home *** CD-ROM | disk | FTP | other *** search
/ BUG 15 / BUGCD1998_06.ISO / aplic / felixcad / fcaddata.z / FLX_TABM.LSP < prev    next >
Lisp/Scheme  |  1996-09-30  |  9KB  |  240 lines
  1. ;;; FLX_TABM.LSP
  2. ;;; ===========================================================
  3. ;;; (C)opyright: Felix Computer Aided Technologies GmbH 1995-96
  4. ;;; Created:     May 29, 1996 dn
  5. ;;; Modified:    Sep 25, 1996 vp
  6. ;;; ===========================================================
  7. ;;; Command: TABSERVICE
  8. ;;; Dialog to modify drawing symbol tables:
  9. ;;; Delete, rename, purge table entries
  10. ;;; ===========================================================
  11.  
  12. (defun FLX_TABSERVICE ( / prt_list dlg_id dlg_file ret tables 
  13.                  Dlg_Init_Func SET_DLG SHOW_TABLE_ENTRIES 
  14.                  TABLE_RENAME TABLE_DELETE TABLE_PURGE FILTER_NAME)
  15.   
  16.   (setq prt_list (list
  17.      "No item!"                          ;0 
  18.      "not referenced"                    ;1
  19.      "Cannot rename this entry in '"     ;2
  20.      "'!"                                ;3
  21.      "These entries cannot be deleted: " ;4
  22.      "Alert"                             ;5
  23.      "No item in this table!"            ;6
  24.   ))
  25.   (if FLX_XLANGUAGE (FLX_XLANGUAGE "_tabm" nil))
  26.  
  27.   ;;; -------------------------------------------------------------------
  28.  
  29.   (setq tables 
  30.     (list "BLOCK" "DIMSTYLE" "LAYER" "LTYPE" "STYLE" "UCS" "VIEW")
  31.   ) 
  32.  
  33.   ;;;---------------------------------------------------------------------
  34.   ;;; One or more entries have been selected from the list box...
  35.   ;;;---------------------------------------------------------------------
  36.  
  37.   (defun SET_DLG  ( / sel_ent tmp tname)
  38.     (setq tname (Dlg_TileGet "tables"))
  39.     (Dlg_ListStart "table_entries" 12)
  40.     (while (setq tmp (Dlg_ListGet)) 
  41.       (setq sel_ent (cons (FILTER_NAME (cadr tmp)) sel_ent))
  42.     )
  43.     (Dlg_ListEnd)
  44.     (cond 
  45.      ((= (length sel_ent) 0)
  46.       (Dlg_TileSet  "edit_name" "")
  47.       (Dlg_TileMode "edit_name" 1)
  48.       (Dlg_TileMode "rename" 1)
  49.       (Dlg_TileMode "delete" 1)
  50.      )
  51.      ((= (length sel_ent) 1)
  52.       (if (OR 
  53.            (AND (= tname "LAYER")(= (car sel_ent) "0"))
  54.            (AND (= tname "STYLE")(= (car sel_ent) "STANDARD"))
  55.            (AND (= tname "LTYPE")(= (car sel_ent) "CONTINUOUS"))
  56.           )
  57.         (progn 
  58.              (Dlg_TileMode "delete" 1)
  59.              (Dlg_TileMode "rename" 1)
  60.              (Dlg_TileMode "edit_name" 1)
  61.              (Dlg_TileSet  "edit_name" "")
  62.         )
  63.         (progn 
  64.             (Dlg_TileMode "delete" 0)
  65.             (Dlg_TileMode "rename" 0)
  66.             (Dlg_TileMode "edit_name" 0)
  67.             (Dlg_TileSet  "edit_name" (car sel_ent))
  68.         )
  69.       )     
  70.      )
  71.      ((> (length sel_ent) 1)
  72.       (Dlg_TileMode "rename"    1)
  73.       (Dlg_TileMode "delete"    0)
  74.       (Dlg_TileMode "edit_name" 1)
  75.       (Dlg_TileSet  "edit_name" "")
  76.      )       
  77.     )
  78.   ) 
  79.  
  80.   ;;;---------------------------------------------------------------------------
  81.   ;;; Display all entries of a table in list box 
  82.   ;;;---------------------------------------------------------------------------
  83.  
  84.   (defun SHOW_TABLE_ENTRIES (name / el tmp tlst ref)
  85.     (setq tlst '())
  86.     (Dlg_TileSet "edit_name" "")
  87.     (Dlg_TileMode "delete" 1)
  88.     (Dlg_TileMode "rename" 1)
  89.     (Dlg_TileMode "purge"  6)     ;;; invisible
  90.     (Dlg_TileMode "edit_name" 1)
  91.     (if (not (setq tmp (tblnext name T)))
  92.       (progn 
  93.         (Dlg_TileSet "message" (nth 0 prt_list)) ;;;@No item!
  94.         (Dlg_ListStart "table_entries" 3)(Dlg_ListEnd)    
  95.         (Dlg_TileMode "purge" 6)  
  96.        )
  97.        (progn
  98.           (if (AND (/= name "DIMSTYLE")(/= name "UCS")(/= name "VIEW"))
  99.              (setq ref 
  100.                (if (/= (logand 64 (cdr (assoc 70 tmp))) 64)
  101.                    (strcat "\t*" (nth 1 prt_list) "*") ;;;@\t*not referenced*
  102.                    "" ; else
  103.                )
  104.              )
  105.              (setq ref "") ; else
  106.           )   
  107.           (setq tlst (cons (strcat (strcase (cdr (assoc 2 tmp))) ref ) tlst))
  108.           (Dlg_TileSet "message" "")
  109.           (Dlg_TileMode "purge" 5)
  110.           (while (setq tmp (tblnext name)) 
  111.             (if (AND (/= name "DIMSTYLE")(/= name "UCS")(/= name "VIEW"))
  112.               (setq ref (if (/= (logand 64 (cdr (assoc 70 tmp))) 64)
  113.                         (strcat "\t*" (nth 1 prt_list) "*") ;;;@\t*not referenced*
  114.                         ""
  115.                ))
  116.                (setq ref "")
  117.             )   
  118.             (setq tlst (cons (strcat (strcase (cdr (assoc 2 tmp))) ref) tlst)) 
  119.           )
  120.           (setq tlst (reverse tlst))
  121.           (Dlg_ListSetTabstops "table_entries" "15")
  122.           (Dlg_ListStart "table_entries")(mapcar 'Dlg_ListAdd tlst)(Dlg_ListEnd) 
  123.          )
  124.       )
  125.   )
  126.  
  127.   ;;;---------------------------------------------------------------------------
  128.   ;;; Rename table entry
  129.   ;;;---------------------------------------------------------------------------
  130.  
  131.   (defun TABLE_RENAME ( / newname oldname tname)
  132.     (setq newname (Dlg_TileGet "edit_name"))
  133.     (Dlg_ListStart "table_entries" 12)
  134.     (setq oldname (filter_name (cadr (Dlg_ListGet))))
  135.     (Dlg_ListEnd)
  136.     (setq tname (Dlg_TileGet "tables"))
  137.     (if (/= newname oldname)
  138.       (progn
  139.         (if (tblrename tname oldname newname)
  140.           (SHOW_TABLE_ENTRIES tname)
  141.           (alert 
  142.             (strcat (nth 2 prt_list) newname (nth 3 prt_list)) ;;;@
  143.             (strcat tname ": " oldname)
  144.             "STOP" 
  145.            )
  146.          ) 
  147.        ) 
  148.     )
  149.   )
  150.  
  151.   ;;;---------------------------------------------------------------------------
  152.   ;;; Delete table entry
  153.   ;;;---------------------------------------------------------------------------
  154.  
  155.   (defun TABLE_DELETE ( / newname oldname tname tmp delnames delstr el separator)
  156.     (setq tname (Dlg_TileGet "tables"))
  157.     (Dlg_ListStart "table_entries" 12)
  158.     (while (setq tmp (Dlg_ListGet)) 
  159.         (if (not (tbldel tname (filter_name (cadr tmp))))
  160.             (setq delnames (append delnames (list (filter_name (cadr tmp)))))
  161.         )   
  162.     )
  163.     (Dlg_ListEnd)
  164.     (if delnames 
  165.        (progn 
  166.          (setq delstr tname separator ":\n")
  167.          (foreach el delnames 
  168.            (setq delstr (strcat delstr separator el))
  169.            (setq separator ", ")
  170.          )
  171.          (alert 
  172.             (strcat (nth 4 prt_list) "\n" delstr)
  173.             (nth 5 prt_list)
  174.             "INFORMATION" 
  175.          )
  176.        )
  177.      )
  178.     (SHOW_TABLE_ENTRIES tname)
  179.   ) 
  180.  
  181.   ;;;---------------------------------------------------------------------------
  182.   ;;; Purge entire table
  183.   ;;;---------------------------------------------------------------------------
  184.  
  185.   (defun TABLE_PURGE ( / tname tmp)
  186.     (setq tname (Dlg_TileGet "tables"))
  187.     (tblpurge tname 0)
  188.     (SHOW_TABLE_ENTRIES tname)
  189.   ) 
  190.  
  191.   ;;;---------------------------------------------------------------------------
  192.   ;;; Read from string end to tab stop, truncate from tab stop if neccessary 
  193.   ;;;---------------------------------------------------------------------------
  194.  
  195.   (defun FILTER_NAME (name / ret i)
  196.     (if (wcmatch name "*\t*")
  197.       (progn
  198.         (setq i (strlen name))
  199.         (while (AND (> i 0)(not ret))
  200.           (if (= (substr name i 1) "\t") (setq ret (substr name 1 (- i 1))))
  201.           (setq i (- i 1))
  202.         )
  203.       )
  204.     )  
  205.     (if (not ret) name ret)
  206.   )
  207.  
  208.   ;;;---------------------------------------------------------------------
  209.   ;;; Dialog initialization function
  210.   ;;;---------------------------------------------------------------------
  211.  
  212.   (defun Dlg_Init_Func ( / i n)
  213.    (if FLX$WIN95 (foreach n 
  214.      '("IDOK" "Static1" "message" "tables" "purge" "rename" "delete"
  215.        "edit_name" "table_entries" "GroupBox1")
  216.          (Dlg_TileSetFont n 2)
  217.    ))  
  218.    (Dlg_ListStart "tables")(mapcar 'Dlg_ListAdd tables)(Dlg_ListEnd) ; fill list box
  219.    (Dlg_TileSet   "tables" "LAYER")
  220.    (SHOW_TABLE_ENTRIES "LAYER")  ; LAYER table is default table
  221.    (Dlg_TileAction "tables" "(SHOW_TABLE_ENTRIES $value)")
  222.    (Dlg_TileAction "table_entries" "(SET_DLG)")
  223.    (Dlg_TileAction "rename" "(TABLE_RENAME)")
  224.    (Dlg_TileAction "delete" "(TABLE_DELETE)")
  225.    (Dlg_TileAction "purge"  "(TABLE_PURGE)")
  226.   )
  227.  
  228.   ;;;---------------------------------------------------------------------------
  229.   ;;; MAIN
  230.   ;;;---------------------------------------------------------------------------
  231.   
  232.   (FLX_FUNC_INIT) ;;; Global Error Handler
  233.   (if (FLX_DLGDSP "flx_dlg" "TablesModify" "(princ)" "(Dlg_Init_Func)") (princ)(exit))
  234.   (FLX_FUNC_EXIT) (setq *error* nil)
  235.   (princ)
  236. )
  237.  
  238. (princ)
  239.  
  240.