home *** CD-ROM | disk | FTP | other *** search
/ BUG 15 / BUGCD1998_06.ISO / aplic / felixcad / fcaddata.z / FLX_PAL.LSP < prev    next >
Lisp/Scheme  |  1996-09-30  |  8KB  |  235 lines
  1. ;;; FLX_PAL.LSP
  2. ;;; =========================================================================
  3. ;;; Palette Manager
  4. ;;; =========================================================================
  5. ;;; (C)opyright Felix Computer Aided Technologies GmbH 1995-96
  6. ;;; =========================================================================
  7. ;;; PALMAN ... reads parameter file: <menuname>.PAL !
  8. ;;; 
  9. ;;; Format of the parameter file:: 
  10. ;;;        description1
  11. ;;;        mnp-name1.mnp
  12. ;;;        description2
  13. ;;;        mnp-name2.mnp
  14. ;;;        ...
  15. ;;; =========================================================================
  16.  
  17. (defun FLX_PALMAN ( / prt_list  
  18.                       PAL_START PAL_INIT SET_PAL GET_FNAME GET_FREE_PAL
  19.                       PAL_GETVAR PAL_TileSet
  20.                       pal1 pal2 pal3 pal4 pal5 pal6 pal7 pal8 pal9 pal10
  21.                       p_id ln descrip_list mnp_list pal_new set_new_mnp
  22.                       cmde mnu_name tmpl) 
  23.  
  24.   ;;; Prompt List
  25.  
  26.   (setq prt_list (list
  27.        "Palette File "
  28.        "Parameter File "
  29.        " not found!"
  30.        "Alert"
  31.   ))  
  32.   (if FLX_XLANGUAGE (FLX_XLANGUAGE "_pal" nil))
  33.  
  34.   ;--------------------------------------------------------------------------
  35.   (defun PAL_START()
  36.     (setq cmde (getvar "CMDECHO"))
  37.     (setvar "CMDECHO" 0)
  38.     (if pal_new (progn
  39.       (if (findfile set_new_mnp)
  40.         (command ".PALOPEN" (strcat "P" (itoa pal_new)) "Auto" set_new_mnp)
  41.         (alert
  42.            ;;;@Palette File @ not found!
  43.            (strcat (nth 0 prt_list) set_new_mnp (nth 2 prt_list) )
  44.            (nth 3 prt_list)  ;;;@Alert
  45.            "EXCLAMATION"
  46.         )
  47.       )
  48.     ))    
  49.     (PAL_GETVAR)
  50.     (PAL_TileSet pal1 "pal1")
  51.     (PAL_TileSet pal2 "pal2")
  52.     (PAL_TileSet pal3 "pal3")
  53.     (PAL_TileSet pal4 "pal4")
  54.     (PAL_TileSet pal5 "pal5")
  55.     (PAL_TileSet pal6 "pal6")
  56.     (PAL_TileSet pal7 "pal7")
  57.     (PAL_TileSet pal8 "pal8")
  58.     (PAL_TileSet pal9 "pal9")
  59.     (PAL_TileSet pal10 "pal10")
  60.     (setvar "CMDECHO" cmde)
  61.   ) 
  62.   ;--------------------------------------------------------------------------
  63.   (defun PAL_INIT ( / el tmpl nr)
  64.     (if FLX$WIN95
  65.       (progn
  66.          (foreach n 
  67.             '("IDCANCEL" "IDOK" "IDHELP" "paletten" 
  68.               "setpal1" "setpal2" "setpal3" "setpal4" "setpal5"  
  69.               "setpal6" "setpal7" "setpal8" "setpal9" "setpal10" 
  70.               "pal1" "pal2" "pal3" "pal4" "pal5"  
  71.               "pal6" "pal7" "pal8" "pal9" "pal10" 
  72.              )
  73.               (Dlg_TileSetFont n 2)
  74.           )
  75.           (Dlg_ListSetTabstops "ListBox1" "20 25 30")
  76.       )
  77.       (Dlg_ListSetTabstops "ListBox1" "15 18 20")
  78.     )
  79.     (PAL_TileSet pal1 "pal1")
  80.     (PAL_TileSet pal2 "pal2")
  81.     (PAL_TileSet pal3 "pal3")
  82.     (PAL_TileSet pal4 "pal4")
  83.     (PAL_TileSet pal5 "pal5")
  84.     (PAL_TileSet pal6 "pal6")
  85.     (PAL_TileSet pal7 "pal7")
  86.     (PAL_TileSet pal8 "pal8")
  87.     (PAL_TileSet pal9 "pal9")
  88.     (PAL_TileSet pal10 "pal10")
  89.     (Dlg_ListStart "paletten")
  90.     (if descrip_list (foreach el descrip_list (Dlg_ListAdd el)))
  91.     (Dlg_ListEnd) 
  92.     (Dlg_TileAction "setpal1" "(setq pal_new 1)(PAL_START)")
  93.     (Dlg_TileAction "setpal2" "(setq pal_new 2)(PAL_START)")
  94.     (Dlg_TileAction "setpal3" "(setq pal_new 3)(PAL_START)")
  95.     (Dlg_TileAction "setpal4" "(setq pal_new 4)(PAL_START)")
  96.     (Dlg_TileAction "setpal5" "(setq pal_new 5)(PAL_START)")
  97.     (Dlg_TileAction "setpal6" "(setq pal_new 6)(PAL_START)")
  98.     (Dlg_TileAction "setpal7" "(setq pal_new 7)(PAL_START)")
  99.     (Dlg_TileAction "setpal8" "(setq pal_new 8)(PAL_START)")
  100.     (Dlg_TileAction "setpal9" "(setq pal_new 9)(PAL_START)")
  101.     (Dlg_TileAction "setpal10" "(setq pal_new 10)(PAL_START)")
  102.     (Dlg_TileAction "paletten" "(set_pal)")
  103.     (Dlg_TileAction "IDCANCEL" "(setq pal_new nil)(Dlg_DialogDone)")
  104.   )
  105.   ;-------------------------------------------------------------------------
  106.   (defun SET_PAL ()
  107.     (Dlg_TileMode "setpal1" 0)
  108.     (Dlg_TileMode "setpal2" 0)
  109.     (Dlg_TileMode "setpal3" 0)
  110.     (Dlg_TileMode "setpal4" 0)
  111.     (Dlg_TileMode "setpal5" 0)
  112.     (Dlg_TileMode "setpal6" 0)
  113.     (Dlg_TileMode "setpal7" 0)
  114.     (Dlg_TileMode "setpal8" 0)
  115.     (Dlg_TileMode "setpal9" 0)
  116.     (Dlg_TileMode "setpal10" 0)
  117.     (setq set_new_mnp (strcase (nth (atoi $value) mnp_list) T))
  118.     (if (= $reason 4) (progn
  119.       (setq pal_new (GET_FREE_PAL))
  120.       (PAL_START)
  121.     ))
  122.   ) 
  123.   ;--------------------------------------------------------------------------
  124.   (defun GET_FNAME (pal subs / ret l i)
  125.     (if (and (= (type pal) 'STR) (> (strlen pal) 0))
  126.       (progn
  127.         (setq l (strlen pal) i l)
  128.         (while (AND (> i 0) (null ret)) 
  129.           (if (or (= (substr pal i 1) "\\")(= (substr pal i 1) "/"))
  130.               (setq ret (substr pal (+ i 1) l))
  131.           )
  132.           (setq i (- i 1))
  133.         )
  134.         (if (null ret) (setq ret pal))
  135.       )
  136.       ;;; ELSE 
  137.       (setq ret "")
  138.     )
  139.     (if (and subs
  140.              (> (strlen ret) 4)
  141.         )
  142.           (setq ret (substr ret 1 (- (strlen ret) 4)) ))
  143.           (if (= (substr ret (- (strlen ret) 4) 1) "_")
  144.               (setq ret (strcat 
  145.                  (substr ret 1 (- (strlen ret) 5))(substr ret (- (strlen ret) 3))
  146.              ))
  147.           )
  148.     (setq ret (strcase ret T)) 
  149.   )
  150.   ;--------------------------------------------------------------------------
  151.   (defun GET_FREE_PAL ( / f1 i1 s1)
  152.     (setq f1 T i1 0 s1 nil)
  153.     (while (and f1 (< i1 7))
  154.       (setq i1 (1+ i1))
  155.       (setq s1 (getvar (strcat "PALETTE" (itoa i1))))
  156.       (if (= s1 "")(setq f1 nil))
  157.     )
  158.     (if f1 
  159.       (setq i1 nil)
  160.       (setq i1 i1)
  161.     )
  162.   )
  163.   ;--------------------------------------------------------------------------
  164.   (defun PAL_GETVAR()
  165.     (setq pal1  (strcase (GET_FNAME (getvar "PALETTE1")) T))
  166.     (setq pal2  (strcase (GET_FNAME (getvar "PALETTE2")) T))
  167.     (setq pal3  (strcase (GET_FNAME (getvar "PALETTE3")) T))
  168.     (setq pal4  (strcase (GET_FNAME (getvar "PALETTE4")) T))
  169.     (setq pal5  (strcase (GET_FNAME (getvar "PALETTE5")) T))
  170.     (setq pal6  (strcase (GET_FNAME (getvar "PALETTE6")) T))
  171.     (setq pal7  (strcase (GET_FNAME (getvar "PALETTE7")) T))
  172.     (setq pal8  (strcase (GET_FNAME (getvar "PALETTE8")) T))
  173.     (setq pal9  (strcase (GET_FNAME (getvar "PALETTE9")) T))
  174.     (setq pal10 (strcase (GET_FNAME (getvar "PALETTE10")) T))
  175.   )
  176.   ;--------------------------------------------------------------------------  
  177.   (defun PAL_TileSet (pal_no pal_string / pal_no pat_string tmp1 nr)
  178.     (if (= pal_no "")
  179.        (Dlg_TileSet pal_string "---")
  180.        (progn
  181.          (if (setq tmpl (member pal_no mnp_list))
  182.            (progn 
  183.                 (setq nr (- (length mnp_list) (length tmpl)))
  184.                 (if (>= nr 0) (setq pal_no (nth nr descrip_list)))
  185.            )
  186.            (setq pal_no (strcat "<" pal_no ">"))
  187.         )
  188.         (Dlg_TileSet pal_string pal_no)     
  189.       ) 
  190.     )
  191.   )
  192.   ;--------------------------------------------------------------------------  
  193.   (defun *ERROR* (msg) 
  194.      (setq *ERROR* nil)
  195.      (setvar "CMDECHO" 1)
  196.      (setvar "FILEDIA" 1)
  197.      (princ)
  198.   )
  199.  
  200.   ; -------------------------------------------------------------------------  
  201.   ; MAIN
  202.   ; -------------------------------------------------------------------------  
  203.  
  204.   (setq pal_new nil set_new_mnp nil)
  205.   (PAL_GETVAR)
  206.   (setq mnu_name (GET_FNAME (getvar "PDMENUNAME") T ))
  207.   (setq p_id (findfile (strcat mnu_name ".pal")))
  208.   (if (not p_id) (setq p_id (findfile "toolbar.pal")))  
  209.   (if (not p_id) (setq p_id (findfile "palette.pal")))  
  210.   (if (not p_id) (setq p_id (findfile "toolbox.pal")))
  211.   (if (not p_id) (setq p_id (findfile "fcad.pal"   )))
  212.   (if (not p_id)
  213.     (alert 
  214.       ;;;@Parameter File @ not found!
  215.       (strcat (nth 1 prt_list) mnu_name ".pal" (nth 2 prt_list) )
  216.       (nth 3 prt_list)  ;;;@Alert
  217.       "EXLAMATION"
  218.     ) ; than
  219.     (progn 
  220.       (setq p_id (open p_id "r"))
  221.       (while (setq ln (read-line p_id))
  222.           (setq descrip_list  (append descrip_list (list ln))) 
  223.           (if (setq ln (read-line p_id))
  224.                (setq mnp_list (append mnp_list (list ln))) 
  225.           )
  226.       )
  227.       (close p_id)
  228.       (if (FLX_DLGDSP "flx_dlg" "PALETTE" "(FLX_DefaultAction)" "(PAL_INIT)") (princ)(exit))
  229.     ) ; else
  230.   ) 
  231.   (princ)
  232. )
  233.  
  234. (princ)
  235.