home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 168.img / ACAD3.ZIP / TABLES.LSP < prev    next >
Lisp/Scheme  |  1988-08-30  |  16KB  |  482 lines
  1.  
  2. ;                          TABLES.LSP
  3.  
  4. ;  This is a programming example.
  5. ;  Exerciser for (TBLNEXT) and (TBLSEARCH) functions.
  6.  
  7. ;  The functions (LAYER), (LTYPE), (VIEW), (STYLE), (BLOCK)
  8. ;  (UCS), and (VPORT) can be called independently.  Each lists the 
  9. ;  entries in the associated symbol table, optionally in alphabetical 
  10. ;  order.  The TABLES command ((C:TABLES) function) calls each of them 
  11. ;  in turn.
  12.  
  13. ;  For the layer, linetype, and text style tables, an asterisk in column
  14. ;  one marks the current setting.  If the current linetype is "BYLAYER",
  15. ;  the linetype corresponding to the current layer will be marked with
  16. ;  an "L" in column one.
  17.  
  18. ;  by Duff Kurland - Autodesk, Inc.
  19. ;  October 12, 1986
  20.  
  21. ;  Added (UCS) and (VPORT) - May 1988 
  22.  
  23. ;  (LAYER) - Dump the layer table
  24.  
  25. (defun layer ( / c d f ln lt ly n x)
  26.    (tblset "layer")
  27.    (write-line "  Layer       Status  Color  Linetype    Description")
  28.    (terpri)
  29.    (setq cl (getvar "clayer"))          ; get current layer
  30.    (setq n  0)
  31.    (setq x  (next T))                   ; get first layer
  32.    (while x
  33.       (setq n  (1+ n)
  34.             ly (fld  2 x)               ; layer name
  35.             ln (fld  6 x)               ; linetype name
  36.             c  (fld 62 x)               ; color number
  37.             f  (logand (fld 70 x) 1)    ; "frozen" flag
  38.             lt (tblsearch "ltype" ln)   ; linetype table entry
  39.             d  (fld  3 lt)              ; linetype prose description
  40.       )
  41.       (write-line
  42.          (strcat
  43.             (if (= ly cl) "* " "  ")    ; flag current layer
  44.             (strfill ly 12)             ; edit layer name
  45.             (strfill
  46.                (cond ((= f 1) "Frozen") ; edit status
  47.                      ((< c 0) "Off")
  48.                      (T       "On")
  49.                ) 8
  50.             )
  51.             (strfill (itoa (abs c)) 7)  ; edit color number
  52.             (strfill ln 12)             ; edit linetype name
  53.             (substr d 1 30)             ; edit linetype description
  54.          )
  55.       )
  56.       (setq x (next nil))               ; get next layer entry
  57.    )
  58.    (princ (if (= n 0) "  -None-\n\n" "\n"))
  59.    nil
  60. )
  61.  
  62.  
  63. ;  (LTYPE) - Dump the linetype table
  64.  
  65. (defun ltype ( / a cl d f lt n s x)
  66.    (tblset "ltype")
  67.    (write-line "  Linetype    Align  Segs  Description")
  68.    (terpri)
  69.    (setq cl (getvar "celtype"))         ; get current linetype
  70.    (setq f  "* ")                       ; set default "current" flag
  71.  
  72.    ;  If current linetype is "BYLAYER", look up the linetype
  73.    ;  associated with the current layer, and change the
  74.    ;  "current" flag from "* " to "L ".
  75.  
  76.    (setq cl
  77.       (cond ((= cl "BYBLOCK") "")
  78.             ((= cl "BYLAYER") (setq f "L ")
  79.                               (fld 6 (tblsearch "layer" (getvar "clayer"))))
  80.             (T cl)
  81.       )
  82.    )
  83.    (setq n 0)
  84.    (setq x (next T))                    ; first linetype
  85.    (while x
  86.       (setq n  (1+ n)
  87.             lt (fld  2 x)               ; linetype name
  88.             d  (fld  3 x)               ; linetype prose description
  89.             a  (fld 72 x)               ; alignment code
  90.             s  (fld 73 x)               ; number of dash length items
  91.       )
  92.       (write-line
  93.          (strcat
  94.             (if (= lt cl) f "  ")       ; flag current entity linetype
  95.             (strfill lt 12)             ; edit layer name
  96.             (strfill (chr a) 7)         ; alignment code
  97.             (strfill (itoa s) 6)        ; number of dash length items
  98.             (substr d 1 30)             ; linetype description
  99.          )
  100.       )
  101.       (if (> s 0) (progn
  102.  
  103.          ;  Edit dash length items
  104.  
  105.          (setq x (member (assoc 49 x) x)) ; get list of dash items
  106.          (while x
  107.             (setq s (cdar x))           ; get dash length
  108.             (write-line
  109.                (strcat
  110.                   (strfill " " 27)
  111.                   (cond ((= s 0) "Dot")
  112.                         ((> s 0) (strcat "Pen down " (rtos s 2 4)))
  113.                         (T       (strcat "Pen up   " (rtos (abs s) 2 4)))
  114.                   )
  115.                )
  116.             )
  117.             (setq x (cdr x))            ; get next dash item
  118.          )
  119.       ))
  120.       (setq x (next nil))               ; get next linetype entry
  121.    )
  122.    (princ (if (= n 0) "  -None-\n\n" "\n"))
  123.    nil
  124. )
  125.  
  126.  
  127. ;  (VIEW) - Dump the named view table
  128.  
  129. (defun view ( / c d h n v w x)
  130.    (tblset "view")
  131.    (write-line "  View        Height x Width    Center            Direction")
  132.    (terpri)
  133.    (setq n 0)
  134.    (setq x (next T))                    ; get first view
  135.    (while x
  136.       (setq n  (1+ n)
  137.             v  (fld  2 x)               ; view name
  138.             c  (fld 10 x)               ; center point
  139.             d  (fld 11 x)               ; view direction
  140.             h  (fld 40 x)               ; height
  141.             w  (fld 41 x)               ; width (valid only for windows)
  142.       )
  143.       (write-line
  144.          (strcat
  145.             "  "
  146.             (strfill v 12)              ; edit view name
  147.             (strfill (strcat (rtos h 2 4)   ; edit height x width
  148.                              "x"
  149.                              (rtos w 2 4)) 18
  150.             )
  151.             (strfill (strcat (rtos (car c) 2 4)  ; edit center point
  152.                              ","
  153.                              (rtos (cadr c) 2 4)) 18
  154.             )
  155.             (rtos (car d) 2 4)          ; edit X portion of direction
  156.             ","
  157.             (rtos (cadr d) 2 4)         ; edit Y portion of direction
  158.             ","
  159.             (rtos (caddr d) 2 4)        ; edit Z portion of direction
  160.          )
  161.       )
  162.       (setq x (next nil))               ; get next view entry
  163.    )
  164.    (princ (if (= n 0) "  -None-\n\n" "\n"))
  165.    nil
  166. )
  167.  
  168.  
  169. ;  (STYLE) - Dump the text style table
  170.  
  171. (defun style ( / cs fb ff g h n o s w x)
  172.    (tblset "style")
  173.    (write-line "  Text style  Height  Width   Slant  Flags  Font      Bigfont")
  174.    (terpri)
  175.    (setq cs (getvar "textstyle"))       ; get current style
  176.    (setq n  0)
  177.    (setq x  (next T))                   ; get first style
  178.    (while x
  179.       (setq n  (1+ n)
  180.             s  (fld  2 x)               ; style name
  181.             ff (fld  3 x)               ; primary font file
  182.             fb (fld  4 x)               ; big font file
  183.             h  (fld 40 x)               ; height
  184.             w  (fld 41 x)               ; width factor
  185.             o  (fld 50 x)               ; obliquing angle
  186.             g  (fld 71 x)               ; generation flags
  187.       )
  188.       (write-line
  189.          (strcat
  190.             (if (= s cs) "* " "  ")     ; flag current style
  191.             (strfill s 12)              ; edit style name
  192.             (strfill (rtos h 2 4) 8)    ; height
  193.             (strfill (rtos w 2 4) 8)    ; width factor
  194.             (strfill (angtos o 0 2) 7)  ; obliquing angle
  195.             (strfill (itoa g) 7)        ; generation flags
  196.             (strfill ff 10)             ; primary font file
  197.             fb                          ; big font file
  198.          )
  199.       )
  200.       (setq x (next nil))               ; get next style entry
  201.    )
  202.    (princ (if (= n 0) "  -None-\n\n" "\n"))
  203.    nil
  204. )
  205.  
  206.  
  207. ;  (BLOCK) - Dump the block definition table
  208.  
  209. (defun block ( / b e ec ed et f n o x)
  210.    (tblset "block")
  211.    (write-line "  Block       Flags  Origin")
  212.    (terpri)
  213.    (setq n 0)
  214.    (setq x (next T))                    ; get first block definition
  215.    (while x
  216.       (setq n  (1+ n)
  217.             b  (fld  2 x)               ; block name
  218.             o  (fld 10 x)               ; origin X,Y,Z
  219.             f  (fld 70 x)               ; flags
  220.       )
  221.       (write-line
  222.            (strcat
  223.                 "  "
  224.                 (strfill b 12)          ; edit block name
  225.                 (strfill (itoa f) 7)    ; flags
  226.                 (rtos (car o) 2 4)      ; origin X
  227.                 ","
  228.                 (rtos (cadr o) 2 4)     ; origin Y
  229.                 ","
  230.                 (rtos (caddr o) 2 4)    ; origin Z
  231.            )
  232.       )
  233.  
  234.       ;  Display interesting facts about the entities comprising
  235.       ;  this block definition.
  236.  
  237.       (setq e (fld -2 x))               ; point to first entity
  238.       (while e
  239.            (setq ed (entget e))         ; get the entity data
  240.            (setq et (fld  0 ed))        ; entity type
  241.            (setq ec (fld 62 ed))        ; entity color
  242.            (write-line
  243.                (strcat
  244.                    (strfill " " 14)
  245.                    (strfill et 9)       ; edit entity type
  246.                    " on layer "
  247.                    (fld 8 ed)           ; edit layer name
  248.                    " with color "
  249.                    (cond ((= ec 0)  "BYBLOCK")  ; edit color number
  250.                          ((null ec) "BYLAYER")
  251.                          (T         (itoa ec))
  252.                    )
  253.                )
  254.            )
  255.            (if (setq e (entnext e))     ; if there's another entity,
  256.                (setq ed (entget e))     ;   read its data
  257.            )
  258.       )
  259.       (terpri)
  260.       (setq x (next nil))               ; get next block entry
  261.    )
  262.    (princ (if (= n 0) "  -None-\n\n" "\n"))
  263.    nil
  264. )
  265.  
  266. ;  (UCS) - Dump the UCS table
  267.  
  268. (defun ucs ( / n x na o xd yd)
  269.    (tblset "ucs")
  270.    (write-line "  UCS         Origin            X axis direction    Y axis direction")
  271.    (terpri)
  272.    (setq n  0)
  273.    (setq x  (next T))                   ; get first ucs
  274.    (while x
  275.       (setq n  (1+ n)
  276.             na (fld  2 x)               ; UCS name
  277.             o  (fld 10 x)               ; origin
  278.             xd (fld 11 x)               ; X axis direction
  279.             yd (fld 12 x)               ; Y axis direction
  280.       )
  281.       (write-line
  282.          (strcat
  283.             (if (= na cucs) "* " "  ")  ; flag current UCS
  284.             (strfill na 12)             ; edit UCS name
  285.             (strfill (strcat "("
  286.                (rtos (car o) 2 2)       ; edit UCS origin
  287.                ","
  288.                (rtos (cadr o) 2 2)
  289.                ","
  290.                (rtos (caddr o) 2 2)
  291.                ")") 18)
  292.             (strfill (strcat "("
  293.                (rtos (car xd) 2 2)      ; edit X axis direction
  294.                ","
  295.                (rtos (cadr xd) 2 2)
  296.                ","
  297.                (rtos (caddr xd) 2 2)
  298.                ")") 20)
  299.                "("
  300.                (rtos (car yd) 2 2)      ; edit Y axis direction
  301.                ","
  302.                (rtos (cadr yd) 2 2)        
  303.                ","
  304.                (rtos (caddr yd) 2 2)
  305.                ")"
  306.          )
  307.       )
  308.       (setq x (next nil))               ; get next UCS entry
  309.    )
  310.    (princ (if (= n 0) "  -None-\n\n" "\n"))
  311.    nil
  312. )
  313.  
  314. ;  (VPORT) - Dump the viewport table
  315.  
  316. (defun vport ( / n x na ll ur v)
  317.    (setq prev nil)
  318.    (tblset "vport")
  319.    (write-line "  Viewport    Lower left     Upper Right     View Mode")
  320.    (terpri)
  321.    (setq n  0)
  322.    (setq x  (nextvp T prev))            ; get first viewport
  323.    (while x
  324.       (setq n  (1+ n)
  325.             na (fld  2 x)               ; viewport name
  326.             ll (fld 10 x)               ; lower left corner
  327.             ur (fld 11 x)               ; upper right corner
  328.             v  (fld 71 x)               ; view mode
  329.       )
  330.       (write-line
  331.          (strcat
  332.             "  "
  333.             (strfill na 10)             ; edit viewport name
  334.             "  "
  335.             (strfill (strcat "("        ; edit lower left corner
  336.                (rtos (car ll) 2 2)
  337.                ","
  338.                (rtos (cadr ll) 2 2)
  339.                ")") 15)   
  340.             (strfill (strcat "("        ; edit upper right corner
  341.                (rtos (car ur) 2 2)
  342.                ","
  343.                (rtos (cadr ur) 2 2)
  344.                ")") 15)
  345.             " "
  346.             (rtos v 2 2)                ; edit view mode
  347.          )
  348.      )
  349.       (setq x (nextvp nil prev))        ; get next viewport entry
  350.    )
  351.    (princ (if (= n 0) "  -None-\n\n" "\n"))
  352.    nil
  353. )
  354.  
  355. ;  Blank-fill the given string to a specified number of characters
  356.  
  357. (defun strfill (s len)
  358.    (substr (strcat s "                              ") 1 len)
  359. )
  360.  
  361. ;  Return the value associated with a particular entity field
  362.  
  363. (defun fld (num lst)
  364.    (cdr (assoc num lst))
  365. )
  366.  
  367. ;  Set up to process specified symbol table.  If TBLSORT is not yet
  368. ;  defined, ask user whether the entries should be sorted.  If sorting
  369. ;  is enabled, obtain all entries and sort them forming TBLENTS list.
  370.  
  371. (defun tblset (tbl / new s)
  372.   (textscr)
  373.   (setq tblname tbl)                    ; set table name
  374.   (if (null tblsort) (progn             ; sorting not yet determined
  375.      (initget 1 "Yes No")               ; Establish keywords, no null
  376.      (setq s (getkword "\nSort the entries (Y/N) ? "))
  377.      (setq tblsort (if (= s "Yes") 1 0))
  378.   ))
  379.   (if (= tblsort 1) (progn              ; if sorting is enabled
  380.      (setq tblents nil)                 ; start with null list
  381.      (setq new (cdr (assoc 2 (tblnext tbl T))))   ; get first entry name
  382.      (while new
  383.         (setq tblents (cons new tblents))         ; add to list
  384.         (setq new (cdr (assoc 2 (tblnext tbl))))  ; get next entry name
  385.      )
  386.      (setq tblents (str-sort tblents))            ; sort the name list
  387.   ))
  388. )
  389.  
  390. ;  Obtain next (or first) entry from table, or from sorted entry list.
  391.  
  392. (defun next (first / temp)
  393.    (if (= tblsort 1) (progn             ; if sorting enabled
  394.       (setq temp (car tblents))         ; get next name from list
  395.       (if temp (progn                   ; if not end of list...
  396.          (setq tblents (cdr tblents))   ; chop from list
  397.          (tblsearch tblname temp)       ; get table entry for this name
  398.       ))
  399.     )
  400.     (tblnext tblname first)             ; else get next (or first) table entry
  401.    )
  402. )
  403.  
  404. ;  Obtain next (or first) vports entry from table, or from sorted entry list.
  405.  
  406. (defun nextvp (first prev / temp)
  407.    (if (= tblsort 1) (progn             ; if sorting enabled
  408.       (if first
  409.          (setq temp (car tblents))      ; get first name from list
  410.          (progn
  411.             (setq prev (car tblents))   ; store previous name
  412.             (setq temp (cadr tblents))  ; get next name from list
  413.          )
  414.       )
  415.       (if temp (progn
  416.          (if (null first)
  417.             (setq tblents (cdr tblents)); chop from list
  418.          )
  419.          (if (= prev temp) (progn
  420.             (setq prev temp)
  421.             (tblnext tblname first)     ; get next table entry
  422.             )(progn
  423.             (setq prev temp)
  424.             (tblsearch tblname temp T)  ; get table entry for this name
  425.          ))
  426.       ))
  427.       )
  428.       (tblnext tblname first)           ; else get next (or first) table entry
  429.    )
  430. )
  431.  
  432. ;  Sort a list of strings.
  433.  
  434. (defun str-sort (x)
  435.   (cond ((null (cdr x)) x)
  436.         (T (str-merge (str-sort (first-half x))
  437.                       (str-sort (last-half x))))))
  438.  
  439. (defun str-merge (a b)
  440.   (cond ((null a) b)
  441.         ((null b) a)
  442.         ((< (strcmp (car a) (car b)) 0)
  443.            (cons (car a) (str-merge (cdr a) b)))
  444.         (t (cons (car b) (str-merge a (cdr b))))))
  445.  
  446. (defun first-half (l)
  447.   (head l (1- (length l))))
  448.  
  449. (defun head (l n)
  450.   (cond ((minusp n) nil)
  451.         (t (cons (car l) (head (cdr l) (- n 2))))))
  452.  
  453. (defun last-half (l)
  454.   (tail l (1- (length l))))
  455.  
  456. (defun tail (l n)
  457.   (cond ((minusp n) l)
  458.         (t (tail (cdr l) (- n 2)))))
  459.  
  460. ;  Compare two strings.  Return 0 if they are equal, -1 if the
  461. ;  first string is less than the second in ASCII collating sequence,
  462. ;  and 1 if the second string is less than the first.
  463.  
  464. (defun strcmp (a b)
  465.   (cond ((= a b) 0)
  466.         (T (cond ((< (ascii a) (ascii b)) -1)
  467.                  ((> (ascii a) (ascii b))  1)
  468.                  (t (strcmp (substr a 2) (substr b 2)))))))
  469.  
  470. ;  Dump all the symbol tables
  471.  
  472. (defun C:TABLES ()
  473.    (setq tblsort nil)                   ; Force "Sort Y/N" query
  474.    (layer)
  475.    (ltype)
  476.    (view)
  477.    (style)
  478.    (block)
  479.    (ucs)
  480.    (vport)
  481. )
  482.