#| -*- Mode:LISP; Base: 10;
       Package:(VISTA-DEMO :use (VISTA VISTA-LIBRARY OBJ LISP));
       Syntax: Common-lisp; Readtable: CL   -*- |#

;;; Copyright (C) LISP Machine, Inc. 1984, 1985, 1986
;;;   See filename "Copyright" for
;;; licensing and release information.

(in-package 'vista-demo :use '(vista vista-library obj lisp))

;;; CHANGES:
;;;
;;; ??/??/85 PECANN Created, etc.
;;;
;;; 05/20/86 PECANN Adapted to new mousing, changed to commonlisp, package VISTA.
;;; 06/05/86 EFH    added viewport argument, run-color-editor, demo-color-editor
;;; 06/09/86 EFH    added save-color-map etc. (needs improvement)
;;; 06/10/86 PECANN fixed disk-valuator's left, right, bottom & top.  Fixed run-color-editor.
;;; 06/30/86 PECANN adapted to fractional viewports & fractional colors.
;;; 07/01/86 PW     fixed some bugs in run-color-editor and frob-all-dynamic-maps
;;; 07/01/86 PW     added mouse process sync stuff to fix toe stepping on
;;; 10/13/86 PECANN various

(export '(RUN-COLOR-EDITOR color-editor-manager *color-editor*))

(defdemo "Color Editor"
	 'demo-color-editor
  "The Color Editor"
  "vista:demo;color-editor")


;(defparameter *color-editor-current-color* 1008) Monster-compatibility colors

;(defparameter *color-editor-register-range-start* 1016)

;(defparameter *color-editor-static-hue-range-start* 1032)

;(defparameter *color-editor-luminance-range-start* 1064)
;(defparameter *color-editor-saturation-range-start* 1096)
;(defparameter *color-editor-hue-range-start* 1128)
;(defparameter *color-editor-red-range-start* 1160)
;(defparameter *color-editor-green-range-start* 1192)
;(defparameter *color-editor-blue-range-start* 1224)


(defparameter *color-editor-current-color* 8)

(defparameter *color-editor-register-range-start* 16)

(defparameter *color-editor-static-hue-range-start* 32)

(defparameter *color-editor-luminance-range-start* 64)
(defparameter *color-editor-saturation-range-start* 96)
(defparameter *color-editor-hue-range-start* 128)
(defparameter *color-editor-red-range-start* 160)
(defparameter *color-editor-green-range-start* 192)
(defparameter *color-editor-blue-range-start* 224)

;;; generalize this cruft
(defparameter *color-editor-map-save* nil); (make-array '(256 3))) ;shouldn't this be an art-8b?

(defun save-color-map (map-save))
;  (let (r g b)
;    (dotimes (i 256)
;      (multiple-value-setq (r g b) (get-map-color i))
;;      (print (list r g b))			   
;      (setf (aref map-save i 0) r)
;      (setf (aref map-save i 1) g)
;      (setf (aref map-save i 2) b))))
			   
(defun restore-color-map (map-save))
;  (dotimes (i 256)
;    (set-map-color i
;		   (aref map-save i 0)
;		   (aref map-save i 1)
;		   (aref map-save i 2))))

