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

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

(clos:defclass clx-handler (basic-handler)
    ((clx-screen :initarg :clx-screen :accessor clx-screen :initform nil)))

(clos:defmethod color-screen-applicable? ((handler clx-handler) &rest args &key type &allow-other-keys)
  (declare (ignore args))
  ;; We're always applicable, except if we're on a Symbolics on the main
  ;; screen.  This isn't the best approach, since we could have *terminal-io* on the
  ;; main screen, but still want the window on some X display.  I guess we should
  ;; look at the type.  If they want to force it on the X display, they'll specify
  ;; the type.
  #+symbolics
  (or (eq type :clx)
      (not (typep (scl:send *terminal-io* :screen) 'tv:main-screen)))
  #-symbolics t)


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

(clos:defmethod init-color-screen-internal ((handler clx-handler) &key display &allow-other-keys)
  (multiple-value-bind (host display screen)
      (parse-display-string (or display #+lucid (lcl:environment-variable "DISPLAY")))
    (let* ((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"
		clx-screen clx-display)
	(setq clx-screen (first (xlib:display-roots clx-display))))
      (let* ((depths (xlib:screen-depths clx-screen))
	     (8-bit (assoc 8 depths :test #'=)))
	(unless (and 8-bit (cdr 8-bit))
	  (error "Requested screen does not support 8-bit windows.  I must have 8-bit windows.")))
      
      (setf (clx-screen handler) clx-screen)
      (setf (screen handler) 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)))))))


(clos:defmethod init-color-window-internal ((handler clx-handler))
  (let ((x-window
	  (xlib:create-window :parent (xlib:screen-root (clx-screen handler))
			      :x 0 :y 0 :width 512 :height 512
			      :background 0)))
    (clos:make-instance 'clx-color-window :window x-window)))

(clos:defmethod uninit-color-window-internal ((handler clx-handler))
  (kill-window (window handler)))

(clos:defmethod clos:initialize-instance :after
  ((win clx-color-window) &rest initargs)
  (declare (ignore initargs))
  (let* ((x-window (color-window-window win))
	 (vis-info (xlib:window-visual-info x-window))
	 (cmap (xlib:create-colormap vis-info x-window t)))
    (setf (color-window-cmap win)   cmap
	  (color-window-gcontext win)
	  (xlib:create-gcontext :drawable x-window))))

(clos:defmethod expose ((win clx-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 clx-color-window))
  (xlib:destroy-window (color-window-window win)))

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

(clos:defmethod clear-window ((win clx-color-window))
  nil)

;;;****************************************************************************************************
;;; image display

(clos:defmethod show-color ((self clx-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? (expose 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 (color-window-window 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.

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

(clos:defmethod new-color-map ((window clx-color-window) map)
  (setf (xlib:window-colormap (color-window-window window)) map)
  (cw-force window))

(clos:defmethod SHOW-PALETTE ((window clx-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))))))

(register-screen-handler 'clx-handler)