; LYR-SHOW.LSP v1.1 [07/01/90] (C) Brother Sanders Design, All Rights Reserved
; Simplified Layer-Identity Manipulation Enhancement: AKA [S.L.I.M.E.]
;------------------------------------------------------------------------------
;
; WHO DOODLED DIDDLY
; ~~~ ~~~~~~~ ~~~~~~
; Randy Sanders (602) 		Voice:      (602) 946-0735
; 4908 N 85th Str		     Modem:      (602) 946-5239
; Scottsdale, AZ 85251		PC-AUG BBS: (602) 952-0638 (Leave MSSG)
;
;                       LYR-TBLS.LSP

;SIMPLIFIED LISP ROUTINE, BASED ON PREVIOUS ROUTINE BY DUFF KIRKLAND
;WRITES A LAYER SORT TO FILE: W/ APPENDED DESCRIPTION OF EACH LAYER.
;UKWORD FROM INSIDE AUTOLISP BY NEW RIDERS PUBLISHING

(defun ukword (bit kwd msg def / inp)
  (if ( and def (/= def ""))
     (setq msg (strcat "\n" msg " <" def ">: ")
           bit (* 2 (fix (/ bit 2)))
     )
     (setq msg (strcat "\n" msg ": "))
  )
  (initget bit kwd)
  (setq inp (getkword msg))
  (if inp inp def)
)

; NO-PATH FROM INSIDE AUTOLISP BY NEW RIDERS PUBLISHING

(defun No-Path ( fname / lngth str chr )
  (setq lngth (1+ (strlen fname))  str "")
  (while
    (and
      (/= 1 lngth)
      (setq lngth (1- lngth) char (substr fname lngth 1))
      (/= "/" char)
      (/= "\\" char)
      (setq str (strcat char str))
  ) );and/if
  str
);defun No-Path

 "ALL ASB BKG CVL DEM ELE EQP FLR INT MOD NEW RCP"


(defun START ( /)
(PROMPT "ALL ASB BKG CVL DEM ELE EQP FLR INT MOD NEW RCP")
(SETQ EXT (STRCAT "." (ukword 1
        "ALL ASB BKG CVL DEM ELE EQP FLR INT MOD NEW RCP"
"Enter Three Letter Extension to open LYR-TBLS File with: " "ALL")))
(SETQ TF (OPEN (STRCAT "D:\\DWG-DATA\\" (NO-PATH (GETVAR "DWGNAME")) EXT) "w"))
(WRITE-LINE (STRCAT "\t" (GETVAR "DWGNAME") EXT) TF)
(WRITE-LINE (STRCAT "\tDATE: "
                    (SUBSTR (RTOS (GETVAR "CDATE") 2 0) 5 2) "/"
                    (SUBSTR (RTOS (GETVAR "CDATE") 2 0) 7 2) "/"
                    (SUBSTR (RTOS (GETVAR "CDATE") 2 0) 3 2)
            ) TF
)
)
(defun layer ( / c d f ln lt ly n x)
   (tblset "layer")
   (WRITE-LINE "\n\t* INDICATES THE CURRENT LAYER:" TF)
   (write-line "\n\t  Layer       Status  Color  Linetype    Description" tf)
   (terpri)
   (setq cl (getvar "clayer"))          ; get current layer
   (setq n  0)
   (setq x  (next T))                   ; get first layer
   (while x
      (setq n  (1+ n)
            ly (fld  2 x)               ; layer name
            ln (fld  6 x)               ; linetype name
            c  (fld 62 x)               ; color number
            f  (logand (fld 70 x) 1)    ; "frozen" flag
            lt (tblsearch "ltype" ln)   ; linetype table entry
      )
      (cond
            ((eq ly "0" ) (setq d "DEFAULT LAYER"))
            ((eq ly "01") (setq d "LOWER WALLS"))
            ((eq ly "02") (setq d "WINDOW FRAMES"))
            ((eq ly "03") (setq d "MOVABLE WINDOWS"))
            ((eq ly "04") (setq d "CORNER WINDOWS"))
            ((eq ly "05") (setq d "CURVED ROOF SECTIONS"))
            ((eq ly "06") (setq d "ROOF-1: LOWER SURFACES"))
            ((eq ly "07") (setq d "ROOF-2: UPPER SURFACES"))
            ((eq ly "08") (setq d "GENERAL SYMBOLS"))
            ((eq ly "09") (setq d "GENERAL DIMENSIONS"))
            ((eq ly "10") (setq d "BUILDING GRID LINES"))
            ((eq ly "DEFPOINTS") (setq d "ASSOC DIMENSION PTS"))  
            (T (setq d "*** NON-STANDARD LAYER ***"))
      ) 
      (write-line
         (strcat "\t"
            (if (= ly cl) "* " "  ")    ; flag current layer
            (strfill ly 12)             ; edit layer name
            (strfill
               (cond ((= f 1) "Frozen") ; edit status
                     ((< c 0) "Off")
                     (T       "On")
               ) 8
            )
            (strfill (itoa (abs c)) 7)  ; edit color number
            (strfill ln 12)             ; edit linetype name
            (substr d 1 30)             ; edit linetype description
         )
      TF )
      (setq x (next nil))               ; get next layer entry
   )
   (princ (if (= n 0) "  -None-\n\n" "\n"))
   nil
)

