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

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

(scl:defflavor COLOR-WINDOW-FLAVOR
	()
	(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
   ))
   
(clos:defclass lxb-color-window (basic-color-window) ((sheet :initarg :sheet :accessor sheet)))

(clos:defclass lxb-handler (basic-handler) ())

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

(clos:defmethod COLOR-SCREEN-APPLICABLE? ((handler lxb-handler) &rest args)
  (declare (ignore args))
  (and (color:color-exists-p)
       (sct:get-system-version "LXB Color")))

(compiler:function-defined 'color:find-color-screen)

(clos:defmethod INIT-COLOR-SCREEN-INTERNAL ((handler lxb-handler) &rest args)
  (declare (ignore args))
  (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*)
  (setf (screen handler) *color-screen*)
  ;; Should this really be here?  --- PAO 6/03/92 16:47:54
  (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.

(clos:defmethod INIT-COLOR-WINDOW-INTERNAL ((handler lxb-handler))
  (let* ((sheet (scl:make-instance 'color-window-flavor))
	 (obj   (clos:make-instance 'color-window-lxb :sheet sheet)))
    obj))

(clos:defmethod UNINIT-COLOR-WINDOW-INTERNAL ((handler lxb-handler))
  (scl:send *color-window* :kill)) 

(clos:defmethod expose ((window lxb-color-window))
  (scl:send (sheet window) :expose))

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

;;; Pieces of this should be abstracted out somehow.
;;; A lot of this code is identical to the code in color-clx.lisp.

(clos:defmethod show-color ((window lxb-color-window) image &rest keys &key &allow-other-keys)
  (apply #'show-color-lxb-internal (sheet window) image keys))

(scl:defmethod (SHOW-COLOR-LXB-INTERNAL COLOR-WINDOW-FLAVOR)
	   (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? (scl:send scl: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
	 (scl:send scl: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
		 (scl: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 scl:self :alu :erase)
	   (scl:send scl:self :bitblt copy-bits-alu width height image from-x from-y to-x to-y)))
	(t (let ((display-raster (vu:make-raster-array width height
						       :element-type `(unsigned-byte ,*color-slot-bits*))))
	     (vu:enhance-array image :result display-raster)
	     (scl:send scl:self :bitblt tv:alu-seta width height display-raster from-x from-y to-x to-y)))))


(clos:defmethod color-map-screen ((window lxb-color-window))
  (scl:send (sheet window) :screen))

(clos:defmethod new-color-map ((window lxb-color-window) map)
  (scl:send (scl:send (sheet window) :screen) :new-color-map map))

(clos:defmethod show-palette ((window lxb-color-window) &key (expose? t))
  (show-palette-internal (sheet window) :expose? expose?))

(scl:defmethod (SHOW-PALETTE-INTERNAL COLOR-WINDOW-FLAVOR) (&key (expose? t))
  (when expose? (scl:send scl:self :expose))
  (let* ((color-sqrt (sqrt *color-slots*))
	 (window-width (scl:send scl:self :width))
	 (window-height (scl:send scl: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
	(scl: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)))
	  (scl:send scl:self :draw-rectangle rect-width-round rect-height-round x-round y-round color-alu))))))

(register-screen-handler 'lxb-handler)