;;; -*- 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
;;;   6/3/92  PAO  Major reorganization!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;****************************************************************************************************
;;; 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)


;;; for CLX
(defvar *clx-display* nil)
(defvar *clx-screen* nil)
(defvar *clx-root* nil)
(defvar *clx-windows* nil)

#+symbolics
(progn
  (compiler:make-obsolete *color-screen* "Use the screen-handler garbage" defvar)
  (compiler:make-obsolete *cs* "Use the screen-handler garbage" defvar)
  (compiler:make-obsolete *color-window* "Use the screen-handler garbage" defvar)
  (compiler:make-obsolete *cw* "Use the screen-handler garbage" defvar)
  (compiler:make-obsolete *color-window-initialized* "Use the screen-handler garbage" defvar)
  (compiler:make-obsolete *clx-display* "Use the screen-handler garbage" defvar)
  (compiler:make-obsolete *clx-screen* "Use the screen-handler garbage" defvar)
  (compiler:make-obsolete *clx-root* "Use the screen-handler garbage" defvar)
  (compiler:make-obsolete *clx-windows* "Use the screen-handler garbage" defvar))

(defvar *spe-color-screen-handler* nil)
(defvar *spe-color-screen-handler-list* nil)

;(clos:defgeneric color-screen-applicable? (handler &rest args))
;(clos:defgeneric init-color-screen-internal (handler &rest args))
;(clos:defgeneric init-color-window-internal (handler))
;(clos:defgeneric reinit-color-screen-internal (handler &rest args))
;(clos:defgeneric uninit-color-screen-internal (handler))
;(clos:defgeneric uninit-color-window-internal (handler))

(clos:defclass basic-handler
	  ()
    ((screen :initarg :screen :accessor screen :initform nil)
     (window :initarg :window :accessor window :initform nil)
     (initialized? :accessor handler-initialized? :initform nil)
     (type :initarg :type :accessor handler-type :initform nil)
     (key :initarg :key :accessor handler-key :initform 0)
     (priority :initarg :priority :accessor handler-priority :initform 0)))

(clos:defmethod uninit-color-window-internal ((handler basic-handler)) nil)
(clos:defmethod uninit-color-screen-internal ((handler basic-handler)) nil)
(clos:defmethod reinit-color-screen-internal ((handler basic-handler) &rest args)
  (declare (ignore args))
  nil)

(clos:defclass basic-color-window () ())

;(clos:defgeneric show-color (window image &rest keys
;				    &key from-x from-y to-x to-y width height enhance? expose?))
;(clos:defgeneric new-color-map (window color-map-name))
;(clos:defgeneric color-map-screen (window))
;(clos:defgeneric expose (window))