;  Blank-fill the given string to a specified number of characters

(defun strfill (s len)
   (substr (strcat s "                              ") 1 len)
)

;  Return the value associated with a particular entity field

(defun fld (num lst)
   (cdr (assoc num lst))
)

;  Set up to process specified symbol table.  If TBLSORT is not yet
;  defined, ask user whether the entries should be sorted.  If sorting
;  is enabled, obtain all entries and sort them forming TBLENTS list.

(defun tblset (tbl / new s)
  (textscr)
  (setq xx (getvar "dwgname"))
  (write-line xx)
  (setq tblname tbl)                    ; set table name
  (if (null tblsort) (progn             ; sorting not yet determined
     (initget 1 "Yes No")               ; Establish keywords, no null
     (setq s (getkword "\nSort the entries (Y/N) ? "))
     (setq tblsort (if (= s "Yes") 1 0))
  ))
  (if (= tblsort 1) (progn              ; if sorting is enabled
     (setq tblents nil)                 ; start with null list
     (setq new (cdr (assoc 2 (tblnext tbl T))))   ; get first entry name
     (while new
        (setq tblents (cons new tblents))         ; add to list
        (setq new (cdr (assoc 2 (tblnext tbl))))  ; get next entry name
     )
     (setq tblents (str-sort tblents))            ; sort the name list
  ))
)

;  Obtain next (or first) entry from table, or from sorted entry list.

(defun next (first / temp)
   (if (= tblsort 1) (progn             ; if sorting enabled
      (setq temp (car tblents))         ; get next name from list
      (if temp (progn                   ; if not end of list...
         (setq tblents (cdr tblents))   ; chop from list
         (tblsearch tblname temp)       ; get table entry for this name
      ))
    )
    (tblnext tblname first)             ; else get next (or first) table entry
   )
)


;  Sort a list of strings.

(defun str-sort (x)
  (cond ((null (cdr x)) x)
        (T (str-merge (str-sort (first-half x))
                      (str-sort (last-half x))))))

(defun str-merge (a b)
  (cond ((null a) b)
        ((null b) a)
        ((< (strcmp (car a) (car b)) 0)
           (cons (car a) (str-merge (cdr a) b)))
        (t (cons (car b) (str-merge a (cdr b))))))

(defun first-half (l)
  (head l (1- (length l))))

(defun head (l n)
  (cond ((minusp n) nil)
        (t (cons (car l) (head (cdr l) (- n 2))))))

(defun last-half (l)
  (tail l (1- (length l))))

(defun tail (l n)
  (cond ((minusp n) l)
        (t (tail (cdr l) (- n 2)))))

;  Compare two strings.  Return 0 if they are equal, -1 if the
;  first string is less than the second in ASCII collating sequence,
;  and 1 if the second string is less than the first.

(defun strcmp (a b)
  (cond ((= a b) 0)
        (T (cond ((< (ascii a) (ascii b)) -1)
                 ((> (ascii a) (ascii b))  1)
                 (t (strcmp (substr a 2) (substr b 2)))))))

(defun C:LYR-TBLS (/ MSG TF)
   (start)
   (SETQ MSG (getstring T "\n\tEnter Message: Drawing Status or Nature of Revisions\n")) 
   (WRITE-LINE (STRCAT "\n\t" MSG) TF)
   (setq tblsort nil)                   ; Force "Sort Y/N" query
   (layer)
   (PROMPT (STRCAT "\n\tLAYER-SORT WRITTEN TO FILE < D:\\DWG-DATA\\"
                   (NO-PATH (GETVAR "DWGNAME")) EXT " >"))
   (SETQ TF (CLOSE TF))
   (PRINC)
)