;;;-*- Mode:LISP; Package: Palette; Base: 8-*-

;;; This program defines the PALETTE flavor.  The general idea for
;;; this program is in AI: DLW; PALETT >.
;;; Windows herein only work on color screens.  Doesn't it suck.

;;; How to use:
;;;  (palette) creates a palette of six color that you can edit.
;;;  (edit-colors) just creates a color editor with no palette.

(DEFMACRO WITH-MOUSE-SHEET ((SHEET) &BODY BODY)
  (LET ((OLD-SHEET (GENSYM)))
    `(LET ((,OLD-SHEET TV:MOUSE-SHEET))
       (UNWIND-PROTECT
	 (PROGN
	   (TV:MOUSE-SET-SHEET ,SHEET)
	   . ,BODY)
	 (TV:MOUSE-SET-SHEET ,OLD-SHEET)))))

(DEFMACRO WITH-MOUSE-CAPTURED ((SHEET) &BODY BODY)
  (LET ((OLD-SHEET (GENSYM)))
    `(LET ((,OLD-SHEET TV:MOUSE-SHEET))
       (TV:WITH-MOUSE-GRABBED
	 (UNWIND-PROTECT
	   (PROGN
	     (TV:MOUSE-SET-SHEET ,SHEET)
	     (FUNCALL TV:MOUSE-BLINKER ':SET-VISIBILITY NIL)
	     . ,BODY)
	   (FUNCALL TV:MOUSE-BLINKER ':SET-VISIBILITY T)
	   (TV:MOUSE-SET-SHEET ,OLD-SHEET))))))

;;; Primitive to draw rectangles in color onto SELF.
(DEFMACRO DRAW-COLOR-RECTANGLE (COLOR X1 Y1 X2 Y2)
  `(COLOR:COLOR-BITBLT (+ ,X1 TV:LEFT-MARGIN-SIZE) (+ ,Y1 TV:TOP-MARGIN-SIZE)
		       (+ ,X2 TV:LEFT-MARGIN-SIZE) (+ ,Y2 TV:TOP-MARGIN-SIZE)
		       ,COLOR TV:ALU-SETA SELF))

;(DEFFLAVOR TV:WINDOW-PANE () (TV:PANE-MIXIN TV:WINDOW))

(DEFCONST  3.14159s0)

;;; This is a try at a standard mixin for all color windows to have.
;;; COLOR-MAP's first dimension is by location in the color map
;;; Its second dimension has red, green, and blue elements in 0, 1, and 2,
;;; and 3 is zero if this entry is "not used" and non-zero if it is used.
;;; A not-used entry does not get written into the hardware color map.
;;; SCREEN is the screen of this window.

;;; Note: the criterion used for calling WRITE-COLOR-MAP herein is essentially
;;; bogus.  First of all, just because you're exposed does not mean you are
;;; visible.  Secondly, the window that controls the color map really ought
;;; to have some more distinguishing characteristic than simply being the
;;; latest one exposed; "selected" is not quite right, but something along
;;; those lines is probably called for.

(DEFFLAVOR COLOR-MIXIN (COLOR-MAP SCREEN) ()
  (:INCLUDED-FLAVORS TV:SHEET))

(DEFMETHOD (COLOR-MIXIN :BEFORE :INIT) (&REST IGNORE)
  (SETQ COLOR-MAP (MAKE-ARRAY '(400 4) ':TYPE 'ART-8B))
  (SETQ SCREEN (TV:SHEET-GET-SCREEN SELF)))

;;; Copy the "used" elements of our map into the hardware.
(DEFUN WRITE-MAP (COLOR-MAP SCREEN)
  (LET ((HARDWARE-COLOR-MAP (GET (LOCF (TV:SCREEN-PROPERTY-LIST SCREEN))
				 ':HARDWARE-COLOR-MAP)))
    (DOTIMES (LOCATION 400)
      (COND ((ZEROP (AREF COLOR-MAP LOCATION 3))
	     (ASET (AREF HARDWARE-COLOR-MAP LOCATION 0) COLOR-MAP LOCATION 0)
	     (ASET (AREF HARDWARE-COLOR-MAP LOCATION 1) COLOR-MAP LOCATION 1)
	     (ASET (AREF HARDWARE-COLOR-MAP LOCATION 2) COLOR-MAP LOCATION 2)))))
  (COLOR:BLT-COLOR-MAP COLOR-MAP SCREEN))

(DEFMETHOD (COLOR-MIXIN :BEFORE :EXPOSE) (&REST IGNORE)
  (WRITE-MAP COLOR-MAP SCREEN))

;;; Write given R, G, B values into given location of the color map.
(DEFMETHOD (COLOR-MIXIN :SET-COLOR-MAP) (LOCATION RED GREEN BLUE)
  (ASET (LOGAND 377 (FIX RED))   COLOR-MAP LOCATION 0)
  (ASET (LOGAND 377 (FIX GREEN)) COLOR-MAP LOCATION 1)
  (ASET (LOGAND 377 (FIX BLUE))  COLOR-MAP LOCATION 2)
  (ASET 1 COLOR-MAP LOCATION 3)			; This location is used.
  (IF TV:EXPOSED-P (WRITE-MAP COLOR-MAP SCREEN)))

;;; Make a location unused.
(DEFMETHOD (COLOR-MIXIN :UNSET-COLOR-MAP) (LOCATION)
  (ASET 0 COLOR-MAP LOCATION 3))

;;; Read given location of the color map.
(DEFMETHOD (COLOR-MIXIN :READ-COLOR-MAP) (LOCATION)
  (VALUES (AREF COLOR-MAP LOCATION 0)
	  (AREF COLOR-MAP LOCATION 1)
	  (AREF COLOR-MAP LOCATION 2)
	  (AREF COLOR-MAP LOCATION 3)))

;;; Write given R, G, B values into all elements of the color map.
(DEFMETHOD (COLOR-MIXIN :FILL-COLOR-MAP) (RED GREEN BLUE)
  (LET ((R (LOGAND 377 (FIX RED)))
	(G (LOGAND 377 (FIX GREEN)))
	(B (LOGAND 377 (FIX BLUE))))
    (DOTIMES (I 400)
      (ASET R COLOR-MAP I 0)
      (ASET G COLOR-MAP I 1)
      (ASET B COLOR-MAP I 2)
      (ASET 1 COLOR-MAP I 3)))
  (IF TV:EXPOSED-P (WRITE-MAP COLOR-MAP SCREEN)))

;;; Set my color map from someone else's.
(DEFMETHOD (COLOR-MIXIN :SET-WHOLE-COLOR-MAP) (MAP)
  (DOTIMES (LOCATION 400)
    (DOTIMES (I 4)
      (ASET COLOR-MAP (AREF MAP LOCATION I) LOCATION I)))
  (IF TV:EXPOSED-P (WRITE-MAP COLOR-MAP SCREEN)))

(DEFMETHOD (COLOR-MIXIN :COLORFUL-MAP) ()
  (DO ((I 1 (1+ I))
       (OFFSET 0 (COND ((= I 177) 1) ((= I 376) 2) (T OFFSET))))
      (( I 377))
    (FUNCALL-SELF ':SET-COLOR-MAP I
		  (* (LDB 0001 (+ I OFFSET)) 255.)
		  (* (LDB 0101 (+ I OFFSET)) 255.)
		  (* (LDB 0201 (+ I OFFSET)) 255.)))
  (FUNCALL-SELF ':SET-COLOR-MAP 0 0 0 0)
  (FUNCALL-SELF ':SET-COLOR-MAP 377 255. 255. 255.)
  (IF TV:EXPOSED-P (WRITE-MAP COLOR-MAP SCREEN)))


;;; This flavor displays an array of rectangles showing colors.  It figures
;;; out the number of rows and columns when its size is set or changed.
;;; COLOR-ALIST associates character string names with slots in the color
;;; map, and the Nth rectangle will correspond to the color-map slot cited
;;; by the Nth element in COLOR-ALIST.  BORDER-FRACTION says how much room
;;; to leave between the rectangles.
(DEFFLAVOR COLOR-CHOICE-WINDOW (COLOR-ALIST BORDER-FRACTION
				N-ROWS N-COLUMNS
				PIXELS-PER-ROW PIXELS-PER-COLUMN)
	                       (TV:LIST-MOUSE-BUTTONS-MIXIN COLOR-MIXIN TV:WINDOW)
  (:GETTABLE-INSTANCE-VARIABLES COLOR-ALIST BORDER-FRACTION)
  (:INITABLE-INSTANCE-VARIABLES COLOR-ALIST BORDER-FRACTION)
  (:DEFAULT-INIT-PLIST :BORDER-FRACTION .1s0))

;;; Color zero is used for the space between rectangles.
(DEFCONST *COLOR-CHOICE-BORDER-COLOR* 0)

(DEFMETHOD (COLOR-CHOICE-WINDOW :WHO-LINE-DOCUMENTATION-STRING) ()
  "Click left to edit this color.  Click middle to quit.")

;;; Computation of the number of rows and columns, and their sizes.
(DEFMETHOD (COLOR-CHOICE-WINDOW :AFTER :INIT) (&OPTIONAL IGNORE)
  (COLOR-CHOICE-RECOMPUTE))

(DEFMETHOD (COLOR-CHOICE-WINDOW :AFTER :CHANGE-OF-SIZE-OR-MARGINS) (&REST IGNORE)
  (COLOR-CHOICE-RECOMPUTE))

(DEFUN COLOR-CHOICE-RECOMPUTE ()
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (COLOR-CHOICE-WINDOW)
    (MULTIPLE-VALUE-BIND (INSIDE-WIDTH INSIDE-HEIGHT)
	(FUNCALL-SELF ':INSIDE-SIZE)
      (LET ((N-COLORS (LENGTH COLOR-ALIST)))
	;; Figure out the best value for N-COLUMNS by trying all possible
	;; values and seeing which is closest to a square.
	(DO ((NC 1 (1+ NC))
	     (BEST-RATIO 1.0S5))
	    ((> NC N-COLORS)
	     (SETQ PIXELS-PER-COLUMN (// INSIDE-WIDTH N-COLUMNS)
		   PIXELS-PER-ROW (// INSIDE-HEIGHT N-ROWS)))
	  ;; Given that NC is the number of columns, how square would the boxes be?
	  (LET* ((NR (// (+ N-COLORS NC -1) NC))
		 (RATIO (// (SMALL-FLOAT (// INSIDE-WIDTH NC))
			    (SMALL-FLOAT (// INSIDE-HEIGHT NR))))
		 (RATIO* (IF (> RATIO 1.0s0)
			     RATIO
			     (// 1.0s0 RATIO))))
	    (IF (< RATIO* BEST-RATIO)
		(SETQ BEST-RATIO RATIO*
		      N-COLUMNS NC
		      N-ROWS NR))))))))

;;; Redisplay.
(DEFMETHOD (COLOR-CHOICE-WINDOW :AFTER :REFRESH) (&OPTIONAL TYPE)
  (AND (OR (NOT TV:RESTORED-BITS-P) (EQ TYPE ':SIZE-CHANGED))
       (TV:SHEET-FORCE-ACCESS (SELF)
	 ;; Redraw the window contents.
	 (MULTIPLE-VALUE-BIND (INSIDE-WIDTH INSIDE-HEIGHT)
	     (FUNCALL-SELF ':INSIDE-SIZE)
	   (LET* ((COLUMN-BORDER (FIX (* PIXELS-PER-COLUMN BORDER-FRACTION)))
		  (ROW-BORDER (FIX (* PIXELS-PER-ROW BORDER-FRACTION)))
		  (ALIST COLOR-ALIST))
	     (DO ((ROW 0 (1+ ROW))
		  (ROW-START-PIXEL 0 ROW-END-PIXEL)
		  (ROW-END-PIXEL PIXELS-PER-ROW (+ ROW-END-PIXEL PIXELS-PER-ROW)))
		 (( ROW N-ROWS))
	       (IF (= ROW (1- N-ROWS))
		   ;; Last time, fill up the window.
		   (SETQ ROW-END-PIXEL INSIDE-HEIGHT))
	       (DO ((COLUMN 0 (1+ COLUMN))
		    (COLUMN-START-PIXEL 0 COLUMN-END-PIXEL)
		    (COLUMN-END-PIXEL PIXELS-PER-COLUMN
				      (+ COLUMN-END-PIXEL PIXELS-PER-COLUMN)))
		   (( COLUMN N-COLUMNS))
		 (IF (= COLUMN (1- N-COLUMNS))
		     ;; Last time, fill up the window.
		     (SETQ COLUMN-END-PIXEL INSIDE-WIDTH))
		 (IF (NULL ALIST)
		     ;; No more elements, just filling up unused spaces.
		     (DRAW-COLOR-RECTANGLE *COLOR-CHOICE-BORDER-COLOR*
					   (- COLUMN-END-PIXEL COLUMN-START-PIXEL)
					   (- ROW-END-PIXEL ROW-START-PIXEL)
					   COLUMN-START-PIXEL ROW-START-PIXEL)
		     ;; Real elements.
		     (LET* ((COLOR-ELEMENT (CAR ALIST))
			    (INSIDE-ROW-START-PIXEL (+ ROW-START-PIXEL ROW-BORDER))
			    (INSIDE-ROW-END-PIXEL (- ROW-END-PIXEL ROW-BORDER))
			    (INSIDE-COLUMN-START-PIXEL (+ COLUMN-START-PIXEL COLUMN-BORDER))
			    (INSIDE-COLUMN-END-PIXEL (- COLUMN-END-PIXEL COLUMN-BORDER)))
		       ;; Put in the border, in four pieces.
		       (DRAW-COLOR-RECTANGLE *COLOR-CHOICE-BORDER-COLOR*	; left edge
					     COLUMN-START-PIXEL ROW-START-PIXEL
					     INSIDE-COLUMN-START-PIXEL ROW-END-PIXEL)
		       (DRAW-COLOR-RECTANGLE *COLOR-CHOICE-BORDER-COLOR*	; right edge
					     INSIDE-COLUMN-END-PIXEL ROW-START-PIXEL
					     COLUMN-END-PIXEL ROW-END-PIXEL)
		       (DRAW-COLOR-RECTANGLE *COLOR-CHOICE-BORDER-COLOR*	; top edge
					     INSIDE-COLUMN-START-PIXEL ROW-START-PIXEL
					     INSIDE-COLUMN-END-PIXEL INSIDE-ROW-START-PIXEL)
		       (DRAW-COLOR-RECTANGLE *COLOR-CHOICE-BORDER-COLOR*	; bottom edge
					     INSIDE-COLUMN-START-PIXEL INSIDE-ROW-END-PIXEL
					     INSIDE-COLUMN-END-PIXEL ROW-END-PIXEL)
		       ;; Put in the color itself.
		       (DRAW-COLOR-RECTANGLE (CDR COLOR-ELEMENT)
					     INSIDE-COLUMN-START-PIXEL INSIDE-ROW-START-PIXEL
					     INSIDE-COLUMN-END-PIXEL INSIDE-ROW-END-PIXEL)
		       (POP ALIST))))))))))

;;; In tidy mode, don't show user the color editor until it is all set up.
(DEFVAR *TIDY-MODE* T)

;;; This is the editor command loop.  Do single-click-left over the palette
;;; element you want to edit.  Single-click-middle or any kbd character exits.
(DEFMETHOD (COLOR-CHOICE-WINDOW :EDIT) ()
  (DO () (())
    (LET ((BLIP (FUNCALL-SELF ':ANY-TYI)))
      (COND ((LISTP BLIP)
	     (LET ((BUTTON (SECOND BLIP))
		   (X (FOURTH BLIP))
		   (Y (FIFTH BLIP)))
	       (COND ((= BUTTON #\MOUSE-L-1)
		      ;; Single-click left on a palette edits this color.
		      (LET* ((ROW (MIN N-ROWS (MAX 0 (// Y PIXELS-PER-ROW))))
			     (COLUMN (MIN N-COLUMNS (MAX 0 (// X PIXELS-PER-COLUMN))))
			     (COLOR-ELEMENT (NTH (+ COLUMN (* ROW N-COLUMNS)) COLOR-ALIST)))
			(COND ((NULL COLOR-ELEMENT)
			       (FUNCALL-SELF ':BEEP))
			      (T
			       (LET ((COLOR-NAME (CAR COLOR-ELEMENT))
				     (SLOT-NUMBER (CDR COLOR-ELEMENT)))
				 (USING-RESOURCE (FRAME COLOR-EDITORS)
				   (UNWIND-PROTECT
				     (PROGN
				       (IF (NOT *TIDY-MODE*)
					   (FUNCALL FRAME ':EXPOSE))
				       (MULTIPLE-VALUE-BIND (OLD-RED OLD-GREEN OLD-BLUE)
					   (FUNCALL-SELF ':READ-COLOR-MAP SLOT-NUMBER)
					 (MULTIPLE-VALUE-BIND (NEW-RED NEW-GREEN NEW-BLUE)
					     (FUNCALL FRAME ':EDIT
						      (STRING-APPEND "Editing " COLOR-NAME)
						      OLD-RED OLD-GREEN OLD-BLUE)
					   (FUNCALL FRAME ':DEACTIVATE)
					   (IF (NOT (NULL NEW-RED))
					       (FUNCALL-SELF ':SET-COLOR-MAP SLOT-NUMBER
							     NEW-RED NEW-GREEN NEW-BLUE)
					       (FUNCALL-SELF ':BEEP)))))
				     (FUNCALL FRAME ':DEACTIVATE))))))))
		     ((= BUTTON #\MOUSE-M-1)
		      ;; Single-click middle means quit.
		      (RETURN))
		     (T (FUNCALL-SELF ':BEEP)))))
	    (T					; not a blip
	     (RETURN))))))

(DEFVAR W)

(DEFUN PALETTE ()
  (WITH-MOUSE-SHEET (COLOR:COLOR-SCREEN)
    (LET ((OLD-SEL TV:SELECTED-WINDOW))
      (UNWIND-PROTECT
	(PROGN
	  (SETQ W (MAKE-INSTANCE
		    'COLOR-CHOICE-WINDOW
		    ':COLOR-ALIST '(("a" . 1) ("b" . 2) ("c" . 3)
				    ("d" . 4) ("e" . 5) ("f" . 6))
		    ':SUPERIOR COLOR:COLOR-SCREEN
		    ':BOTTOM 100
		    ':BLINKER-P NIL
		    ':LABEL NIL))
	  (FUNCALL W ':COLORFUL-MAP)
	  (FUNCALL W ':EXPOSE)
	  (FUNCALL W ':EDIT))
	(FUNCALL W ':DEACTIVATE)
	(FUNCALL OLD-SEL ':SELECT))))
  W)

;;; Init-options for slider windows:
;;; :FORMAT-CONTROL is format control string for printing out the current value.
;;; :LABEL-STRING is the name to appear before the number.
;;; :MIN is the minimum value of the variable.
;;; :MAX is the maximum value of the variable.
;;; :VALUE is the current value.

;;; Meanings of other instance variables:
;;; LINE-Y is the Y-coord of the line; LINE-DY is the half-length of the
;;;   little vertical lines at the end.  LINE-X1 snd LINE-X2 are the X-coords
;;;   of the ends of the line (and of the little vertical lines.)
;;; KNOB-HEIGHT and KNOB-WIDTH are the size of the knob in pixels.
;;; KNOB-X is the X-position of the knob, or NIL if no knob is being displayed.
;;; KNOB-BITS is an image of the knob, to be BLTed onto the window.
;;; KNOB-SAVE-BITS is another array of the same size used to save what is
;;;   underneath the knob.
;;; LABEL-END-X is where the label ends and the number begins.

(DEFFLAVOR SLIDER-WINDOW (FORMAT-CONTROL LABEL-STRING MIN MAX VALUE
			  LINE-Y LINE-DY LINE-X1 LINE-X2
			  KNOB-X KNOB-HEIGHT KNOB-WIDTH KNOB-BITS KNOB-SAVE-BITS
			  LABEL-END-X)
			 (TV:LINE-TRUNCATING-MIXIN TV:WINDOW)
  (:DEFAULT-INIT-PLIST :FORMAT-CONTROL "~4,2F" :BLINKER-P NIL :LABEL NIL)
  (:INITABLE-INSTANCE-VARIABLES FORMAT-CONTROL LABEL-STRING MIN MAX VALUE)
  (:GETTABLE-INSTANCE-VARIABLES FORMAT-CONTROL LABEL-STRING MIN MAX VALUE))

(DEFMETHOD (SLIDER-WINDOW :AFTER :INIT) (&REST IGNORE)
  (CHECK-ARG FORMAT-CONTROL STRINGP "a string")
  (CHECK-ARG MIN NUMBERP "a number")
  (CHECK-ARG MAX NUMBERP "a number")
  (SETQ VALUE (MIN MAX (MAX MIN VALUE)))
  (SETQ KNOB-X NIL)
  (SLIDER-RECOMPUTE))

(DEFMETHOD (SLIDER-WINDOW :AFTER :CHANGE-OF-SIZE-OR-MARGINS) (&REST IGNORE)
  (SLIDER-RECOMPUTE))

(DEFCONST *SLIDER-SPACE-1* 0)			; Between top of window and label-string.
(DEFCONST *SLIDER-SPACE-2* 0)			; Between bottom of label-string and center.
(DEFCONST *SLIDER-SIDE-SPACE* 0.05s0)		; Between end of line and left (right) edge.
(DEFCONST *SLIDER-LINE-COLOR* 377)		; Color for the line.
(DEFCONST *SLIDER-KNOB-HEIGHT* 2.0s0)		; Function of LINE-DY.
(DEFCONST *SLIDER-KNOB-WIDTH* 0.05s0)		; Function of (- LINE-x2 LINE-x1).

(DEFUN SLIDER-RECOMPUTE ()
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (SLIDER-WINDOW)
     (MULTIPLE-VALUE-BIND (INSIDE-WIDTH INSIDE-HEIGHT)
	 (FUNCALL-SELF ':INSIDE-SIZE)
       (LET ((TOP-PART-HEIGHT (+ *SLIDER-SPACE-1*
				 (FONT-RASTER-HEIGHT TV:CURRENT-FONT)
				 *SLIDER-SPACE-2*)))
	 (SETQ LINE-Y (// (+ INSIDE-HEIGHT TOP-PART-HEIGHT) 2)
	       LINE-DY (// (- INSIDE-HEIGHT TOP-PART-HEIGHT) 4)
	       LINE-X1 (FIX (* *SLIDER-SIDE-SPACE* INSIDE-WIDTH))
	       LINE-X2 (- INSIDE-WIDTH LINE-X1)
	       KNOB-HEIGHT (1+ (* 2 (// (1+ (FIX (* *SLIDER-KNOB-HEIGHT* LINE-DY))) 2)))
	       KNOB-WIDTH (1+ (* 2 (// (1+ (FIX (* *SLIDER-KNOB-WIDTH*
						   (- LINE-X2 LINE-X1)))) 2))))
	 (SETQ KNOB-BITS (TV:MAKE-SHEET-BIT-ARRAY SELF KNOB-WIDTH KNOB-HEIGHT)
	       KNOB-SAVE-BITS (TV:MAKE-SHEET-BIT-ARRAY SELF KNOB-WIDTH KNOB-HEIGHT))
	 ;; Draw the image of the knob.
	 (DOTIMES (I KNOB-HEIGHT)
	   (ASET *SLIDER-LINE-COLOR* KNOB-BITS 0 I)
	   (ASET *SLIDER-LINE-COLOR* KNOB-BITS (1- KNOB-WIDTH) I))
	 (DOTIMES (I KNOB-WIDTH)
	   (ASET *SLIDER-LINE-COLOR* KNOB-BITS I 0)
	   (ASET *SLIDER-LINE-COLOR* KNOB-BITS I (1- KNOB-HEIGHT)))))))

(DEFMETHOD (SLIDER-WINDOW :AFTER :REFRESH) (&OPTIONAL TYPE)
  (COND ((OR (NOT TV:RESTORED-BITS-P) (EQ TYPE ':SIZE-CHANGED))
	 ;; Write the text at the top.
	 (FUNCALL-SELF ':SET-CURSORPOS 0 *SLIDER-SPACE-1*)
	 (FUNCALL-SELF ':CLEAR-EOL)
	 (FUNCALL-SELF ':STRING-OUT LABEL-STRING)
	 (FUNCALL-SELF ':STRING-OUT ": ")
	 (SETQ LABEL-END-X (FUNCALL-SELF ':READ-CURSORPOS))
	 (FORMAT SELF FORMAT-CONTROL (FLOAT VALUE))	;kludge!!!
	 ;; Draw the line.
	 (FUNCALL-SELF ':DRAW-LINE LINE-X1 LINE-Y LINE-X2 LINE-Y)
	 (FUNCALL-SELF ':DRAW-LINE LINE-X1 (- LINE-Y LINE-DY) LINE-X1 (+ LINE-Y LINE-DY))
	 (FUNCALL-SELF ':DRAW-LINE LINE-X2 (- LINE-Y LINE-DY) LINE-X2 (+ LINE-Y LINE-DY))
	 ;; Draw the knob.
	 (SETQ KNOB-X NIL)
	 (SLIDER-DRAW-KNOB)
	 )))

(DEFUN SLIDER-DRAW-KNOB ()
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (SLIDER-WINDOW)
    (IF (NOT (NULL KNOB-X))
	(SLIDER-UNDRAW-KNOB))
    (SETQ KNOB-X (+ LINE-X1 (FIX (* (- LINE-X2 LINE-X1)
				    (// (- (SMALL-FLOAT VALUE) MIN) (- MAX MIN))))))
    (FUNCALL-SELF ':BITBLT-FROM-SHEET
		  TV:ALU-SETA KNOB-WIDTH KNOB-HEIGHT
		  (- KNOB-X (1+ (// KNOB-WIDTH 2))) (- LINE-Y LINE-DY)
		  KNOB-SAVE-BITS 0 0)
    (FUNCALL-SELF ':BITBLT
		  TV:ALU-SETA KNOB-WIDTH KNOB-HEIGHT
		  KNOB-BITS 0 0
		  (- KNOB-X (1+ (// KNOB-WIDTH 2))) (- LINE-Y LINE-DY))))

(DEFUN SLIDER-UNDRAW-KNOB ()
  (DECLARE-FLAVOR-INSTANCE-VARIABLES (SLIDER-WINDOW)
    (COND ((NOT (NULL KNOB-X))
	   (FUNCALL-SELF ':BITBLT
			 TV:ALU-SETA KNOB-WIDTH KNOB-HEIGHT
			 KNOB-SAVE-BITS 0 0
			 (- KNOB-X (1+ (// KNOB-WIDTH 2))) (- LINE-Y LINE-DY))))
    (SETQ KNOB-X NIL)))

(DEFMETHOD (SLIDER-WINDOW :SET-VALUE) (NEW-VALUE)
  (SETQ VALUE (MIN MAX (MAX MIN NEW-VALUE)))
  (SLIDER-UNDRAW-KNOB)
  (FUNCALL-SELF ':SET-CURSORPOS LABEL-END-X *SLIDER-SPACE-1*)
  (FUNCALL-SELF ':CLEAR-EOL)
  (FORMAT SELF FORMAT-CONTROL (FLOAT VALUE))	;kludge!!!
  (SLIDER-DRAW-KNOB))

(DEFMETHOD (SLIDER-WINDOW :MOUSE-BUTTONS) (IGNORE IGNORE IGNORE)
  (FUNCALL-SELF ':FORCE-KBD-INPUT (LIST 'SLIDER-BUTTONS SELF)))

;;; Track the mouse.  This runs in the calling process.
;;; When mouse-tracking sets the value of the window, it uses a :MOUSE-SET-VALUE
;;; message.  This is what you should add daemons to if you want to get
;;; extra effects during mouse tracking (rather than putting daemons onto :SET-VALUE).
;;; The basic method just turns into a :SET-VALUE.
(DEFMETHOD (SLIDER-WINDOW :TRACK-MOUSE) ()
  (WITH-MOUSE-CAPTURED (SELF)
    (DO () (())
      (IF (ZEROP TV:MOUSE-LAST-BUTTONS)
	  (RETURN))
      (FUNCALL-SELF ':MOUSE-SET-VALUE
		    (+ (* (// (SMALL-FLOAT (- TV:MOUSE-X LINE-X1))
			      (- LINE-X2 LINE-X1))
			  (- MAX MIN))
		       MIN))
      (TV:MOUSE-WAIT))))

(DEFMETHOD (SLIDER-WINDOW :MOUSE-SET-VALUE) (NEW-VALUE)
  (FUNCALL-SELF ':SET-VALUE NEW-VALUE))

;;; Color editor.

;;; This kind of pane is used to show the user the color you are editing.
(DEFFLAVOR EDITOR-DISPLAY-PANE () (TV:WINDOW-PANE)
  (:DEFAULT-INIT-PLIST :BLINKER-P NIL :LABEL NIL :BORDER-MARGIN-WIDTH 0))

(DEFCONST *SAMPLE-LOC* 376)

(DEFMETHOD (EDITOR-DISPLAY-PANE :AFTER :REFRESH) (&OPTIONAL TYPE)
  (AND (OR (NOT TV:RESTORED-BITS-P) (EQ TYPE ':SIZE-CHANGED))
       (MULTIPLE-VALUE-BIND (WIDTH HEIGHT)
	   (FUNCALL-SELF ':INSIDE-SIZE)
	 (DRAW-COLOR-RECTANGLE *SAMPLE-LOC* 0 0 WIDTH HEIGHT))))

(DEFMETHOD (EDITOR-DISPLAY-PANE :WHO-LINE-DOCUMENTATION-STRING) ()
  "Use the mouse on the sliders to edit this color, or on the menu to finish editing.")


;;; This kind of pane is basically a slider that tells its superior
;;; whenever anything happens to its value because of the mouse.
(DEFFLAVOR EDITOR-SLIDER-PANE (WHOAMI) (TV:PANE-MIXIN SLIDER-WINDOW)
  (:DEFAULT-INIT-PLIST :MIN 0.0s0 :MAX 1.0s0 :VALUE 0.0s0 :WHOAMI NIL
		       :FONT-MAP '(FONTS:TVFONT))
  (:SETTABLE-INSTANCE-VARIABLES WHOAMI))

;;; If any inferior gets his value change by the mouse, let the superior know.
(DEFMETHOD (EDITOR-SLIDER-PANE :AFTER :MOUSE-SET-VALUE) (IGNORE)
  (FUNCALL TV:SUPERIOR ':INFERIOR-MOUSE-SET-VALUE WHOAMI VALUE))

(DEFMETHOD (EDITOR-SLIDER-PANE :WHO-LINE-DOCUMENTATION-STRING) ()
  "Click left to move the slider to this point.  Hold down to continuously move the slider.")


;;; This is a color-editor frame.
(DEFFLAVOR COLOR-EDITOR (RED-PANE GREEN-PANE BLUE-PANE
			 INTENSITY-PANE HUE-PANE SATURATION-PANE)
	   (TV:BORDERS-MIXIN
	    TV:TOP-LABEL-MIXIN
	    COLOR-MIXIN
	    TV:BORDERED-CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER))

(DEFRESOURCE COLOR-EDITORS ()
  :CONSTRUCTOR
   (TV:WINDOW-CREATE
     'COLOR-EDITOR
     ':SAVE-BITS T
     ':SUPERIOR COLOR:COLOR-SCREEN
     ':PANES
     `((RED-BAR EDITOR-SLIDER-PANE :LABEL-STRING "Red" :WHOAMI RED)
       (GREEN-BAR EDITOR-SLIDER-PANE :LABEL-STRING "Green" :WHOAMI GREEN)
       (BLUE-BAR EDITOR-SLIDER-PANE :LABEL-STRING "Blue" :WHOAMI BLUE)
       (INTENSITY-BAR EDITOR-SLIDER-PANE :LABEL-STRING "Intensity" :WHOAMI INTENSITY
		      :MIN 0.0s0 :MAX ,(SMALL-FLOAT (SQRT 3.0)))
       (HUE-BAR EDITOR-SLIDER-PANE :LABEL-STRING "Hue" :WHOAMI HUE
		:MIN ,(- ) :MAX ,)
       (SATURATION-BAR EDITOR-SLIDER-PANE :LABEL-STRING "Saturation" :WHOAMI SATURATION)
       (DISPLAY EDITOR-DISPLAY-PANE)
       (MENU TV:COMMAND-MENU-PANE :ITEM-LIST
	     (("Done" :VALUE DONE :DOCUMENTATION "Finish editing this color.")
	      ("Abort" :VALUE ABORT :DOCUMENTATION "Abort editing this color.")))
       )
     ':CONSTRAINTS
     '((MAIN . ((DISPLAY
		  MENU
		  RED-BAR GREEN-BAR BLUE-BAR
		  INTENSITY-BAR HUE-BAR SATURATION-BAR)
		((DISPLAY 0.5s0))
		((MENU :ASK :PANE-SIZE))
		((RED-BAR :EVEN)
		 (GREEN-BAR :EVEN)
		 (BLUE-BAR :EVEN)
		 (INTENSITY-BAR :EVEN)
		 (HUE-BAR :EVEN)
		 (SATURATION-BAR :EVEN)))))))

