home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0000 - 0009 / ibm0000-0009 / ibm0003.tar / ibm0003 / ACAD10-2.ZIP / ICD.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1987-06-05  |  12.6 KB  |  372 lines
  1.  
  2. ;       Interactive Colour Designer
  3.  
  4. ;       Designed and implemented by Kelvin R. Throop in June of 1987
  5.  
  6. ;       This code allows the user to interactively select a colour from
  7. ;       the colour gamut of an AutoCAD 256 colour device by manipulating
  8. ;       sliders which control hue, brightness, and saturation.  Another
  9. ;       slider allows selection from the six special grey scale colours.
  10.  
  11. ;       The capability is provided in both functional and a command
  12. ;       forms.  To set the current entity drawing colour, you may
  13. ;       simply use the command:
  14.  
  15. ;       icolour
  16. ;   or  icolor
  17.  
  18. ;       If you want a colour number to use in another context (such as to
  19. ;       reply to a LAYER COLOUR prompt, or for the CHANGE command, or for
  20. ;       use in your own Lisp code) you may use:
  21.  
  22. ;       (icolour)
  23. ;   or  (icolor)
  24.  
  25. ;       which return the selected colour number in the range from 10
  26. ;       to 255.
  27.  
  28. ;       ICOLOUR  --  Obtain colour number interactively and return index.
  29.  
  30. (defun icolour ( / vctr smin smax pixy)
  31.  
  32. ;       Obtain world to screen scale factors and build our local
  33. ;       coordinate system in which the screen runs from (0 0) to (1 1).
  34.  
  35.         (setq vctr (getvar "viewctr")
  36.               yspan (getvar "viewsize")
  37.               smin (getvar "vsmin")
  38.               smax (getvar "vsmax")
  39.               ymin (- (cadr vctr) (/ yspan 2.0))
  40.               xspan (* yspan (/ (- (car smax) (car smin))
  41.                                 (- (cadr smax) (cadr smin))))
  42.               xmin (- (car vctr) (/ xspan 2.0))
  43.         )
  44.  
  45. ;       Make sure we're on the graphics screen and clear it
  46.  
  47.         (graphscr)
  48.         (grclear)
  49.         (setq scoords (getvar "coords"))
  50.         (setvar "coords" 0)        ; Coordinate line?  Just say no.
  51.  
  52.         (setq pixy (/ 1.0 (cadr (getvar "screensize"))))
  53.  
  54. ;       Precompute lines and bounding region for hue
  55.  
  56.         (setq huelf (plcs (list 0.1 0.85)))
  57.         (setq huelt (plcs (list 0.9 0.85)))
  58.         (setq huehf (plcs (list 0.1 (+ 0.85 pixy))))
  59.         (setq hueht (plcs (list 0.9 (+ 0.85 pixy))))
  60.  
  61.         (setq huexl (+ xmin (* 0.1 xspan)))
  62.         (setq huexh (+ xmin (* 0.9 xspan)))
  63.         (setq hueyl (+ ymin (* 0.8 yspan)))
  64.         (setq hueyh (+ ymin (* 0.9 yspan)))
  65.  
  66. ;       Precompute lines and bounding region for brightness
  67.  
  68.         (setq brtlf (plcs (list 0.3 0.65)))
  69.         (setq brtlt (plcs (list 0.7 0.65)))
  70.         (setq brthf (plcs (list 0.3 (+ 0.65 pixy))))
  71.         (setq brtht (plcs (list 0.7 (+ 0.65 pixy))))
  72.  
  73.         (setq brtxl (+ xmin (* 0.3 xspan)))
  74.         (setq brtxh (+ xmin (* 0.7 xspan)))
  75.         (setq brtyl (+ ymin (* 0.6 yspan)))
  76.         (setq brtyh (+ ymin (* 0.7 yspan)))
  77.  
  78. ;       Precompute lines and bounding region for saturation
  79.  
  80.         (setq satlf (plcs (list 0.4 0.45)))
  81.         (setq satlt (plcs (list 0.6 0.45)))
  82.         (setq sathf (plcs (list 0.4 (+ 0.45 pixy))))
  83.         (setq satht (plcs (list 0.6 (+ 0.45 pixy))))
  84.  
  85.         (setq satxl (+ xmin (* 0.4 xspan)))
  86.         (setq satxh (+ xmin (* 0.6 xspan)))
  87.         (setq satyl (+ ymin (* 0.4 yspan)))
  88.         (setq satyh (+ ymin (* 0.5 yspan)))
  89.  
  90. ;       Precompute lines and bounding region for grey values
  91.  
  92.         (setq grylf (plcs (list 0.2 0.25)))
  93.         (setq grylt (plcs (list 0.8 0.25)))
  94.         (setq gryhf (plcs (list 0.2 (+ 0.25 pixy))))
  95.         (setq gryht (plcs (list 0.8 (+ 0.25 pixy))))
  96.  
  97.         (setq gryxl (+ xmin (* 0.2 xspan)))
  98.         (setq gryxh (+ xmin (* 0.8 xspan)))
  99.         (setq gryyl (+ ymin (* 0.2 yspan)))
  100.         (setq gryyh (+ ymin (* 0.3 yspan)))
  101.  
  102. ;       Draw the hue control slider
  103.  
  104.         (grdraw (list huexl hueyl) (list huexl hueyh) 10)
  105.         (grdraw (list huexh hueyl) (list huexh hueyh) 210)
  106.         (grdraw huelf huelt 90)
  107.  
  108. ;       Draw the lightness control slider
  109.  
  110.         (grdraw (list brtxl brtyl) (list brtxl brtyh) 94)
  111.         (grdraw (list brtxh brtyl) (list brtxh brtyh) 90)
  112.         (grdraw brtlf brtlt 94)
  113.  
  114. ;       Draw the saturation control slider
  115.  
  116.         (grdraw (list satxl satyl) (list satxl satyh) 10)
  117.         (grdraw (list satxh satyl) (list satxh satyh) 11)
  118.         (grdraw satlf satlt 10)
  119.  
  120. ;       Draw the grey scale slider
  121.  
  122.         (grdraw (list gryxl gryyl) (list gryxl gryyh) 251)
  123.         (grdraw (list gryxh gryyl) (list gryxh gryyh) 255)
  124.         (grdraw grylf grylt 253)
  125.  
  126. ;       Set defaults.  We start with a middle of the road green.  You
  127. ;       want to change this to default to the last colour, but rember
  128. ;       that if the pointer happens to be inside one the sliders, it
  129. ;       will be immediately changed.
  130.  
  131.         (setq hue 90
  132.               brite 0
  133.               sat 0
  134.         )
  135.         (ucol)
  136.  
  137. ;       Loop examining pointer coordinates.  If the user enters an
  138. ;       active slider area, dispatch to the handler for that slider.
  139.  
  140.         (setq ocont T)
  141.         (setq lp nil)
  142.         (while ocont
  143.            (setq p (grread T))
  144.            (if (not (equal lp p))
  145.               (progn
  146.                  (setq lp p)
  147.                  (if (= (car p) 5)
  148.                     (progn
  149.                        (setq px (caadr p))
  150.                        (setq py (cadadr p))
  151.                        (if (and (>= py hueyl) (<= py hueyh)
  152.                                 (>= px huexl) (<= px huexh))
  153.                           (sethue)
  154.                           (if (and (>= py brtyl) (<= py brtyh)
  155.                                    (>= px brtxl) (<= px brtxh))
  156.                              (setbrt)
  157.                              (if (and (>= py satyl) (<= py satyh)
  158.                                       (>= px satxl) (<= px satxh))
  159.                                 (setsat)
  160.                                 (if (and (>= py gryyl) (<= py gryyh)
  161.                                          (>= px gryxl) (<= px gryxh))
  162.                                    (setgry)
  163.                                 )
  164.                              )
  165.                           )
  166.                        )
  167.                     )
  168.                     (if (= (car p) 3)
  169.                        (setq ocont nil)
  170.                     )
  171.                  )
  172.               )
  173.            )
  174.         )
  175.  
  176. ;       Put back the original screen and return the selected colour
  177.  
  178.         (setvar "coords" scoords)
  179.         (grtext)
  180.         (redraw)
  181.         col
  182. )
  183.  
  184. ;       SETHUE  --  Set hue.  This is invoked when the user enters the hue
  185. ;                   control slider and returns when he leaves it or clicks.
  186.  
  187. (defun sethue ( / cont lp p px py pcol)
  188.         (setq cont T)
  189.         (setq lp nil)
  190.         (while cont
  191.            (setq p (grread T))
  192.            (if (not (equal lp p))
  193.               (progn
  194.                  (setq lp p)
  195.                  (if (= (car p) 5)
  196.                     (progn
  197.                        (setq px (caadr p))
  198.                        (setq py (cadadr p))
  199.                        (if (and (>= py hueyl) (<= py hueyh)
  200.                                 (>= px huexl) (<= px huexh))
  201.                           (progn
  202.                              (setq pcol (fix (* 24 (/ (- 
  203.                                 (/ (- px xmin) xspan) 0.1) 0.8))))
  204.                              (setq hue (+ (* 10 pcol) 10))
  205.                              (ucol)
  206.                              (grdraw huelf huelt col)
  207.                              (grdraw huehf hueht col)
  208.                              (grtext -1 (strcat "Hue: " (itoa hue)))
  209.                           )
  210.                           (setq cont nil)
  211.                        )
  212.                     )
  213.                     (if (= (car p) 3)
  214.                        (setq cont nil ocont nil)
  215.                     )
  216.                  )
  217.               )
  218.            )
  219.         )
  220.         (grdraw huehf hueht 0)
  221.         (grtext -1 "")
  222. )
  223.  
  224. ;       SETBRT  --  Set brightness.  This is activated when the user enters
  225. ;                   the brightness control slider and returns when
  226. ;                   he leaves it or clicks.
  227.  
  228. (defun setbrt ( / cont lp p px py)
  229.         (setq cont T)
  230.         (setq lp nil)
  231.         (while cont
  232.            (setq p (grread T))
  233.            (if (not (equal lp p))
  234.               (progn
  235.                  (setq lp p)
  236.                  (if (= (car p) 5)
  237.                     (progn
  238.                        (setq px (caadr p))
  239.                        (setq py (cadadr p))
  240.                        (if (and (>= py brtyl) (<= py brtyh)
  241.                                 (>= px brtxl) (<= px brtxh))
  242.                           (progn
  243.                              (setq brite (- 8 (* 2 (fix (* 5
  244.                                 (/ (- (/ (- px xmin) xspan) 0.3) 0.4))))))
  245.                              (ucol)
  246.                              (grdraw brtlf brtlt col)
  247.                              (grdraw brthf brtht col)
  248.                              (grtext -1 (strcat "Brightness: " (itoa brite)))
  249.                           )
  250.                           (setq cont nil)
  251.                        )
  252.                     )
  253.                     (if (= (car p) 3)
  254.                        (setq cont nil ocont nil)
  255.                     )
  256.                  )
  257.               )
  258.            )
  259.         )
  260.         (grdraw brthf brtht 0)
  261.         (grtext -1 "")
  262. )
  263.  
  264. ;       SETSAT  --  Set saturation.  This is activated when the user enters
  265. ;                   the saturation control slider and returns when
  266. ;                   he leaves it or clicks.
  267.  
  268. (defun setsat ( / cont lp p px py)
  269.         (setq cont T)
  270.         (setq lp nil)
  271.         (while cont
  272.            (setq p (grread T))
  273.            (if (not (equal lp p))
  274.               (progn
  275.                  (setq lp p)
  276.                  (if (= (car p) 5)
  277.                     (progn
  278.                        (setq px (caadr p))
  279.                        (setq py (cadadr p))
  280.                        (if (and (>= py satyl) (<= py satyh)
  281.                                 (>= px satxl) (<= px satxh))
  282.                           (progn
  283.                              (setq sat (if (> px (+ xmin (/ xspan 2))) 1 0))
  284.                              (ucol)
  285.                              (grdraw satlf satlt col)
  286.                              (grdraw sathf satht col)
  287.                              (grtext -1 (strcat "Saturation: " (itoa sat)))
  288.                           )
  289.                           (setq cont nil)
  290.                        )
  291.                     )
  292.                     (if (= (car p) 3)
  293.                        (setq cont nil ocont nil)
  294.                     )
  295.                  )
  296.               )
  297.            )
  298.         )
  299.         (grdraw sathf satht 0)
  300.         (grtext -1 "")
  301. )
  302.  
  303. ;       SETGRY  --  Set grey scale.  This is activated when the user enters
  304. ;                   the grey scale control slider and returns when
  305. ;                   he leaves it or clicks.
  306.  
  307. (defun setgry ( / cont lp p px py)
  308.         (setq cont T)
  309.         (setq lp nil)
  310.         (while cont
  311.            (setq p (grread T))
  312.            (if (not (equal lp p))
  313.               (progn
  314.                  (setq lp p)
  315.                  (if (= (car p) 5)
  316.                     (progn
  317.                        (setq px (caadr p))
  318.                        (setq py (cadadr p))
  319.                        (if (and (>= py gryyl) (<= py gryyh)
  320.                                 (>= px gryxl) (<= px gryxh))
  321.                           (progn
  322.                              (setq col (+ 250 (fix (* 6
  323.                                 (/ (- (/ (- px xmin) xspan) 0.2) 0.6)))))
  324.                              (grdraw grylf grylt col)
  325.                              (grdraw gryhf gryht col)
  326.                              (grtext -1 (strcat "Grey scale: "
  327.                                 (itoa (- col 250))))
  328.                               (grtext -2 (strcat "Colour: " (itoa col)))
  329.                           )
  330.                           (setq cont nil)
  331.                        )
  332.                     )
  333.                     (if (= (car p) 3)
  334.                        (setq cont nil ocont nil)
  335.                     )
  336.                  )
  337.               )
  338.            )
  339.         )
  340.         (grdraw gryhf gryht 0)
  341.         (grtext -1 "")
  342. )
  343.  
  344. ;       PLCS  --  Tranform point from local coordinate system to world
  345. ;                 coordinates.
  346.  
  347. (defun plcs (p)
  348.            (list (+ xmin (* (car p) xspan))
  349.                  (+ ymin (* (cadr p) yspan)))
  350. )
  351.  
  352. ;       UCOL  --  Update colour from hue, lightness, and saturation
  353.  
  354. (defun ucol ()
  355.         (setq col (+ hue brite sat))
  356.         (grtext -2 (strcat "Colour: " (itoa col)))
  357. )
  358.  
  359. ;       C:ICOLOUR --  Command to set current colour
  360. ;       C:ICOLOR  --  Synonym
  361. ;       ICOLOR    --  Synonym of functional form
  362.  
  363. (defun C:ICOLOUR ()
  364.         (command "colour" (icolour))
  365. )
  366. (defun C:ICOLOR ()
  367.         (command "colour" (icolour))
  368. )
  369. (defun icolor ()
  370.         (icolour)
  371. )
  372.