home *** CD-ROM | disk | FTP | other *** search
/ BUG 15 / BUGCD1998_06.ISO / aplic / felixcad / fcaddata.z / FLX_QLAY.LSP < prev    next >
Lisp/Scheme  |  1996-09-30  |  12KB  |  314 lines
  1. ;;; FLX_QLAY.LSP
  2. ;;; ===========================================================
  3. ;;; Provided for FelixCAD
  4. ;;; Created:     Dec 20, 1995 / dn
  5. ;;; Modified:    Sep 29, 1996 / vp
  6. ;;; ===========================================================
  7. ;;; Commands: QLAYER
  8. ;;; Quick layer control by selecting reference element
  9. ;;; ===========================================================
  10.  
  11. (defun FLX_QLAYER ( / prt_list l1 l2 l3 selstrlist mod lst el 
  12.                       lstlay change_how GETAUSLAY GETFRLAY
  13.                       TOGGLE_ALL_LAY LAYERCONTROL_OK
  14.                       CHANGELAY DlgInit)
  15.  
  16.   (FLX_FUNC_INIT)
  17.  
  18.   ;;; Prompt List
  19.  
  20.   (setq prt_list (list
  21.             "Please select only ONE layer name!" ;;;@ 0
  22.             "Set Layer"              ;;;@ 1 Title Alert
  23.             "Layer does not exist: " ;;;@2
  24.             "\nLayer unlocked: "     ;;;@3
  25.             "\nLayer thawed: "       ;;;@4
  26.             "\nLayer locked: "       ;;;@5
  27.             "\nLayer freezed: "      ;;;@6
  28.             "New current layer: "    ;;;@7
  29.             "Turn off the CURRENT layer?"  ;;;@8
  30.             "\nLayer turned off: "         ;;;@9
  31.             "\nLayer turned off: "         ;;;@10
  32.             "\nLayer already turned off: " ;;;@11
  33.             "\nLayer turned on: "          ;;;@12
  34.             "\nLayer already turned on: "  ;;;@13
  35.             "The current layer cannot be freezed!" ;;;@14 
  36.             "On..."     ;;;@15 # initget
  37.             "Thaw..."   ;;;@16 # initget
  38.             "Select reference entity to set layer: "      ;;;@17
  39.             "Select reference entity to turn layer off: " ;;;@18
  40.             "Select reference entity to lock layer: "     ;;;@19
  41.             "Select reference entity to freeze layer: "   ;;;@20
  42.             "Alert"                                       ;;;@21
  43.             "Select reference entity to unlock layer: "   ;;;@22
  44.             "Off Lock Freeze Unlock On... Thaw..."        ;;;@23 # initget
  45.             "Off"     ;;;@24 # initget
  46.             "Lock"    ;;;@25 # initget
  47.             "Freeze"  ;;;@26 # initget
  48.             "Unlock"  ;;;@27 # initget
  49.             "New current layer: " ;;;@28
  50.     ))
  51.  
  52.     (if FLX_XLANGUAGE (FLX_XLANGUAGE "_qlay" nil))
  53.  
  54.   ;;;---------------------------------------------------------------------
  55.   ;;; Functions for Layer Dialog
  56.   ;;;---------------------------------------------------------------------
  57.   (defun GETAUSLAY( / x tmp)
  58.      (setq x 0 ret "")
  59.      (while (< x (length lstlay))
  60.         (setq tmp (tblsearch "LAYER" (nth x lstlay)))
  61.         (if (and tmp (< (cdr (assoc 62 tmp)) 0))
  62.              (setq ret (strcat ret (symbtos x) " "))
  63.         )
  64.         (setq x (+ x 1)) 
  65.      )
  66.      (setq ret ret)
  67.   )
  68.   ;;;---------------------------------------------------------------------
  69.   (defun GETFRLAY()
  70.     (setq x 0 ret "")
  71.     (while (< x (length lstlay))
  72.        (setq tmp (tblsearch "LAYER" (nth x lstlay)))
  73.        (IF (and tmp (= (logand 1 (cdr (assoc 70 tmp))) 1))
  74.          (setq ret (strcat ret (symbtos x) " "))
  75.        )
  76.       (setq x (+ x 1)) 
  77.     )
  78.     (setq ret ret)
  79.   )
  80.   ;;;---------------------------------------------------------------------
  81.   (defun TOGGLE_ALL_LAY ( / x s)  
  82.     (if (= $value "1")
  83.       (progn
  84.          (setq x 0 s "")
  85.          (while (<= x (length lstlay))
  86.             (setq s (strcat s (symbtos x) " "))
  87.             (setq x (+ x 1))
  88.          ) 
  89.          (Dlg_TileSet "layer" s)
  90.       )
  91.       (Dlg_ListStart "layer")
  92.       (mapcar 'Dlg_ListAdd lstlay)
  93.       (Dlg_ListEnd)
  94.     )
  95.   )
  96.   ;;;---------------------------------------------------------------------
  97.   (defun LAYERCONTROL_OK ()
  98.     (if (= (Dlg_TileGet "L_set")  "1") (setq mod 0))
  99.     (if (= (Dlg_TileGet "L_off")  "1") (setq mod 1))
  100.     (if (= (Dlg_TileGet "L_lock") "1") (setq mod 2))
  101.     (if (= (Dlg_TileGet "L_freeze") "1") (setq mod 3))
  102.     (if (= (Dlg_TileGet "L_on")   "1") (setq mod 4))
  103.     (if (= (Dlg_TileGet "L_free") "1") (setq mod 5))
  104.     (if (= (Dlg_TileGet "L_thaw") "1") (setq mod 6))
  105.     (if (setq lst (Dlg_TileGet "layer"))
  106.         (setq lst (read (strcat "(" lst ")" )))
  107.     )
  108.     (if (AND (> (length lst) 1) (= mod 0))
  109.          (ALERT
  110.             (nth 0 prt_list) ;;;@"Please select only ONE layer name!" 
  111.             (nth 1 prt_list) ;;;@"Set Layer"   
  112.             "EXCLAMATION"
  113.          )
  114.          (progn 
  115.              (if (AND (= (length lst) 0)(= mod 1))
  116.                  (setq lst (list (getvar "CLAYER"))) 
  117.              )
  118.              (Dlg_DialogDone)
  119.          )
  120.     )     
  121.   )
  122.   ;;;-------------------------------------------------------------------
  123.   ;;; CHANGE LAYER PROPERTIES
  124.   ;;; lay: Layer name 
  125.   ;;; change_how: 0=set 1=off 2=lock 3=freeze 4=on 5=free 6=thaw
  126.   ;;;-------------------------------------------------------------------
  127.   (defun CHANGELAY (lay change_how / tmp fr sp x melde)
  128.     (if (not (setq tmp (tblsearch "LAYER" lay)))
  129.         (ALERT 
  130.             (strcat (nth 2 prt_list)  lay)   ;;;@"Layer does not exist: " 
  131.             (nth 21 prt_list)
  132.             "EXCLAMATION"
  133.         )
  134.         (progn
  135.           (setq sp (logand 4 (cdr (assoc 70 tmp))))
  136.           (setq fr (logand 1 (cdr (assoc 70 tmp))))
  137.           (if (= change_how 5) (setq sp 0 melde (nth 3 prt_list))) ;;;@\nLayer unlocked: 
  138.           (if (= change_how 6) (setq fr 0 melde (nth 4 prt_list))) ;;;@\nLayer thawed: 
  139.           (if (= change_how 2) (setq sp 4 melde (nth 5 prt_list))) ;;;@\nLayer locked: 
  140.           (if (= change_how 3) (setq fr 1 melde (nth 6 prt_list))) ;;;@\nLayer freezed: 
  141.           (cond 
  142.              ((= change_how 0)
  143.               (setvar "CLAYER" lay)
  144.               (princ (nth 7 prt_list))  ;;;@\nNew current layer: 
  145.               (princ lay)
  146.              )
  147.              ((= change_how 1)   ;;; Off
  148.               (if (> (setq x (cdr (assoc 62 tmp))) 0)
  149.                  (progn
  150.                    (setq x (* x -1))
  151.                    (setq tmp (subst (cons 62 x) (assoc 62 tmp) tmp))
  152.                    (if (= (strcase lay) (getvar "CLAYER"))
  153.                       (if (ALERT
  154.                             (nth 8 prt_list)  ;;;@Turn off the CURRENT layer?
  155.                             (nth 21 prt_list) ;;;@Alert
  156.                             "QUESTION"
  157.                           )
  158.                            (if (tblmod tmp) (princ (strcat 
  159.                               (nth 9 prt_list)  ;;;@\nLayer turned off: 
  160.                               lay
  161.                            )))
  162.                       )
  163.                       (if (tblmod tmp) (princ (strcat
  164.                                 (nth 10 prt_list)  ;;;@\nLayer turned off: 
  165.                                lay
  166.                       )))
  167.                    )
  168.                  )
  169.                  (princ (strcat
  170.                        (nth 11 prt_list)  ;;;@\nLayer already turned off: 
  171.                        lay
  172.                  ))
  173.               ) 
  174.             ) ;;; 1
  175.             ((= change_how 4)   ;;; On
  176.              (if (< (setq x (cdr (assoc 62 tmp))) 0)
  177.                (progn
  178.                  (setq x (* x -1))
  179.                  (setq tmp (subst (cons 62 x) (assoc 62 tmp) tmp))
  180.                  (if (tblmod tmp) (princ (strcat
  181.                        (nth 12 prt_list)  ;;;@\nLayer turned on: 
  182.                        lay
  183.                  )))    
  184.                )
  185.                (princ (strcat
  186.                     (nth 13 prt_list)  ;;;@\nLayer already turned on: 
  187.                    lay
  188.                ))
  189.              ) 
  190.             ) ;;; 4
  191.             (T       ;;; FREI/SP/FR/TAU
  192.               (setq x (logior sp fr (if (= lay "0") 64 0))) 
  193.               (setq tmp (subst (cons 70 x) (assoc 70 tmp) tmp))
  194.               (if (and (= lay (getvar "CLAYER"))(= fr 1))
  195.                 (ALERT
  196.                     (nth 14 prt_list)  ;;;@The current layer cannot be freezed!
  197.                     (nth 21 prt_list)  ;;;@Alert 
  198.                     "EXCLAMATION"
  199.                 ) 
  200.                 (if (tblmod tmp)(princ (strcat melde lay)))
  201.               )  
  202.             )  ;;; T
  203.           )  ;;; cond
  204.         )
  205.     )
  206.     (princ)   
  207.   )
  208.   ;;;---------------------------------------------------------------------
  209.   (defun DlgInit ( / s1)
  210.       (if FLX$WIN95 (foreach n 
  211.           '("IDCANCEL" "IDOK" "IDHELP" 
  212.             "layer" "EditCurr" "LayControl" "L_set" "SelectAll"
  213.             "L_on" "L_off" "L_free" "L_lock" "L_thaw" "L_freeze"
  214.             "Static1" "Static2" "Static3" "Static4")
  215.           (Dlg_TileSetFont n 2)
  216.       ))
  217.     (Dlg_TileAction "IDOK" "(LAYERCONTROL_OK)")
  218.     (Dlg_TileAction "IDCANCEL" "(setq lst nil mod nil)(Dlg_DialogDone)")
  219.     (setq lstlay '())
  220.     (if (setq s1 (tblnext "LAYER" T))
  221.         (progn
  222.           (setq lstlay (cons (cdr (assoc 2 s1)) lstlay))
  223.           (while (setq s1 (tblnext "LAYER")) 
  224.                  (setq lstlay (append lstlay (list (cdr (assoc 2 s1)))))
  225.           )
  226.         )
  227.     )
  228.     (Dlg_ListStart "layer")
  229.     (mapcar 'Dlg_ListAdd lstlay)
  230.     (Dlg_ListEnd)
  231.     (cond 
  232.        ((= l1 (nth 15 prt_list))   ;;;@On...
  233.         (Dlg_TileSet "L_on" "1")
  234.         (Dlg_TileSet "layer" (GETAUSLAY))
  235.        )
  236.        ((= l1  (nth 16 prt_list))   ;;;@Thaw...
  237.         (Dlg_TileSet "L_thaw" "1")
  238.         (Dlg_TileSet "layer" (GETFRLAY))
  239.        )         
  240.        ((= mod 0) (Dlg_TileSet "L_set" "1"))
  241.        ((= mod 1) (Dlg_TileSet "L_off" "1"))
  242.        ((= mod 2) (Dlg_TileSet "L_lock" "1"))
  243.        ((= mod 3) (Dlg_TileSet "L_freeze" "1"))
  244.        ((= mod 4) (Dlg_TileSet "L_on" "1"))
  245.        ((= mod 5) (Dlg_TileSet "L_free" "1"))
  246.        ((= mod 6) (Dlg_TileSet "L_thaw" "1"))     
  247.     )
  248.     (Dlg_TileSet "EditCurr" (getvar "CLAYER"))
  249.     (Dlg_TileAction "layer" "(if (= $reason 4)(LAYERCONTROL_OK))")
  250.     (Dlg_TileAction "SelectAll" "(TOGGLE_ALL_LAY)")
  251.   ) ;DlgInit
  252.   ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  253.   ;;; MAIN
  254.   ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  255.    (setq mod 0)     ;;; Mode 0 = Set layer 
  256.    (setq selstrlist (list
  257.       (nth 17 prt_list)   ;;;@\nSelect reference entity to set layer: 
  258.       (nth 18 prt_list)   ;;;@\nSelect reference entity to turn layer off: 
  259.       (nth 19 prt_list)   ;;;@\nSelect reference entity to lock layer: 
  260.       (nth 20 prt_list)   ;;;@\nSelect reference entity to freeze layer: 
  261.       (nth 21 prt_list)   ;;;@""
  262.       (nth 22 prt_list)   ;;;@\nSelect reference entity to unlock layer: 
  263.    ))
  264.    (while (not l1)
  265.       (initget 256 (nth 23 prt_list)) ;;;@Off Lock Freeze Unlock On... Thaw... 
  266.       (setq l1 (entsel (nth mod selstrlist)))
  267.       ;;; If no entity has been selected, a dialog box comes up with a layer list.
  268.       (cond
  269.         ((= l1 (nth 24 prt_list)) ;;;@Off
  270.          (setq mod 1 l1 nil)
  271.         )
  272.         ((= l1 (nth 25 prt_list)) ;;;@Lock
  273.          (setq mod 2 l1 nil)
  274.         )
  275.         ((= l1 (nth 26 prt_list)) ;;;@Freeze
  276.          (setq mod 3 l1 nil)
  277.         )
  278.         ((= l1 (nth 27 prt_list)) ;;;@Unlock
  279.          (setq mod 5 l1 nil)
  280.         )
  281.         ((= (type l1) 'LIST)      ;;; Reference entity picked... 
  282.          (princ)
  283.         )
  284.         (T
  285.           (if (FLX_DLGDSP "flx_dlg" "LayerSet" "(princ)" "(DlgInit)") (princ) (exit) )
  286.           (setq l1 T)
  287.         )     
  288.       )  ; cond
  289.    ) ; while
  290.    (if (= (type l1) 'LIST)  ;;; IF Reference entity has bee picked...  
  291.      (progn 
  292.         (setq l2 (entget (car l1)))
  293.         (setq l3 (cdr (assoc 8 l2)))
  294.         (cond 
  295.           ((= mod 0)
  296.            (setvar "CLAYER" l3)
  297.            (princ (nth 28 prt_list))   ;;;@\nNew current layer: 
  298.            (princ l3)
  299.           )
  300.           (T (CHANGELAY l3 mod))   
  301.         )
  302.      )
  303.      (progn   ;;; ELSE via dialog !
  304.         (if (AND lst mod) (foreach el lst (CHANGELAY (nth el lstlay) mod))) 
  305.      )
  306.    )
  307.    (FLX_FUNC_EXIT)
  308.    (princ)
  309. )
  310.  
  311. (princ)
  312.  
  313.  
  314.