;;; Initialization for COLOR-EDITOR frames.  Just get all the panes
;;; into instance variables, and set up some color map elements.
(DEFMETHOD (COLOR-EDITOR :AFTER :INIT) (&REST IGNORE)
  (FUNCALL-SELF ':SET-COLOR-MAP 0 0 0 0)
  (FUNCALL-SELF ':SET-COLOR-MAP *SLIDER-LINE-COLOR* 255. 255. 255.)
  (SETQ RED-PANE (FUNCALL-SELF ':GET-PANE 'RED-BAR)
	GREEN-PANE (FUNCALL-SELF ':GET-PANE 'GREEN-BAR)
	BLUE-PANE (FUNCALL-SELF ':GET-PANE 'BLUE-BAR)
	INTENSITY-PANE (FUNCALL-SELF ':GET-PANE 'INTENSITY-BAR)
	HUE-PANE (FUNCALL-SELF ':GET-PANE 'HUE-BAR)
	SATURATION-PANE (FUNCALL-SELF ':GET-PANE 'SATURATION-BAR)))

;;; This is for demos of the color editor.
(DEFUN EDIT-COLORS ()
  (WITH-MOUSE-SHEET (COLOR:COLOR-SCREEN)
    (LET (VAL1 VAL2 VAL3)
      (USING-RESOURCE (FRAME COLOR-EDITORS)
	(FUNCALL FRAME ':EXPOSE)
	(MULTIPLE-VALUE (VAL1 VAL2 VAL3)
	  (FUNCALL FRAME ':EDIT "Demonstration of the color editor." 0 0 0))
	(FUNCALL FRAME ':DEACTIVATE))
      (VALUES VAL1 VAL2 VAL3))))

;;; Takes three values, representing RED, GREEN, and BLUE levels expressed
;;; as fixnums.  Edits them and returns three new values as fixnums, or NIL
;;; if the user aborts.  COLOR-NAME is displayed in the label as the
;;; name of the color being edited.
(DEFMETHOD (COLOR-EDITOR :EDIT) (LABEL RED GREEN BLUE)
  (TV:SHEET-FORCE-ACCESS (SELF)
    (FUNCALL-SELF ':SET-LABEL LABEL)
    (FUNCALL RED-PANE ':MOUSE-SET-VALUE (// RED 255.0s0))
    (FUNCALL GREEN-PANE ':MOUSE-SET-VALUE (// GREEN 255.0s0))
    (FUNCALL BLUE-PANE ':MOUSE-SET-VALUE (// BLUE 255.0s0))
    (FUNCALL RED-PANE ':CLEAR-INPUT))
  (IF (NOT TV:EXPOSED-P)
      (FUNCALL-SELF ':EXPOSE))
  (DO ()
      (())
    (LET ((CHAR (FUNCALL RED-PANE ':ANY-TYI)))
      (COND ((AND (LISTP CHAR)
		  (SELECTQ (FIRST CHAR)
		    (SLIDER-BUTTONS
		     (FUNCALL (SECOND CHAR) ':TRACK-MOUSE))
		    (:MENU
		     (SELECTQ (FUNCALL (FOURTH CHAR) ':EXECUTE (SECOND CHAR))
		       (DONE
			(RETURN (FUNCALL-SELF ':READ-COLOR-MAP *SAMPLE-LOC*)))
		       (ABORT
			(RETURN NIL)))))))))))

;;; Magic constants for the IHSRGB conversion algorithm.
(DEFCONST C1 (SQRT (// 6.0)))
(DEFCONST C2 (SQRT (// 2.0)))
(DEFCONST C3 (SQRT (// 3.0)))

;;; This is called when one of the inferiors got its value changed by the
;;; mouse; it is forwarded to us by a daemon on the :MOUSE-SET-VALUE
;;; message.  This method must update the other three sliders, and change
;;; the color map itself.
(DEFMETHOD (COLOR-EDITOR :INFERIOR-MOUSE-SET-VALUE) (WHOISIT IGNORE)
  (LET ((R) (G) (B))
    (COND ((MEMQ WHOISIT '(RED GREEN BLUE))
	   (SETQ R (FUNCALL RED-PANE ':VALUE)
		 G (FUNCALL GREEN-PANE ':VALUE)
		 B (FUNCALL BLUE-PANE ':VALUE))
	   ;; Do :SET-VALUEs on the other three.
	   (LET* ((X (* C1 (- (+ R R) B G)))
		  (Y (* C2 (- G B)))
		  (Z (* C3 (+ R G B)))
		  (Q (+ (* X X) (* Y Y)))
		  (I (SMALL-FLOAT (SQRT (+ Q (* Z Z))))))
	     (FUNCALL INTENSITY-PANE ':SET-VALUE I)
	     (COND ((ZEROP Q)
		    (FUNCALL HUE-PANE ':SET-VALUE 0.0s0)
		    (FUNCALL SATURATION-PANE ':SET-VALUE 0.0s0))
		   (T
		    (FUNCALL HUE-PANE ':SET-VALUE (SMALL-FLOAT (ATAN2 Y X)))
		    (FUNCALL SATURATION-PANE
			     ':SET-VALUE
			     (LET ((F (// Z I)))
			       ;; RG claims this MAX is needed.  I can't make the problem
			       ;; happen, but might as well leave it in. -- DLW 6/20/81
			       (SMALL-FLOAT (ATAN2 (SQRT (MAX 0.0s0 (- 1.0 (* F F))))
						   F))))))
	     ))
	  (T
	   (LET ((I (FUNCALL INTENSITY-PANE ':VALUE))
		 (H (FUNCALL HUE-PANE ':VALUE))
		 (S (FUNCALL SATURATION-PANE ':VALUE)))
	     ;; Figure out R, G, and B.
	     (LET* ((S3 (SIN S))
		    (Z (* C3 (COS S) I))
		    (X (* C1 S3 (COS H) I))
		    (Y (* C2 S3 (SIN H) I)))
	       (SETQ R (+ X X Z)
		     G (+ Y Z (- X))
		     B (- Z X Y)))
	     (FUNCALL RED-PANE ':SET-VALUE R)
	     (FUNCALL GREEN-PANE ':SET-VALUE G)
	     (FUNCALL BLUE-PANE ':SET-VALUE B)
	     (SETQ R (FUNCALL RED-PANE ':VALUE)
		   G (FUNCALL GREEN-PANE ':VALUE)
		   B (FUNCALL BLUE-PANE ':VALUE)))))
    (FUNCALL-SELF ':SET-COLOR-MAP
		  *SAMPLE-LOC*
		  (FIX (* R 255.0s0)) (FIX (* G 255.0s0)) (FIX (* B 255.0s0)))))

;;; ;;; Magic functions from Seth Steinberg, Oct 19 1976.
;;; (DEFUN RGB-TO-IHS (R G B)
;;;   (LET* ((X (* C1 (- (+ R R) B G)))
;;; 	 (Y (* C2 (- G B)))
;;; 	 (Z (* C3 (+ R G B)))
;;; 	 (Q (+ (* X X) (* Y Y)))
;;; 	 (I (SQRT (+ Q (* Z Z)))))
;;;     (IF (ZEROP Q)
;;; 	(VALUES I 0.0 0.0)
;;; 	(VALUES I (ATAN2 Y X)
;;; 		;;(ATAN2 Q Z)  Seth's formula does not work.
;;; 		(LET ((F (// Z I)))
;;; 		  (ATAN2 (SQRT (- 1.0 (* F F))) F))))))
;;; 
;;; (DEFUN IHS-TO-RGB (I H S)
;;;   (LET* ((S3 (SIN S))
;;; 	 (Z (* C3 (COS S) I))
;;; 	 (X (* C1 S3 (COS H) I))
;;; 	 (Y (* C2 S3 (SIN H) I)))
;;;     (VALUES (+ X X Z)
;;; 	    (+ Y Z (- X))
;;; 	    (- Z X Y))))

(COMPILE-FLAVOR-METHODS COLOR-CHOICE-WINDOW
			COLOR-EDITOR EDITOR-SLIDER-PANE EDITOR-DISPLAY-PANE)