;;; -*- Mode:LISP; Package:COLOR; Base:10; Readtable:ZL -*-
;; Copyright LISP Machine, Inc. 1984, 1985, 1986
;;    See filename "Copyright.Text" for
;; licensing and release information.

;; this is a complete reworking of the old COLOR support from the CADR
;; the usefull functions have been made device independant. There are a few messages all color devices
;; must accept. 10/28/84 09:19:14 -george carrette

;***** Things to do *****
; * Color functions based on hue and intensity and saturation, or other coordinate scheme,
;   which is independant of the number of bits per pixel.
; * Then this file should be the device-independant part of the color system.
; * %NUBUS-WRITE-SYNC needed (put in with the device dependant code)
; * Code for handling more than one color screen.

;SCREEN data structure for the color TV

(DEFVAR COLOR-SCREEN :UNBOUND
  "The default screen for doing making color window applications")

(SI:FORWARD-VALUE-CELL 'COLOR-SCREEN (intern "GREY-SCREEN" "GREY"))

(DEFUN COLOR-EXISTS-P (&OPTIONAL SCREEN)
  "T if this machine has color screen hardware. return NIL if called on
an argument which is not the grey-screen, e.g. calls to this function
from obsolete :EXPOSE methods of the old color screen code."
  (cond (screen
	 (send screen :device-attached?))
	((boundp 'color-screen)
	 (send color-screen :device-attached?))
	(t
	 nil)))

(DEFUN hardware-color-map (&optional (screen color-screen))
  "Returns a 3xN dimension array, where N = 2^B, where B= number of bits per pixel supported
by the particular hardware connected to the screen"
  (get (locf (tv:screen-property-list screen))
       ':hardware-color-map))

(DEFUN hardware-color-map-dimension (&optional (screen color-screen))
  "Returns the number of colors, N that the hardware can support simultaneously. A valid
first argument to WRITE-COLOR-MAP is then J such that: 0 <= J < N"
  (array-dimension (hardware-color-map screen) 1))


(DEFUN read-color-map (loc &optional (screen color-screen))
  (send screen :read-color-map loc))

(DEFUN write-color-map (loc r g b &optional (synchronize nil) (screen color-screen))
  (send screen :write-color-map loc r g b synchronize))

(DEFUN write-color-map-immediate (loc r g b &optional (screen color-screen))
  (send screen :write-color-map-immediate loc r g b))


(DEFUN blt-color-map (array &optional (screen color-screen))
    "write the entire color map of screen from ARRAY
ARRAY could be a saved copy of HARDWARE-COLOR-MAP."
    (check-arg array (and (= (hardware-color-map-dimension screen)
			     (array-dimension array 0))
			  (>= (array-dimension array 1) 3))
	       "an array compatible with the hardware color map")
  (send screen :blt-color-map array))



(DEFVAR COLOR-MAP-ON #o377)
(DEFVAR COLOR-MAP-OFF 0)

;;; Fill the color map with the specified color from the specified starting address
(DEFUN FILL-COLOR-MAP (R G B &OPTIONAL (START 1) (SCREEN COLOR-SCREEN))
  "Write color map starting with START with R, G, B."
  (DO ((I START (1+ I))
       (n (hardware-color-map-dimension screen)))
      ((= I n))
    (WRITE-COLOR-MAP I R G B T SCREEN)))




(defun BITBLT-ARRAY (screen)
  (cond ((typep screen 'tv:screen)
	 (or (GET (LOCF (TV:SCREEN-PROPERTY-LIST SCREEN))
		  :bitblt-array)
	     (putprop (LOCF (TV:SCREEN-PROPERTY-LIST SCREEN))
		      (make-array '(1 8)
				  ':type (array-type (send screen :screen-array)))
		      :bitblt-array)))
	((typep screen 'tv:window)
	 (bitblt-array (send screen :superior)))
	('else
	 (ferror nil "not a screen or window: ~S" screen))))

(DEFUN BARS (SIZE &OPTIONAL (START 0) (SCREEN COLOR-SCREEN))
  "Draw 16 vertical bars of width SIZE on color-screen SCREEN.
Start at horizontal position START.
Bar n is drawn in color n."
  (TV:PREPARE-SHEET (SCREEN)
    (DO ((COLOR 0 (1+ COLOR))
	 (bitblt-array (bitblt-array screen))
	 (SCREEN-WIDTH (TV:SHEET-WIDTH SCREEN))
	 (HEIGHT (TV:SHEET-HEIGHT SCREEN))
	 (TARGET-ARRAY (TV:SHEET-SCREEN-ARRAY SCREEN)))
	((> COLOR 16))
      (array-initialize bitblt-array (1+ COLOR))
      (OR (> (+ START (* SIZE COLOR) SIZE) SCREEN-WIDTH)
          (BITBLT TV:ALU-SETA SIZE HEIGHT
                  BITBLT-ARRAY 0 0
                  TARGET-ARRAY (+ START (* SIZE COLOR)) 0)))))

(DEFUN RECTANGLE (X Y WIDTH HEIGHT COLOR
                      &OPTIONAL (ALU TV:ALU-SETA) (SCREEN COLOR-SCREEN)
		      &aux (bitblt-array (bitblt-array screen)))
  "Draw a colored rectangle of color COLOR, with top left corner X and Y.
The width and height are WIDTH and HEIGHT.  It is drawn on color screen SCREEN."
  (array-initialize bitblt-array COLOR)
  (TV:PREPARE-SHEET (SCREEN)
    (BITBLT ALU WIDTH HEIGHT
	    BITBLT-ARRAY 0 0
	    (TV:SHEET-SCREEN-ARRAY SCREEN) X Y)))

(COMPILER:MAKE-OBSOLETE COLOR-BITBLT "use COLOR:RECTANGLE with slightly different args")
(DEFUN COLOR-BITBLT (X1 Y1 X2 Y2 &OPTIONAL (COLOR 17) (ALU TV:ALU-SETA) (SCREEN COLOR-SCREEN))
  "Fill rectangle with endpoints X1, Y1 and X2, Y2 with color COLOR."
  (rectangle x1 y1 (- x2 x1) (- y2 y1) color alu screen))


(DEFUN R-G-B-BARS (&OPTIONAL (WIDTH #o20) (SCREEN COLOR-SCREEN))
  "Draw alternating red, green and blue bars of width WIDTH on SCREEN."
  (R-G-B-COLOR-MAP)
  (BARS WIDTH 0 SCREEN))

(DEFCONST R-G-B `((,COLOR-MAP-ON ,COLOR-MAP-OFF ,COLOR-MAP-OFF)
		  (,COLOR-MAP-OFF ,COLOR-MAP-ON ,COLOR-MAP-OFF)
		  (,COLOR-MAP-OFF ,COLOR-MAP-OFF ,COLOR-MAP-ON)))

(DEFUN R-G-B-COLOR-MAP ()
  "Set color 0 to black, and the remaining colors to alternating red, green, blue."
  (WRITE-COLOR-MAP 0 COLOR-MAP-OFF COLOR-MAP-OFF COLOR-MAP-OFF)
  (DO ((I 1 (1+ I))
       (n (hardware-color-map-dimension)))
      ((= I n))
    (LEXPR-FUNCALL #'WRITE-COLOR-MAP I
		   (NTH (\ I 3) R-G-B))))

(DEFUN CLEAR (&OPTIONAL (SCREEN COLOR-SCREEN))
  "Clear the color screen SCREEN."
  (FUNCALL SCREEN ':CLEAR-SCREEN))

(DEFUN FLOOD (&OPTIONAL (SCREEN COLOR-SCREEN))
  "Fill all of color screen SCREEN with the max color: (1- (hardware-color-map-dimension))"
  (TV:PREPARE-SHEET (SCREEN)
    (%DRAW-RECTANGLE (TV:SHEET-WIDTH SCREEN) (TV:SHEET-HEIGHT SCREEN)
		     0 0 TV:ALU-IOR SCREEN)))

(DEFUN ALL-BARS (&OPTIONAL (WIDTH 16) (SCREEN COLOR-SCREEN))
  "Fill the entire width of SCREEN with red, green and blue bars of width WIDTH."
  (R-G-B-COLOR-MAP)
  (CLEAR SCREEN)
  (LET ((SCREEN-WIDTH (TV:SHEET-WIDTH SCREEN))
        (BARS-WIDTH (* WIDTH 15)))
       (DO ((START 0 (+ START BARS-WIDTH)))
           (( START SCREEN-WIDTH))
           (BARS WIDTH START SCREEN))))

(DEFUN CROSSHATCH (&OPTIONAL (BAR-SIZE 1) (SPACING 16) (SCREEN COLOR-SCREEN))
  "Draw colored crosshatching with lines of width BAR-SIZE and spacing SPACING.
Does not set the color map."
  (CLEAR SCREEN)
  (MULTIPLE-VALUE-BIND (WIDTH HEIGHT) (FUNCALL SCREEN ':SIZE)
    (LET ((NV)(NH)(m (1- (hardware-color-map-dimension screen))))
      (SETQ NV (- (TRUNCATE WIDTH SPACING) (COND ((> (\ WIDTH SPACING) BAR-SIZE) 0)
					   (T 1)))
	    NH (- (TRUNCATE HEIGHT SPACING) (COND ((> (\ HEIGHT SPACING) BAR-SIZE) 0)
					    (T 1))))
      (SETQ WIDTH (+ (* NV SPACING) BAR-SIZE)
	    HEIGHT (+ (* NH SPACING) BAR-SIZE))
      (DO ((X 0 (+ X SPACING))
	   (I 0 (1+ I)))
	  ((> I NV))
	(RECTANGLE X 0 BAR-SIZE HEIGHT (1+ (\ I m))))
      (DO ((Y 0 (+ Y SPACING))
	   (I 0 (1+ I)))
	  ((> I NH))
	(RECTANGLE 0 Y WIDTH BAR-SIZE (1+ (\ I m)))))))

(DEFUN WHITE-CROSSHATCH (&REST ARGS)
  "Draw crosshatching with white lines.  ARGS are passed to CROSSHATCH."
  (WRITE-COLOR-MAP 0 COLOR-MAP-OFF COLOR-MAP-OFF COLOR-MAP-OFF)
  (FILL-COLOR-MAP COLOR-MAP-ON COLOR-MAP-ON COLOR-MAP-ON 1)
  (LEXPR-FUNCALL #'CROSSHATCH ARGS))


(DEFUN TRACK-MOUSE (&OPTIONAL (CURSOR-WIDTH 30) (CURSOR-HEIGHT 5) (COLOR 1))
  "Track the mouse on the color screen."
  (TV:WITH-MOUSE-GRABBED
    (DO ((BOX-X) (BOX-Y)
	 (MAX-X (- (TV:SHEET-WIDTH COLOR-SCREEN) CURSOR-WIDTH))
	 (MAX-Y (- (TV:SHEET-HEIGHT COLOR-SCREEN) CURSOR-HEIGHT)))
	((FUNCALL TERMINAL-IO ':TYI-NO-HANG)
	 (RECTANGLE BOX-X BOX-Y CURSOR-WIDTH CURSOR-HEIGHT COLOR TV:ALU-XOR))
      (WHEN BOX-X
	(TV:MOUSE-INPUT T)
	(RECTANGLE BOX-X BOX-Y CURSOR-WIDTH CURSOR-HEIGHT COLOR TV:ALU-XOR))
      (OR (ZEROP TV:MOUSE-LAST-BUTTONS)
	  (SETQ COLOR TV:MOUSE-LAST-BUTTONS))
      (RECTANGLE (SETQ BOX-X (MIN TV:MOUSE-X MAX-X)) (SETQ BOX-Y (MIN TV:MOUSE-Y MAX-Y))
		 CURSOR-WIDTH CURSOR-HEIGHT
		 COLOR TV:ALU-XOR))))

;; color map hackers.

(DEFUN SPECTRUM-COLOR-MAP (&AUX STEP PI X (max (hardware-color-map-dimension)))
  "Fill the color map with a spectrum."
  (SETQ PI (ATAN 0 -1))
  (SETQ STEP (// PI max))
  (DO ((N 0 (+ 1 N)))
      ((= N max))
    (SETQ X (* N STEP))
    (WRITE-COLOR-MAP N
		     (- color-map-on (FIXR (* (1- (// max 2)) (- 1 (COS (* X .8))))))
		     (- color-map-on (FIXR (* (- max 2) (- 1 (SIN X)))))
		     (- color-map-on (FIXR (* (1- (// max 2)) (+ 1 (COS X)))))))
  (WRITE-COLOR-MAP 0 0 0 0)
  (WRITE-COLOR-MAP (1- max) color-map-on color-map-on color-map-on))


(DEFUN RANDOM-COLOR-MAP (&OPTIONAL (START 1) (SYNCHRONIZE NIL) (SCREEN COLOR-SCREEN))
  "Fill the color map from START through with random colors."
       (DO ((I START (1+ I))
	    (n (HARDWARE-COLOR-MAP-DIMENSION SCREEN)))
	   ((= I n))
           (WRITE-COLOR-MAP I (RANDOM (1+ COLOR-MAP-ON)) (RANDOM (1+ COLOR-MAP-ON))
			    (RANDOM (1+ COLOR-MAP-ON)) SYNCHRONIZE SCREEN)
	   (SETQ SYNCHRONIZE NIL)))


(defun palette (&optional (Screen color-screen) &aux (dim (hardware-color-map-dimension screen)))
  "draws rectangles on the screen, each with a unique color map value"
  (let ((m (fix (sqrt dim))))
    (multiple-value-bind (width height) (send screen :size)
      (let ((rect-width (// width m))
	    (rect-height (// height m)))
	(do ((j 0 (1+ j)))
	    ((= j dim))
	  (rectangle (* (\ j m) rect-width)
		     (* (// j m) rect-height)
		     rect-width
		     rect-height
		     j
		     tv:alu-seta
		     screen))))))

(DEFUN GRAY-COLOR-MAP (&OPTIONAL (BASE 0))
  "Fill the color map with a gray scale; color 0 = BASE,
and the other colors going up in whiteness and wrapping around
so that the max color is just darker than BASE."
  (DO ((I 0 (1+ I))
       (dim (hardware-color-map-dimension))
       (LEVEL))
      ((= I dim))
    (SETQ LEVEL (\ (+ base I) dim))
    (WRITE-COLOR-MAP I LEVEL LEVEL LEVEL)))

(DEFUN COLORIZE (&OPTIONAL (DELAY 4))
  "Set the color map randomly, again and again."
       (DO ()
           ((FUNCALL TERMINAL-IO ':TYI-NO-HANG))
           (PROCESS-ALLOW-SCHEDULE)
           (RANDOM-COLOR-MAP 1 (> DELAY 2))	;IF THE DELAY IS > 2, SYNCHRONIZE WRITES
           (OR (ZEROP DELAY) (PROCESS-SLEEP DELAY))))

(DEFUN GRAY-COLORIZE (&OPTIONAL (DELAY 2))
  "Set the color map to a gray scale but rotate it randomly again and again."
       (DO ()
           ((FUNCALL TERMINAL-IO ':TYI-NO-HANG))
           (PROCESS-ALLOW-SCHEDULE)
           (GRAY-COLOR-MAP (RANDOM 400))
           (OR (ZEROP DELAY) (PROCESS-SLEEP DELAY))))


(DEFUN COLORATE (&OPTIONAL (DELAY 4) (STEPS 1000.))
  "Choose two colors and melt each into the other, repeatedly."
       (DO ()
           ((FUNCALL TERMINAL-IO ':TYI-NO-HANG))
	   (LET ((J (RANDOM 20))
		 (KFOO (RANDOM 17)))
	     (LET ((K (IF (< KFOO J) KFOO (1+ KFOO))))
	       (MULTIPLE-VALUE-BIND (JR JG JB) (READ-COLOR-MAP J)
		 (MULTIPLE-VALUE-BIND (KR KG KB) (READ-COLOR-MAP K)
		   (DO ((I STEPS (1- I))
			(FSTEPS (FLOAT STEPS))
			(FJR (FLOAT JR))
			(FJG (FLOAT JG))
			(FJB (FLOAT JB))
			(FKR (FLOAT KR))
			(FKG (FLOAT KG))
			(FKB (FLOAT KB)))
		       ((< I 0))
		     (LET ((P (// (FLOAT I) FSTEPS))
			   (1-P (// (FLOAT (- STEPS I)) FSTEPS)))
		       (WRITE-COLOR-MAP J
					(FIX (+ (* P FJR) (* 1-P FKR)))
					(FIX (+ (* P FJG) (* 1-P FKG)))
					(FIX (+ (* P FJB) (* 1-P FKB))))
		       (WRITE-COLOR-MAP K
					(FIX (+ (* P FKR) (* 1-P FJR)))
					(FIX (+ (* P FKG) (* 1-P FJG)))
					(FIX (+ (* P FKB) (* 1-P FJB))))))))))
           (OR (ZEROP DELAY) (PROCESS-SLEEP DELAY))))

(DECLARE (SPECIAL :10LEAF))

(DEFUN PUT-UP-PICT (&OPTIONAL (PICT :10LEAF)
                    &AUX MIN MAX HEIGHT WIDTH SC X0 Y0
                         (SCR (TV:SHEET-SCREEN-ARRAY COLOR-SCREEN)))
  (CLEAR)
  (GRAY-COLOR-MAP)
  (SETQ MIN (CDR (ARRAYDIMS PICT)))
  (SETQ HEIGHT (CAR MIN) WIDTH (CADR MIN))
  (SETQ X0 (TRUNCATE (- (TV:SHEET-WIDTH COLOR-SCREEN) WIDTH) 2)
        Y0 (TRUNCATE (- (TV:SHEET-HEIGHT COLOR-SCREEN) HEIGHT) 2))
  (SETQ MIN COLOR-MAP-ON MAX 0)
  (DO I 0 (1+ I) (>= I HEIGHT)
    (DO J 0 (1+ J) (>= J WIDTH)
      (SETQ MIN (MIN MIN (AREF PICT I J)))
      (SETQ MAX (MAX MAX (AREF PICT I J)))))
  (SETQ SC (// (- MAX MIN) 20.0S0))
  (DO I 0 (1+ I) (>= I HEIGHT)
    (DO J 0 (1+ J) (>= J WIDTH)
      (ASET (FIX (// (- (AREF PICT I J) MIN) SC))
            SCR (+ I X0) (+ J Y0)))))


(DEFUN COLOR-DRAW-LINE (X1 Y1 X2 Y2
			&OPTIONAL (COLOR 17) (ALU TV:ALU-SETA) (SCREEN COLOR-SCREEN))
  "Draw a line from X1, Y1 to X2, Y2 in color COLOR."
    (COND ((> X1 X2) (SWAPF X1 X2) (SWAPF Y1 Y2)))
    (TV:PREPARE-SHEET (SCREEN)
      (LET ((DX (- X2 X1))
	    (DY (- Y2 Y1))
	    (PIXEL-ARRAY (TV:SHEET-SCREEN-ARRAY COLOR-SCREEN)))
	(LET ((DIR-Y (IF (MINUSP DY) -1 1))
	      (DY (ABS DY)))
	  (COND ((ZEROP DY) (RECTANGLE X1 Y1 (- X2 X1) 1 COLOR ALU))
		((ZEROP DX) (RECTANGLE X1 (MIN Y1 Y2) 1 (- (MAX Y1 Y2) (MIN Y1 Y2))
				       COLOR ALU))
		((> DX DY)			;X IS LARGER STEP
		 (DO ((X1 X1 (1+ X1))
		      (REM (TRUNCATE DY 2) (+ REM DY)))
		     ((> X1 X2))
		   (IF ( REM DX) (SETQ Y1 (+ Y1 DIR-Y) REM (- REM DX)))
		   (AS-2-REVERSE (BOOLE ALU COLOR (AR-2-REVERSE PIXEL-ARRAY X1 Y1))
				 PIXEL-ARRAY X1 Y1)))
		(T				;Y IS LARGER STEP
		 (DO ((I 0 (1+ I))
		      (Y Y1 (+ Y DIR-Y))
		      (REM (TRUNCATE DX 2) (+ REM DX)))
		     ((> I DY))
		   (IF ( REM DY) (SETQ X1 (1+ X1) REM (- REM DY)))
		   (AS-2-REVERSE (BOOLE ALU COLOR (AR-2-REVERSE PIXEL-ARRAY X1 Y))
				 PIXEL-ARRAY X1 Y))))))))


(DEFUN COLOR-DRAW-CHAR (FONT CHAR X Y &OPTIONAL (COLOR 0) (DEVICE COLOR-SCREEN))
  "Draw character CHAR in font FONT at position X, Y in color COLOR.
FONT is an ordinary black-and-white font.
X and Y are the position of the top left corner of the character."
  (TV:PREPARE-SHEET (DEVICE)
    (%COLOR-DRAW-CHAR FONT CHAR X Y COLOR DEVICE)))

(DEFUN %COLOR-DRAW-CHAR (FONT CHAR X Y COLOR DEVICE)
  (LET ((WIDTH (FONT-RASTER-WIDTH FONT))
	(SCREEN (TV:SHEET-SCREEN-ARRAY DEVICE))
	(HEIGHT (FONT-RASTER-HEIGHT FONT)))
    (DO ((H 0 (1+ H)))
	((> H HEIGHT))
      (DO ((W 0 (1+ W)))
	  ((> W WIDTH))
	(IF (= (FED:FONT-GET-PIXEL FONT CHAR H W) 1)
	    (ASET COLOR SCREEN (+ Y H) (+ X W)))))))

(DEFUN COLOR-PRINC (STRING X Y &OPTIONAL (COLOR 0) (FONT FONTS:CPTFONT)
			   (DEVICE COLOR-SCREEN)
			   &AUX (WIDTH (FONT-CHAR-WIDTH FONT))
			   (WIDTH-TABLE (FONT-CHAR-WIDTH-TABLE FONT)))
  "Output STRING starting at position X, Y in color COLOR using font FONT.
FONT is an ordinary black-and-white font.
X and Y are the position of the top left corner of the first character."
  (DO ((W X (+ W (IF WIDTH-TABLE (AREF WIDTH-TABLE (AREF C I)) WIDTH)))
       (C (FORMAT NIL "~A" STRING))
       (CH)
       (I 0 (1+ I)))
      ((>= I (STRING-LENGTH C)))
    (OR (= (SETQ CH (AREF C I)) #\SPACE)
	(COLOR-DRAW-CHAR FONT (AREF C I) W Y COLOR DEVICE))))