(defmacro with-color-map (map-save &body body)
  `(unwind-protect (progn (save-color-map ,map-save)
			  ,@body)
     (restore-color-map ,map-save)))




(defkind pointer 2d-visob)

(defobfun (pointer-shape pointer) ()
  (move 0.0 0.0)
  (line-relative 20. 13.)
  (line-relative 0 -8.)
  (line-relative 13. 0)
  (line-relative 0 -11.)
  (line-relative -13. 0)
  (line-relative 0 -8.)
  (line-relative -20. 13.)
  )

(defobfun (rotary-pointer-shape pointer) ()
  (move 0.0 0.0)
  (move-relative 108. 0.)
  (line-relative 20. 13.)
  (line-relative 0 -8.)
  (line-relative 13. 0)
  (line-relative 0 -11.)
  (line-relative -13. 0)
  (line-relative 0 -8.)
  (line-relative -20. 13.)
  )

(defkind color-bar 2d-visob)

(defobfun (color-bar-shape color-bar) ()
  (set-color 7)
  (rectangle -502.0 -52.0 502.0 52.0)
  (set-color color)
  (fill-rectangle -500.0 -50.0 500.0 50.0))

(defobfun (note-mouse-click color-bar) (&rest ignore)
  nil)

(defkind mouse-sensitive-rectangle 2d-visob)

(definstancevars mouse-sensitive-rectangle left right top bottom)

(defobfun (note-mouse-click mouse-sensitive-rectangle) ()
  (multiple-value-bind (b x y ignore ignore ignore ignore) (get-local-last-mouse-click)
    (when (and (>= x left)
	     (<= x right)
	     (>= y bottom)
	     (<= y top))
      (mouse-hit b x y)
      (current-obj))))

(defkind register mouse-sensitive-rectangle)

(definstancevars register (frac-red 0) (frac-green 0) (frac-blue 0))

(defobfun (exist register) (&rest args)
  (apply 'shadowed-exist args)
  (setq left -52
	right 52
	bottom -52
	top 52)
  )

(defobfun (register-shape register) ()
  (set-color 7)
  (rectangle -52.0 -52.0 52.0 52.0)
  (set-color color)
  (fill-rectangle -50.0 -50.0 50.0 50.0))

(defobfun (mouse-hit register) (b x y)
  (drawing
    (case b
      (1 (setq frac-red (ask component-of (ask red-valuator setting))
	       frac-green (ask component-of (ask green-valuator setting))
	       frac-blue (ask component-of (ask blue-valuator setting)))
	 (update-map))
      (2 (ask-funcall (ask component-of red-valuator)
		      'set-to
		      frac-red)
	 (ask-funcall (ask component-of green-valuator)
		      'set-to
		      frac-green)
	 (ask-funcall (ask component-of blue-valuator)
		      'set-to
		      frac-blue)
	 (ask component-of
	   (constrain-lsh)
	   (frob-all-dynamic-maps)
	   (ask component-of (draw-self)))))))

(defobfun (update-map register) ()
  (set-map-color color frac-red frac-green frac-blue))

(defkind static-label 2d-visob)

(defobfun solid-static-label-shape ()
  "Drawn from center."
  (set-color 7)
  (circle 0.0 0.0 45.0)
  (set-color color)
  (fill-circle 0.0 0.0 40.0))

(defobfun rainbow-static-label-shape ()
  "Drawn from center."
  (set-color 7)
  (circle 0.0 0.0 45.0)
  (do ((n 0 (1+ n))
       (index color (1+ index))
       (angle 90. (+ angle 11.25)))
      ((> n 31))
    (set-color index)
    (fill-arc 0.0 0.0 40.0 (round (mod (- angle 5.625) 360.)) (round (mod (+ angle 5.625) 360.)))))

(defobfun white-striped-rainbow-static-label-shape ()
  "Drawn from center."
  (set-color 7)
  (circle 0.0 0.0 45.0)
  (fill-circle 0.0 0.0 40.0)
  (do ((n 0 (1+ n))
       (index color (1+ index))
       (angle 90. (+ angle 11.25)))
      ((> n 31))
    (set-color index)
    (fill-arc 0.0 0.0 40.0 (round (mod (- angle 2.8125) 360.)) (round (mod (+ angle 2.8125) 360.)))))

(defkind valuator mouse-sensitive-rectangle)

(definstancevars valuator
  (setting 0))

(defkind box-valuator valuator)

(definstancevars box-valuator
  upper-label-shape
  upper-label-arg
  lower-label-shape
  lower-label-arg)

(defobfun (exist box-valuator) (&rest args)
  (apply 'shadowed-exist args)
  (have 'shape 'box-valuator-shape)
  (add-component (oneof static-label
			'shape upper-label-shape
			'color upper-label-arg
			'x 0.0
			'y 200.0
			'colorablep nil))
  (add-component (oneof static-label
			'shape lower-label-shape
			'color lower-label-arg
			'x 0.0
			'y -200.0
			'colorablep nil))
  (have 'my-pointer (oneof pointer
			'shape 'pointer-shape
			'color 7
			'x 30.0
			'y -128.0))
  (add-component my-pointer)
  (setq left -50
	right 70
	bottom -250
	top 250)
  )

(defobfun box-valuator-shape ()
  "Box slider control.  Drawn from center."
  (set-color 7)
  (rectangle -28.0 -130.0 28.0 130.0)
  (do ((n 0 (1+ n))
       (index color (1+ index))
       (bar-y -128.0 (+ bar-y 8)))
      ((> n 31))
    (set-color index)
    (fill-rectangle -25.0 bar-y 25.0 (+ bar-y 8))))

(defobfun (set-to box-valuator) (new-setting)
  (setq setting new-setting)
  (ask-funcall my-pointer 'set-xy (ask my-pointer x) (- (* setting 256) 128)))

(defkind ls-box-valuator box-valuator)

(defkind rgb-box-valuator box-valuator)

(defobfun (mouse-hit ls-box-valuator) (ignore ignore my)
  (set-to (min 1 (max 0 (/ (+ my
			      128.)
			   256.))))
  (ask component-of
    (constrain-rgb)
    (drawing
      (set-map-color *color-editor-current-color*
		     (ask red-valuator setting)
		     (ask green-valuator setting)
		     (ask blue-valuator setting))))	    
  (do () (nil)
    (multiple-value-bind (b ignore my ignore ignore ignore ignore) (get-local-mouse-state)
      (if (zerop b) (return))
      (set-to (min 1 (max 0 (/ (+ my
				  128.)
			       256.)))))
    (ask component-of
      (finish)
      (constrain-rgb)
      (drawing
	(set-map-color *color-editor-current-color*
		       (ask red-valuator setting)
		       (ask green-valuator setting)
		       (ask blue-valuator setting)))))	    
  (drawing
    (ask component-of
      (frob-all-dynamic-maps)
      (ask component-of (draw-self)))))

(defobfun (mouse-hit rgb-box-valuator) (ignore ignore my)
  (set-to (min 1 (max 0 (/ (+ my
			      128.)
			   256.))))
  (drawing (ask component-of (set-map-color *color-editor-current-color*
					    (ask red-valuator setting)
					    (ask green-valuator setting)
					    (ask blue-valuator setting))))   
  (do () (nil)
    (multiple-value-bind (b mx my ignore ignore ignore ignore) (get-local-mouse-state)
      (if (zerop b) (return))
      (set-to (min 1 (max 0 (/ (+ my
				  128.)
			       256.)))))
    (drawing (ask component-of (set-map-color *color-editor-current-color*
					      (ask red-valuator setting)
					      (ask green-valuator setting)
					      (ask blue-valuator setting)))) )   
  (drawing
    (ask component-of
      (constrain-lsh)
      (frob-all-dynamic-maps)
      (finish)
      (ask component-of (draw-self)))))

(defkind disk-valuator valuator)

(definstancevars disk-valuator label-shape label-arg)

(defobfun (exist disk-valuator) (&rest args)
  (apply 'shadowed-exist args)
  (have 'shape 'disk-valuator-shape)
  (add-component (oneof static-label
			'shape label-shape
			'color label-arg
			'x 0.0
			'y 0.0))
  (have 'my-pointer (oneof pointer
			'shape 'rotary-pointer-shape
			'color 7
			'x 0.0
			'y 0.0
			'rotation 90))
  (add-component my-pointer)
  (setq left -150.
	right 150.
	bottom -150.
	top 150.)
  )

(defobfun disk-valuator-shape ()
  "Drawn from center."
  (set-color 7)
  (circle 0.0 0.0 105.0)
  (do ((n 0 (1+ n))
       (index color (1+ index))
       (angle 90. (+ angle 11.25)))
      ((> n 31))
    (set-color index)
    (fill-arc 0.0 0.0 100.0 (round (mod (- angle 5.625) 360.)) (round (mod (+ angle 5.625) 360.))))
  (set-color 0)
  (fill-circle 0.0 0.0 50.0))

(defobfun (set-to disk-valuator) (new-setting)
  (setq setting new-setting)
  (ask-funcall my-pointer 'set-rotation (mod (+ 90
					     (* setting 360))
					  360)))

(defobfun (mouse-hit disk-valuator) (ignore mx my)
  (if (not (and (zerop my)
		(zerop mx)))
      (set-to (mod (- (/ (atan my mx)
			 (* 2 pi))
		      .25)
		   1)))
  (ask component-of
    (constrain-rgb)
    (drawing (set-map-color *color-editor-current-color*
			    (ask red-valuator setting)
			    (ask green-valuator setting)
			    (ask blue-valuator setting))))
  (do () (nil)
    (multiple-value-bind (b mx my ignore ignore ignore ignore) (get-local-mouse-state)
      (if (zerop b) (return))
      (if (not (and (zerop my)
		    (zerop mx)))
	  (set-to (mod (- (/ (atan my mx)
			     (* 2 pi))
			  .25)
		       1))))
    (ask component-of
      (constrain-rgb)
      (finish)
      (drawing (set-map-color *color-editor-current-color*
			      (ask red-valuator setting)
			      (ask green-valuator setting)
			      (ask blue-valuator setting)))))
  (drawing (ask component-of
	     (frob-all-dynamic-maps)
	     (ask component-of (draw-self)))))

(defkind color-editor-vista 2d-vista)

(defobfun (exist color-editor-vista) (&rest args)
  (apply 'shadowed-exist args)
  (have 'luminance-valuator (oneof ls-box-valuator
				   'obj-name 'luminance-valuator
				   'x 100.0
				   'y 380.0
				   'color *color-editor-luminance-range-start*
				   'upper-label-shape 'white-striped-rainbow-static-label-shape
				   'upper-label-arg *color-editor-static-hue-range-start*
				   'lower-label-shape 'solid-static-label-shape
				   'lower-label-arg 0
				   'colorablep nil))
  (add-component luminance-valuator)
  (have 'saturation-valuator (oneof ls-box-valuator
				    'obj-name 'saturation-valuator
				    'x 225.0
				    'y 380.0
				    'color *color-editor-saturation-range-start*
				    'upper-label-shape 'rainbow-static-label-shape
				    'upper-label-arg *color-editor-static-hue-range-start*
				    'lower-label-shape 'solid-static-label-shape
				    'lower-label-arg 7
				    'colorablep nil))
  (add-component saturation-valuator)
  (have 'hue-valuator (oneof disk-valuator
			     'obj-name 'hue-valuator
			     'x 450.0
			     'y 380.0
			     'color *color-editor-hue-range-start*
			     'label-shape 'rainbow-static-label-shape
			     'label-arg *color-editor-static-hue-range-start*
			     'colorablep nil))
  (add-component hue-valuator)
  (have 'red-valuator (oneof rgb-box-valuator
			     'obj-name 'red-valuator
			     'x 650.0
			     'y 380.0
			     'color *color-editor-red-range-start*
			     'upper-label-shape 'solid-static-label-shape
			     'upper-label-arg 1
			     'lower-label-shape 'solid-static-label-shape
			     'lower-label-arg 0
			     'colorablep nil))
  (add-component red-valuator)
  (have 'green-valuator (oneof rgb-box-valuator
			       'obj-name 'green-valuator
			       'x 775.0
			       'y 380.0
			       'color *color-editor-green-range-start*
			       'upper-label-shape 'solid-static-label-shape
			       'upper-label-arg 2
			       'lower-label-shape 'solid-static-label-shape
			       'lower-label-arg 0
			       'colorablep nil))
  (add-component green-valuator)
  (have 'blue-valuator (oneof rgb-box-valuator
			      'obj-name 'blue-valuator
			      'x 900.0
			      'y 380.0
			      'color *color-editor-blue-range-start*
			      'upper-label-shape 'solid-static-label-shape
			      'upper-label-arg 4
			      'lower-label-shape 'solid-static-label-shape
			      'lower-label-arg 0
			      'colorablep nil))
  (add-component blue-valuator)
  (add-component (oneof color-bar
			'obj-name 'color-bar
			'x 512.0
			'y 700.0
			'shape 'color-bar-shape
			'color *color-editor-current-color*
			'colorablep nil))
  (have 'registers)
  (do ((i 7 (1- i))
       (x 940.5 (- x 125.0)))
      ((< i 0))
    (push (oneof register
		 'obj-name (format nil "REGISTER-~D" i)
		 'x x
		 'y 65.0
		 'shape 'register-shape
		 'color (+ *color-editor-register-range-start* i)
		 'colorablep nil)
	  registers)
    (add-component (car registers))))

(defkind color-editor-manager vista-manager)

(defobfun (exist color-editor-manager) (&rest args)
  (apply 'shadowed-exist 'clearp nil args)
  (add-component (oneof color-editor-vista)))

(defparameter *color-editor-viewport* (make-viewport 0 1 0 1))

(defobfun (run color-editor-manager) (&optional (viewport *color-editor-viewport*))
  (ask (car components) (set-vista-viewport viewport))
  (drawing (prep-device))
  (with-color-map *color-editor-map-save*
    (drawing
      (ask (car components)
	(set-ortho -.5 1023.5 -.5 767.5)
	(unless compilation (drawing (compile-self-flexible)))
	(mapc-ask registers (update-map))
	(frob-map-static-hue)
	(frob-all-dynamic-maps))
      (draw-self))
    (catch 'done
      (with-vista-mouse
	(do () (nil)
	  (if (= (get-mouse-click t) 4) (progn (do () ((zerop (get-mouse-state)))) (throw 'done nil)))
	  (dolist (component (ask (car components) components))
	    (when (ask component (note-mouse-click))
	      (return))))))
    (values (ask (car components) (list (ask red-valuator setting)
					(ask green-valuator setting)
					(ask blue-valuator setting)))
	    (ask (car components) (let ((result))
				    (dolist (register registers)
				      (push (ask register (list frac-red
								frac-green
								frac-blue))
					    result))
				    (nreverse result))))))

(defobfun (set-edit-color color-editor-manager) (fractional-red fractional-green fractional-blue)
  (ask (car components)
    (ask red-valuator (set-to fractional-red))
    (ask green-valuator (set-to fractional-green))
    (ask blue-valuator (set-to fractional-blue))
    (constrain-lsh)))

(defobfun (set-register-color color-editor-manager) (reg-num fractional-red fractional-green fractional-blue)
  (let ((reg (nth reg-num (ask (car components) registers))))
    (ask-funcall reg 'set 'frac-red fractional-red)
    (ask-funcall reg 'set 'frac-green fractional-green)
    (ask-funcall reg 'set 'frac-blue fractional-blue)))

(defobfun (frob-map-static-hue color-editor-vista) () ;full saturation spectrum for labels.
  (do ((i 0 (1+ i))
       (hue 0 (+ hue (/ 1.0 32.))))
      ((> i 31.))
    (set-map-color (+ *color-editor-static-hue-range-start* i)
		   (r-from-lsh 1 1 hue)
		   (g-from-lsh 1 1 hue)
		   (b-from-lsh 1 1 hue))))

(defobfun (frob-map-luminance color-editor-vista) (sat hue)
  (do ((i 0 (1+ i)))
      ((> i 31.))
    (set-map-color (+ *color-editor-luminance-range-start* i)
		   (r-from-lsh (/ (+ 1 i) 32.0) sat hue)
		   (g-from-lsh (/ (+ 1 i) 32.0) sat hue)
		   (b-from-lsh (/ (+ 1 i) 32.0) sat hue))))

(defobfun (frob-map-saturation color-editor-vista) (lum hue)
  (do ((i 0 (1+ i)))
      ((> i 31.))
    (set-map-color (+ *color-editor-saturation-range-start* i)
		   (r-from-lsh lum (/ (+ 1 i) 32.0) hue)
		   (g-from-lsh lum (/ (+ 1 i) 32.0) hue)
		   (b-from-lsh lum (/ (+ 1 i) 32.0) hue))))

(defobfun (frob-map-hue color-editor-vista) (lum sat)
  (do ((i 0 (1+ i))
       (hue 0 (+ hue (/ 1.0 32.))))
      ((> i 31.))
    (set-map-color (+ *color-editor-hue-range-start* i)
		   (r-from-lsh lum sat hue)
		   (g-from-lsh lum sat hue)
		   (b-from-lsh lum sat hue))))

(defobfun (frob-map-red color-editor-vista) (green-setting blue-setting)
  (do ((i 0 (1+ i)))
      ((> i 31.))
    (set-map-color (+ *color-editor-red-range-start* i)
		   (/ (+ 1 i) 32.0)
		   green-setting
		   blue-setting)))

(defobfun (frob-map-green color-editor-vista) (red-setting blue-setting)
  (do ((i 0 (1+ i)))
      ((> i 31.))
    (set-map-color (+ *color-editor-green-range-start* i)
		   red-setting
		   (/ (+ 1 i) 32.0)
		   blue-setting)))

(defobfun (frob-map-blue color-editor-vista) (red-setting green-setting)
  (do ((i 0 (1+ i)))
      ((> i 31.))
    (set-map-color (+ *color-editor-blue-range-start* i)
		   red-setting
		   green-setting
		   (/ (+ 1 i) 32.0))))

(defobfun (r-from-lsh color-editor-vista) (lum sat hue &aux int frac)
  "Red 0-1.  Args:  luminance, saturation, hue 0-1."
  (multiple-value-setq (int frac) (truncate hue (/ 1.0 6.0))) ;I hope the compiler's smart about constant expressions.
  (* lum (- 1 (* sat (case int
		       (2 (* 6 frac))
		       ((3 4) 1)
		       (5 (- 1 (* 6 frac)))
		       ((0 6 1) 0))))))

(defobfun (g-from-lsh color-editor-vista) (lum sat hue &aux int frac)
  "Green 0-1.  Args:  luminance, saturation, hue 0-1."
  (multiple-value-setq (int frac) (truncate hue (/ 1.0 6.0)))
  (* lum (- 1 (* sat (case int
		       ((0 6) (* 6 frac))
		       ((1 2) 1)
		       (3 (- 1 (* 6 frac)))
		       ((4 5) 0))))))

(defobfun (b-from-lsh color-editor-vista) (lum sat hue &aux int frac)
  "Blue 0-1.  Args:  luminance, saturation, hue 0-1."
  (multiple-value-setq (int frac) (truncate hue (/ 1.0 6.0)))
  (* lum (- 1 (* sat (case int
		       (4 (* 6 frac))
		       ((5 0 6) 1)
		       (1 (- 1 (* 6 frac)))
		       ((2 3) 0))))))

(defobfun (lsh-from-rgb color-editor-vista) (r g b)	;s and h may be nil if undefined.  l is always defined.
  (if (<= r g)
      (if (<= g b)
	  ;r<=g<=b
	  (values b ;lum
		  (if (zerop b)
		      nil
		    (- 1 (/ r b 1.0))) ;sat
		  (if (= b r)
		      nil
		    (+ .5 (/ (- g r) (- b r) 6.0)))) ;hue
	;b<g
	(if (<= r b)
	    ;r<=b<g
	    (values g ;lum
		    (- 1 (/ r g 1.0)) ;sat
		    (- (/ 5.0 6.0) (/ (- b r) (- g r) 6.0))) ;hue
	  ;b<r<=g
	  (values g ;lum
		  (- 1 (/ b g 1.0)) ;sat
		  (- 1 (/ (- g r) (- g b) 6.0))))) ;hue
    ;g<r
    (if (<= r b)
	;g<r<=b
	(values b ;lum
		(- 1 (/ g b 1.0)) ;sat
		(- .5 (/ (- r g) (- b g) 6.0))) ;hue
      ;b<r
      (if (<= g b)
	  ;g<=b<r
	  (values r ;lum
		  (- 1 (/ g r 1.0)) ;sat
		  (+ (/ 1.0 6.0) (/ (- b g) (- r g) 6.0))) ;hue
	;b<g<r
	(values r ;lum
		(- 1 (/ b r 1.0)) ;sat
		(- (/ 1.0 6.0) (/ (- g b) (- r b) 6.0))))))) ;hue

(defobfun (constrain-rgb color-editor-vista) (&aux l s h)
  (setq l (ask luminance-valuator setting)
	s (ask saturation-valuator setting)
	h (ask hue-valuator setting))
  (ask-funcall red-valuator 'set-to (r-from-lsh l s h))
  (ask-funcall green-valuator 'set-to (g-from-lsh l s h))
  (ask-funcall blue-valuator 'set-to (b-from-lsh l s h)))

(defobfun (constrain-lsh color-editor-vista) (&aux l s h)
  (multiple-value-setq (l s h) (lsh-from-rgb (ask red-valuator setting)
					(ask green-valuator setting)
					(ask blue-valuator setting)))
  (ask-funcall luminance-valuator 'set-to l)
  (if s (ask-funcall saturation-valuator 'set-to s))
  (if h (ask-funcall hue-valuator 'set-to h)))

(defobfun (frob-all-dynamic-maps color-editor-vista) ()
  (set-map-color *color-editor-current-color*
	    (ask red-valuator setting)
	    (ask green-valuator setting)
	    (ask blue-valuator setting))
  (frob-map-luminance (ask saturation-valuator setting) (ask hue-valuator setting))
  (frob-map-saturation (ask luminance-valuator setting) (ask hue-valuator setting))
  (frob-map-hue (ask luminance-valuator setting) (ask saturation-valuator setting))
  (frob-map-red (ask green-valuator setting) (ask blue-valuator setting))
  (frob-map-green (ask red-valuator setting) (ask blue-valuator setting))
  (frob-map-blue (ask red-valuator setting) (ask green-valuator setting)))
  

(defparameter *color-editor* (oneof color-editor-manager))


(defun demo-color-editor ()
  (format t "~&Color Editor Demo.  Mouse right to exit.")
  (initialize-device)
  (format t "~&Current setting:  ~a~%" (ask *color-editor*
					 (drawing (compile-self-flexible))
					 (run))))