;;; -*- Mode: Lisp; Syntax: Common-lisp; Package: SPECTRAL; Base: 10.; -*-

;;; Copyright (c) 1988, Massachusetts Institute of Technology
;;; Author: Walter E. Gillett

(in-package :spectral)

;;; Functions to make simple use of the color display more convenient.  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Change History
;;;
;;;   3/1/88  WEG  created this file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;****************************************************************************************************
;;; constants

(defconstant *COLOR-SLOT-BITS* 8)			;bits to represent a slot in the color map
(defconstant *COLOR-SLOTS* (expt 2 *color-slot-bits*))	;slots in color map

(defconstant *COLOR-VALUE-BITS* 10)			;bits for color value
(defconstant *COLOR-VALUES* (expt 2 *color-value-bits*))	;number of color values
(defconstant *MAX-COLOR-VALUE* (1- *color-values*))

;;;****************************************************************************************************
;;; parameters

(defvar *OVERLAY-RED* *max-color-value*)	;default overlay color is red
(defvar *OVERLAY-GREEN* 0) 
(defvar *OVERLAY-BLUE* 0) 

;;;****************************************************************************************************
;;; globals

(defvar *COLOR-SCREEN* nil)			;screen associated with color monitor
(defvar *CS* nil)				;alias for *color-screen*

(defvar *COLOR-WINDOW* nil)			;window associated with color monitor
(defvar *CW*)					;alias for *color-window*
(defvar *COLOR-WINDOW-INITIALIZED* nil)

;;;****************************************************************************************************
;;; flavors

(defflavor COLOR-WINDOW
	()
	(tv:window)
  (:default-init-plist
   :superior (color:find-color-screen)
   :screen (color:find-color-screen)
   :label nil
   :borders nil
   :blinker-p nil
   :more-p nil
   :save-bits nil
   ))
   
;;;****************************************************************************************************
;;; initialization

(defun INIT-COLOR-SCREEN ()
  (if (not (color:color-exists-p)) (error "Cannot initialize color screen because there is no color hardware."))
  (setq *color-screen* (color:find-color-screen :create-p t)
	*cs* *color-screen*)
  (spe:linear-map *color-screen*))

