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

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

(in-package :spectral :nicknames '(:spe) :use '(lisp))

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

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


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

(clos:defclass COLOR-WINDOW
	()
	((window :initform nil :accessor color-window-window)
	 (cmap :initform nil :accessor color-window-cmap)
	 (gcontext :initform nil :accessor color-window-gcontext)
	 (omaps :initform nil :accessor color-window-omaps)))

(clos:defmethod clos:initialize-instance  ((win color-window) &rest initargs)
  (declare (ignore initargs))
  (let* ((x-window (xlib:create-window :parent *clx-root*
				       :x 0 :y 0 :width 512 :height 512
				       :background 0
				       ))
	 (vis-info (xlib:window-visual-info x-window))
	 (cmap (xlib:create-colormap vis-info x-window t)))
    (setf (color-window-window win) x-window
	  (color-window-cmap win)   cmap
	  (color-window-gcontext win)
	  (xlib:create-gcontext :drawable x-window))
    (push win *clx-windows*)))

(clos:defmethod map-window ((win color-window))
  (xlib:map-window (color-window-window win))
  (xlib:display-force-output (xlib:drawable-display (color-window-window win))))

(clos:defmethod kill-window ((win color-window))
  (xlib:destroy-window (color-window-window win))
  (setq *clx-windows* (remove win *clx-windows*)))

(clos:defmethod cw-force ((win color-window))
  (xlib:display-force-output (xlib:drawable-display (color-window-window win))))

(clos:defmethod clear-window ((win color-window))
  nil)

;;;****************************************************************************************************
;;; initialization

(defun shutdown-clx-display ()
  (when *clx-display* (xlib:close-display *clx-display*))
  (setq *clx-display* nil
	*clx-screen* nil
	*clx-root* nil
	*clx-windows* nil))

(defun INIT-COLOR-SCREEN (&key force display)
  (when *clx-display*
    (if force
	(shutdown-clx-display)
	(return-from init-color-screen)))
  ;; Figure out what host.
  (multiple-value-bind (host display screen)
      (parse-display-string (or display #+lucid (lcl:environment-variable "DISPLAY")))
    (setq *clx-display* (xlib:open-display host :display display)
	  *clx-screen*  (nth screen (xlib:display-roots *clx-display*)))
    (when (null *clx-screen*)
      (cerror "Use screen 0"
	      "Requested screen does not exist on the display: Screen ~S on ~S"
	      screen *clx-display*)
      (setq *clx-screen* (first (xlib:display-roots *clx-display*))))
    (setq *clx-root* (xlib:screen-root *clx-screen*)
	  *cs* *clx-display*)))

(defun parse-display-string (display-string)
  (let* ((colon (position #\: display-string :test #'char=))
	 (dot   (position #\. display-string :start (if colon (+ colon
								 1) 0)
			  :test #'char=)))
    ;; If no colon, it's probably mal-formed, but we'll assume it's a
    ;; host name and they want display 0, screen 0
    (cond ((null colon) (values display-string 0 0))
	  ((null dot)
	   (values (subseq display-string 0 colon)
		   (parse-integer display-string :start (+ colon 1))
		   0))
	  (t
	   (values (subseq display-string 0 colon)
		   (parse-integer display-string :start (+ colon 1) :end dot)
		   (parse-integer display-string :start (+ dot 1)))))))



;;; 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* (clos:make-instance 'color-window)
	       *cw* *color-window*)
	 (map-window *color-window*)
	 (setq *color-window-initialized* t)))
  )

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

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

(clos:defmethod show-color ((self color-window) image
			    &key
			    (from-x 0) (from-y 0) (to-x 0) (to-y 0)
			    width height
			    ;; 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:array-element-size image)))
  "Display a raster on the color window.  Should be generalized to handle pvars."

  (multiple-value-bind (iwidth iheight)
      (vu:decode-raster-array image)
    (unless width (setq width iwidth))
    (unless height (setq height iheight)))

  (when expose? (map-window self))		;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))

  (flet ((doit (image)
	   (xlib:put-raw-image (color-window-window self)
			       (color-window-gcontext self)
			       (make-array (array-total-size image)
					   :element-type (array-element-type image)
					   :displaced-to image)
			       :depth bits :width width :height height
			       :x to-x :y to-y
			       :left-pad from-x
			       :start (array-row-major-index image from-x from-y)
			       :format (if (eql bits 1) :bitmap :z-pixmap))
	   (xlib:display-force-output (xlib:drawable-display self))))
    (cond ((or (eql bits 1)
	       (and (eql bits 8) (not enhance?)))	;use eql because bits is NIL for art-q arrays
	   (doit image))
	  (t (let ((display-raster (vu:make-raster-array width height
							 :element-type `(unsigned-byte ,*color-slot-bits*))))
	       (vu:enhance-array image :result display-raster)
	       (doit display-raster))))))


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

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

(defmacro DEFUN-COLOR-MAP-FUNCTION (map-name)
  (let ((color-map-symbol (find-symbol (string map-name) 'keyword)))
    `(defun ,map-name (&optional (spe-window spe:*color-window*))
      (let ((x-window (color-window-window spe-window)))
	(setf (xlib:window-colormap x-window)
	      (cmv:color-map-named ,color-map-symbol :screen x-window))
	(cw-force 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 (spe-window spe:*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* ((window (color-window-window spe-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 window :reinitialize t)))

    (when black (cmv::clx-set-map-slot spectral-map black 0.0 0.0 0.0))
    (when white (cmv::clx-set-map-slot spectral-map white
				       *max-color-value*
				       *max-color-value*
				       *max-color-value*))
    (setf (xlib:window-colormap window) spectral-map)
    (cw-force spe-window)))



(defun INVERSE-SPECTRAL-MAP (&key (window spe:*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 spe:*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 spe:*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*)))))

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

(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 (spe-window spe:*color-window*)
	(red *overlay-red*) (green *overlay-green*) (blue *overlay-blue*))
  (let* ((window (color-window-window spe-window))
	 (overlay-map (cmv::find-or-make-color-map window :special nil t)))
    (cmv::initialize-color-map-internal
      window 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))))
    (setf (xlib:window-colormap window) overlay-map)))

(clos:defmethod SHOW-PALETTE ((window COLOR-WINDOW) &key (expose? t))
  (let* ((color-sqrt (sqrt *color-slots*))
	 (x-window (color-window-window window))
	 (window-width (xlib:drawable-width x-window))
	 (window-height (xlib:drawable-height x-window))
	 (rect-width (/ window-width color-sqrt))
	 (rect-height (/ window-height color-sqrt))
	 (gc (xlib:create-gcontext :drawable x-window)))
    (when expose? (xlib:map-window x-window))
    (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)))
	  (setf (xlib:gcontext-foreground gc) (+ (* y color-sqrt) x))
	  (xlib:draw-rectangle x-window gc x-round y-round rect-width-round rect-height-round t))))))