(proclaim '(inline color-window color-screen))

(defun COLOR-WINDOW () (or (and *spe-color-screen-handler*
				(window *spe-color-screen-handler*))
			   (init-color-window)))
(defun COLOR-SCREEN () (and *spe-color-screen-handler* (screen *spe-color-screen-handler*)))

(defun REGISTER-SCREEN-HANDLER (handler-class &rest init-args)
  (let ((new (apply #'clos:make-instance handler-class :key (sxhash init-args) init-args)))
    ;; Only add it if it's really new
    (dolist (h *spe-color-screen-handler-list*)
      (when (handler-similar? new h) (return-from register-screen-handler)))
    (push new *spe-color-screen-handler-list*)
    (values)))

(clos:defmethod HANDLER-SIMILAR? ((h1 basic-handler) (h2 basic-handler))
  (and (eq (handler-type h1) (handler-type h2))
       (eq (clos:class-of h1) (clos:class-of h2))
       (= (handler-key h1) (handler-key h2))))

(defun INIT-COLOR-SCREEN (&rest args &key type force &allow-other-keys)
  (if (and *spe-color-screen-handler* (not force))
      (apply #'reinit-color-screen-internal *spe-color-screen-handler* args)
      (progn
	(when (not (null *spe-color-screen-handler*))
	  (uninit-color-screen-internal *spe-color-screen-handler*)
	  (setq *spe-color-screen-handler* nil))
	(loop with best-handler = nil
	      for handler in *spe-color-screen-handler-list*
	      when (and (or (null type) (eq type (handler-type handler)))
			(apply #'color-screen-applicable? handler args))
	      do (when (or (null best-handler)
			   (> (handler-priority handler) (handler-priority best-handler)))
		   (setq best-handler handler))
	      finally
	      (if (null best-handler)
		  (error "No applicable color screen could be found.")
		  (progn
		    (setq *spe-color-screen-handler* best-handler)
		    (apply #'init-color-screen-internal best-handler args)))))))

;;; 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* (init-color-window-internal *spe-color-screen-handler*)
	       *cw* *color-window*)
	 (setf (window *spe-color-screen-handler*) *color-window*)
	 (expose *color-window*)
	 (setq *color-window-initialized* t)
	 (setf (handler-initialized? *spe-color-screen-handler*) t)))
  (window *spe-color-screen-handler*))

(defun KILL-COLOR-WINDOW ()
  (when *spe-color-screen-handler*
    (uninit-color-window-internal *spe-color-screen-handler*)
    (setq *color-window* nil)
    (setq *color-window-initialized* nil)
    (setf (handler-initialized? *spe-color-screen-handler*) nil)))

;;;****************************************************************************************************
;;; color map

;;; macro that defines functions to alter the color map
;;; Recast to work on a window instead of a screen.


(clos:defmethod color-map-screen ((window basic-color-window)) window)


(defmacro DEFUN-COLOR-MAP-FUNCTION (map-name)
  (let ((color-map-symbol (find-symbol (string map-name) 'keyword)))
    `(defun ,map-name (&optional (spe-window (color-window)))
       (new-color-map spe-window
		      (cmv:color-map-named ',color-map-symbol :screen (color-map-screen spe-window))))))

;;; 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

(cmv:def-color-map :special-grey-and-inverse-spectral-map :copy :grey-and-inverse-spectral-map)
(cmv:def-color-map :special-grey-and-spectral-map 	  :copy :grey-and-spectral-map)
(cmv:def-color-map :special-inverse-spectral-map 	  :copy :inverse-spectral-map)
(cmv:def-color-map :special-spectral-map		  :copy :spectral-map)

(defun SPECTRAL-MAP (&key (window (color-window)) 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* ((screen (color-map-screen window))
	 (map-name (if and-grey
		       (if invert-spectrum :special-grey-and-inverse-spectral-map :special-grey-and-spectral-map)
		       (if invert-spectrum :special-inverse-spectral-map :special-spectral-map)))
	 (spectral-map
	   (cmv:color-map-named map-name :screen screen :reinitialize t)))

    (cmv::initialize-color-map-internal
      screen spectral-map 0
      #'(lambda (screen map slot-setter)
	  (declare (ignore screen))
	  (if black (funcall slot-setter map black 0 0 0))
	  (if white (funcall slot-setter map
			     white *max-color-value* *max-color-value* *max-color-value*)))
      nil)
    (new-color-map window spectral-map)))

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

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

(defun GREY-AND-INVERSE-SPECTRAL-MAP (&key (window (color-window)) black white)
  (spectral-map :window window :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))
(cmv:def-color-map :BLUE-AND-RED-MAP
		    :slot (lambda (slot)
			    (values
			      (ash (ldb (byte *half-slot-bits* *half-slot-bits*) slot)
				   (- *color-value-bits* *half-slot-bits*))
			      0
			      (ash (ldb (byte *half-slot-bits* 0) slot)
				   (- *color-value-bits* *half-slot-bits*)))))

(cmv:def-color-map :special :slot (lambda (x) (values 0 0 0)))

;;; Set up a linear color map with bit 0 reserved for an overlay.
(defun OVERLAY-MAP
       (&key (window (color-window))
	(red *overlay-red*) (green *overlay-green*) (blue *overlay-blue*))
  (let* ((screen (color-map-screen window))
	 (overlay-map (cmv::find-or-make-color-map screen :special nil t)))
    (cmv::initialize-color-map-internal
      screen overlay-map 0 :slot
      #'(lambda (slot)
	  (if (evenp slot)
	      (let ((color-value (ash slot (- *color-value-bits* *color-slot-bits*))))
		(values color-value color-value color-value))
	      (values red green blue))))
    (new-color-map window overlay-map)))