;;; By default, the color window is only initialized if parameter *color-window-initialized* is nil.
;;; To force initialization, set "always" to t.
(defun INIT-COLOR-WINDOW (&key always)
  (cond ((or (not *color-window-initialized*) always)
	 (init-color-screen)
	 (setq *color-window* (make-instance 'color-window)
	       *cw* *color-window*)
	 (send *color-window* :expose)
	 (setq *color-window-initialized* t))))

(defun KILL-COLOR-WINDOW ()
  (send *color-window* :kill)
  (setq *color-window* nil)
  (setq *color-window-initialized* nil)) 

;;;****************************************************************************************************
;;; image display

(defmethod (SHOW-COLOR COLOR-WINDOW)
	   (image &key
		  (from-x 0) (from-y 0) (to-x 0) (to-y 0)
		  (width (vu::width image)) (height (vu::height image))
		  ;; By default, enhance the image if it is not 8-bit.  For an 8-bit image, the user
		  ;; must explicitly request enhancement if desired.
		  (enhance? t enhance-specified?)
		  (expose? t)
		  &aux (bits (vu:bits-per-element image)))
  "Display a raster on the color window.  Should be generalized to handle pvars."
  (when expose? (zl:send self :expose))				;make sure that window is exposed
  ;; Enhance an 8-bit image only if requested explicitly to do so.
  (if (and (eql bits 8) (not enhance-specified?)) (setq enhance? nil))
  (cond ((and (eql bits 8) (not enhance?))		;use eql because bits is NIL for art-q arrays
	 (zl:send self :bitblt tv:alu-seta width height image from-x from-y to-x to-y))
	((eql bits 1)
	 ;; snarfed from PAO's grey documentation
	 (let ((copy-bits-alu
		 (make-instance 'color:general-sc-color-alu :array :masked-bits
				:fill-data -1 :plane-mask -1 :alu color:alu-x)))
	   (graphics:draw-rectangle to-x to-y (+ to-x width) (+ to-y height) :stream self :alu :erase)
	   (zl:send self :bitblt copy-bits-alu width height image from-x from-y to-x to-y)))
	(t (let ((display-raster (make-raster-array width height
						    :element-type `(unsigned-byte ,*color-slot-bits*))))
	     (vu:enhance-array image :result display-raster)
	     (zl:send self :bitblt tv:alu-seta width height display-raster from-x from-y to-x to-y)))))

;;;****************************************************************************************************
;;; color map

;;; macro that defines functions to alter the color map
(defmacro DEFUN-COLOR-MAP-FUNCTION (map-name)
  (let ((color-map-symbol (find-symbol (string map-name) 'keyword)))
    `(defun ,map-name (&optional (screen spe:*color-screen*))
       (send screen :new-color-map (grey:color-map-named ,color-map-symbol :screen screen)))))

;;; Define functions to simplify use of the color maps provided by lxb-color.  We define the spectral
;;; and grey/spectral functions ourselves in order to provide black/white options.
(defun-color-map-function intensity-map-with-colors)
(defun-color-map-function spectral-map-with-colors)
(defun-color-map-function intensity-map)
(defun-color-map-function linear-map)
(defun-color-map-function blue-and-red-map)	;defined below

(defun SPECTRAL-MAP (&key (screen spe:*color-screen*) invert-spectrum and-grey black white)
  "Set up a spectral color map.  If invert-spectrum is t, run the spectrum from blue to red rather
than from red to blue.  If and-grey is t, build a map with alternating grey scale and spectral
slots.  The keywords black and white specify color slots to be set to black and white,
respectively.  By default black and white colors are not provided."
  (let ((spectral-map (send screen :make-color-map-image)))
    (cond (and-grey				;mixed grey
	   ;; This color map will soon be renamed to :grey-and-inverse-spectral-map, a better choice.
	   (if invert-spectrum
	       (scl:copy-array-contents (grey:color-map-named :grey-and-inverse-spectral-map) spectral-map)
	       (scl:copy-array-contents (grey:color-map-named :grey-and-spectral-map) spectral-map)))
	  (t (if invert-spectrum
		 (scl:copy-array-contents (grey:color-map-named :inverse-spectral-map) spectral-map)
		 (scl:copy-array-contents (grey:color-map-named :spectral-map) spectral-map))))
    (if black (send screen :write-color-map-image black 0 0 0 0 spectral-map))
    (if white (send screen :write-color-map-image
		    white *max-color-value* *max-color-value* *max-color-value* 0 spectral-map))
    (send screen :new-color-map spectral-map)))

(defun INVERSE-SPECTRAL-MAP (&key (screen spe:*color-screen*) black white)
  (spectral-map :screen screen :invert-spectrum t :and-grey nil :black black :white white))

(defun GREY-AND-SPECTRAL-MAP (&key (screen spe:*color-screen*) black white)
  (spectral-map :screen screen :invert-spectrum nil :and-grey t :black black :white white))

(defun GREY-AND-INVERSE-SPECTRAL-MAP (&key (screen spe:*color-screen*) black white)
  (spectral-map :screen screen :invert-spectrum t :and-grey t :black black :white white))

;;; Create a color map in which the upper 4 bits of the color value become a 4-bit red component
;;; and the lower 4 bits of the color value become a 4-bit blue component.  This is useful for
;;; displaying stereo anaglyphs.
(defvar *HALF-SLOT-BITS* (floor *color-slot-bits* 2))
(grey:def-color-map :BLUE-AND-RED-MAP
		    :slot (lambda (slot)
			    (values
			      (ash (load-byte slot *half-slot-bits* *half-slot-bits*)
				   (- *color-value-bits* *half-slot-bits*))
			      0
			      (ash (load-byte slot 0 *half-slot-bits*)
				   (- *color-value-bits* *half-slot-bits*))
			      )))

;;; *** obsolete ***
;(defun OVERLAY-COLOR (&optional (red *overlay-red*) (green *overlay-green*) (blue *overlay-blue*))
;  "Set the default overlay color for an overlay color map.  For user convenience, color values
;are read in the range 0 to 255 and scaled to the range 0 to 1023 for the Symbolics color system."
;  (setq *overlay-red* (ash red (- *color-value-bits* *color-slot-bits*))
;	*overlay-green* (ash green (- *color-value-bits* *color-slot-bits*))
;	*overlay-blue* (ash blue (- *color-value-bits* *color-slot-bits*))))

;;; Set up a linear color map with bit 0 reserved for an overlay.
(defun OVERLAY-MAP
       (&key (screen spe:*color-screen*)
	(red *overlay-red*) (green *overlay-green*) (blue *overlay-blue*))
  (let ((overlay-map (send screen :make-color-map-image)))
    ;; initialize the map
    (dotimes (slot *color-slots*)
      (if (evenp slot)
	  (let ((color-value (ash slot (- *color-value-bits* *color-slot-bits*))))
	    (send screen :write-color-map-image slot color-value color-value color-value 0 overlay-map))
	  (send screen :write-color-map-image slot red green blue 0 overlay-map)))
    ;; use the map
    (send screen :new-color-map overlay-map)))

(defmethod (SHOW-PALETTE COLOR-WINDOW) (&key (expose? t))
  (when expose? (send self :expose))
  (let* ((color-sqrt (sqrt *color-slots*))
	 (window-width (send self :width))
	 (window-height (send self :height))
	 (rect-width (/ window-width color-sqrt))
	 (rect-height (/ window-height color-sqrt))
	 (color-alu (color:sc-fill-alu 0 -1)))
    (loop for x from 0 below color-sqrt do
      (loop for y from 0 below color-sqrt do
	(send color-alu :set-fill-data (+ (* y color-sqrt) x))
	(let* ((x-float (* x rect-width))
	       (y-float (* y rect-height))
	       (x-round (round x-float))
	       (y-round (round y-float))
	       (rect-width-round (- (round (+ x-float rect-width)) x-round))
	       (rect-height-round (- (round (+ y-float rect-height)) y-round)))
	  (send self :draw-rectangle rect-width-round rect-height-round x-round y-round color-alu))))))