#| -*- Mode:LISP; Base: 10;
       Package:(VISTA-LIBRARY :use (LISP));
       Syntax: Common-lisp; Readtable: CL; -*- 

|#

;;; Copyright (C) Lisp Machine, Inc. 1984, 1985, 1986
;;;   See filename "Copyright" for
;;; licensing and release information.

(in-package 'vista-library :use '(lisp))

;;; This is in case the IRIS system has not been loaded.
;;; Normally it is loaded before this file
(eval-when (compile load)
  (unless (find-package 'iris)
    (make-package 'iris)))

;;;; The definition of the Iris device
;;;  and the implementation of the Vista Library for it

;;; 06/17/86 PW     FINISH now waits for the read and write buffers to empty
;;; 06/17/86 PW     Added waiting for sole ownership of iris to mouse stuff
;;; 09/02/86 PECANN Implemented blank-video-while-drawing.
;;; 10/06/86 PECANN (export '(iris))
;;; 10/07/86 EFH    added "Use Iris" demo
;;; 10/09/86 PECANN GET-ASPECT-RATIO -> SCREEN-ASPECT-RATIO, CLEAR-VIEWPORT -> FILL-VIEWPORT, added COLOR-MAP-SIZE
;;; 10/13/86 PECANN removed export, ? -> -p
;;; 10/14/86 PECANN <single-word>-p -> <single-word>p
;;; 10/15/86 EFH    iris:blankscreen takes t or nil in BLANK-VIDEO
;;; 10/15/86 PECANN in mouseing, 771 replaced with (tv:sheet-height mouse-sheet)
;;; 10/16/86 PECANN translation of lispm mouse to iris done right
;;; 10/17/86 PECANN -poly gone, nD-POLY -> nD-ABSOLUTE
;;; 10/19/86 PECANN rotatable-p -> rotatablep

(defvice IRIS
  "Silicon Graphics Inc Integrated Raster Imaging System."
  (segment-id-counter 1)   ;reserve 0 for null segment for mapw
  (segment-id-freelist nil)
  (open-segment nil)
  (cursor-visibility nil)
  (mouse-buffer (tv:make-io-buffer 3))
  (last-mouse-click (make-mouse-click))
  (blank-video-while-drawing-p nil))


(zl:defconst *iris-stealing-mouse* nil)
(zl:defconst *iris-no-mouse-button-p* nil)
(zl:defconst *iris-mouse-process* nil)
(zl:defconst *iris-lock* nil)

(zl:defconst *iris-screen-max-x* 1023)
(zl:defconst *iris-screen-max-y* 767)

(defvar *lm-max-y* 1)
(defvar *inv-lm-max-y* 0)
(defvar *inv-lm-max-x* 0)

(defmacro wait-for-iris ()
  '(zl:process-wait "IRIS sync wait" #'(lambda () (and (= (iris:read-head) (iris:read-tail))
							 (= (iris:write-head) (iris:write-tail))))))

(defvicefun (INIT IRIS) (&rest args)
  (declare (ignore args))
  (if (not *iris-mouse-process*)
      (setq *iris-mouse-process*
	    (zl:process-run-function
	      "iris-mouse"
	      #'(lambda ()
		  (zl:do-forever
		    (setq *iris-stealing-mouse* nil)
		    (zl:process-wait "IRIS mouse idle" #'(lambda () *iris-stealing-mouse*))
		    (setq *lm-max-y* (1- (tv:sheet-height tv:mouse-sheet))
			  *inv-lm-max-y* (/ *lm-max-y*)	;* will be faster than / later
			  *inv-lm-max-x* (/ (1- (tv:sheet-width tv:mouse-sheet))))
		    (tv:with-mouse-usurped
		      (setq tv:who-line-mouse-grabbed-documentation
			    (format nil
			      "Mouse stolen by IRIS.  ~
                               In emergency (setq vl:*iris-stealing-mouse* nil) ~
                               to restore mouse to normal."))
		      (do () ((zerop (tv:mouse-buttons))))
		      (do ()
			  ((zl:neq *iris-stealing-mouse* *current-display-device*))
			(multiple-value-bind (b ignore x y) (tv:mouse-buttons)
			  (let ((x (* x *inv-lm-max-x* *iris-screen-max-x*))
				(y (* (- *lm-max-y* y) *inv-lm-max-y* *iris-screen-max-y*)))
			    (if (iris-cursor-visibility *current-display-device*)  ;prevent interference with stuff in DRAWING
				(zl:with-lock (*iris-lock*)
				  (iris:setvaluator 266 x x x)
				  (iris:setvaluator 267 y y y)))
			    (when (and *iris-no-mouse-button-p* (not (zerop b)))
			      (if (not
				    (zl:without-interrupts
				      (and (typep vl:*current-display-device* 'iris)
					   (tv:io-buffer-put (iris-mouse-buffer *current-display-device*)
							     (make-mouse-click :buttons b :x x :y y)
							     t))))
				  (tv:beep)))
			    (setq *iris-no-mouse-button-p* (zerop b))))
			(zl:process-allow-schedule)))))))))

;----------------------------------------------------------------

;;; The implementation of the Vista Library for the Iris


(defvicefun (INITIALIZE-DEVICE IRIS) ()
  (iris:initialize-device)
  (setf (iris-open-segment) nil
	(iris-cursor-visibility) nil)
  (iris:makeobj 0) ;null segment for mapw
  (iris:closeobj)
  )

(defvicefun (DEVICE-INFORMATION IRIS) ()
  nil)

(defvicefun (FINISH IRIS) ()
  (wait-for-iris)
  (iris:getcolor)) ;;; iris:finish doesn't work!


;---------------- Cursor ----------------

(defvicefun (SET-CURSOR-VISIBILITY IRIS) (predicate)
  (setf (iris-cursor-visibility) predicate)
  (if predicate
      (iris:curson)
    (iris:cursoff)))

(defvicefun (GET-CURSOR-VISIBILITY IRIS) ()
  (iris-cursor-visibility))


;-------------------- Color --------------------


(defvicefun (SET-COLOR IRIS) (color-map-index)
  (iris:color color-map-index)
  )

(defvicefun (GET-COLOR  IRIS) ()
  (iris:getcolor)
  )

(defvicefun (SET-MAP-COLOR IRIS) (index red green blue)
  (iris:mapcolor index (round (* 255 red)) (round (* 255 green)) (round (* 255 blue)))
  )

(defvicefun (GET-MAP-COLOR IRIS) (index)
  (declare (values red green blue))
  (multiple-value-bind (r g b) (iris:getmcolor index)
    (values (/ r 255.0) (/ g 255.0) (/ b 255.0))))

(defvicefun (COLOR-MAP-SIZE IRIS) ()
  (values (expt 2 (iris:getplanes)) 4096))


;----------------- Points ---------------------


(defvicefun (POINT3 IRIS) (x y z)
  (if (and
	(integerp x)
	(integerp y)
	(integerp z)
	)
      (iris:pnti x y z)
    (iris:pnt x y z)
    )
  )
  

(defvicefun (POINT2 IRIS) (x y)
  (if (and
	(integerp x)
	(integerp y)
	)
      (iris:pnt2i x y)
    (iris:pnt2 x y)
    )
  )

;---------------- Lines ----------------



(defvicefun (GET-GRAPHICS-POS IRIS) ()
  (iris:getgpos))

(defvicefun (LINE3 IRIS) (x y z)
  (if (and (integerp x)
	   (integerp y)
	   (integerp z))
      (iris:drawi x y z)
    (iris:draw x y z)))

(defvicefun (LINE2 IRIS) (x y)
  (if (and (integerp x)
	   (integerp y))
      (iris:draw2i x y)
    (iris:draw2 x y)))

(defvicefun (LINE-RELATIVE3 IRIS) (dx dy dz)
  (if (and (integerp dx)
	   (integerp dy)
	   (integerp dz))
      (iris:rdri dx dy dz)
    (iris:rdr dx dy dz)))

(defvicefun (LINE-RELATIVE2 IRIS) (dx dy)
  (if (and (integerp dx)
	   (integerp dy))
      (iris:rdr2i dx dy)
    (iris:rdr2 dx dy)))

(defvicefun (STROKE IRIS) (x y)
  (declare (ignore x y))
  (print "STROKE is not implemented for the IRIS."))

(defvicefun (MOVE3 IRIS) (x y z)
  (if (and (integerp x)
	   (integerp y)
	   (integerp z))
      (iris:movei x y z)
    (iris:move x y z)))

(defvicefun (MOVE2 IRIS) (x y)
  (if (and (integerp x)
	   (integerp y))
      (iris:move2i x y)
    (iris:move2 x y)))

(defvicefun (MOVE-RELATIVE3 IRIS) (dx dy dz)
  (if (and (integerp dx)
	   (integerp dy)
	   (integerp dz))
      (iris:rmvi dx dy dz)
    (iris:rmv dx dy dz)))

(defvicefun (MOVE-RELATIVE2 IRIS) (dx dy)
  (if (and (integerp dx)
	   (integerp dy))
      (iris:rmv2i dx dy)
    (iris:rmv2 dx dy)))


;---------------- Rectangles ----------------


(defvicefun (RECTANGLE IRIS) (x1 y1 x2 y2)
  (if (and (integerp x1)
	   (integerp y1)
	   (integerp x2)
	   (integerp y2))
      (iris:recti x1 y1 x2 y2)
    (iris:rect x1 y1 x2 y2)))

(defvicefun (FILL-RECTANGLE IRIS) (x1 y1 x2 y2)
  (if (and (integerp x1)
	   (integerp y1)
	   (integerp x2)
	   (integerp y2))
      (iris:rectfi x1 y1 x2 y2)
    (iris:rectf x1 y1 x2 y2)))


;---------------- ARCS AND CIRCLES ----------------


(defvicefun (ARC IRIS) (x y radius start-angle end-angle)
  (if (and (integerp x)
	   (integerp y)
	   (integerp radius))
      (iris:arci x y radius (* 10 start-angle) (* 10 end-angle))
    (iris:arc x y radius (* 10 start-angle) (* 10 end-angle))))

(defvicefun (FILL-ARC IRIS) (x y radius start-angle end-angle)
  (if (and (integerp x)
	   (integerp y)
	   (integerp radius))
      (iris:arcfi x y radius (* 10 start-angle) (* 10 end-angle))
    (iris:arcf x y radius (* 10 start-angle) (* 10 end-angle))))

(defvicefun (CIRCLE IRIS) (x y radius)
  (if (and (integerp x)
	   (integerp y)
	   (integerp radius))
      (iris:circi x y radius)
    (iris:circ x y radius)))

(defvicefun (FILL-CIRCLE IRIS) (x y radius)
  (if (and (integerp x)
	   (integerp y)
	   (integerp radius))
      (iris:circfi x y radius)
    (iris:circf x y radius)))


;---------------- Polygons ----------------


(defvicefun (POLYGON IRIS) (polygon)
  (let ((n (poly-number-of-points polygon))
	(points (poly-points polygon)))
    (case (poly-type polygon)
      (:2D-ABSOLUTE
       (if (poly-integerp polygon)
	   (iris:poly2i n points)
	 (iris:poly2 n points)))
      (:3D-ABSOLUTE
       (if (poly-integerp polygon)
	   (iris:polyi n points)
	 (iris:poly n points)))
      (:2D-RELATIVE
       (dotimes (i n)
	 (iris:rdr2 (aref points i 0) (aref points i 1))))
      (:3D-RELATIVE
	(dotimes (i n)
	  (iris:rdr (aref points i 0) (aref points i 1) (aref points i 2)))))))

(defvicefun (FILL-POLYGON IRIS) (polygon)
  (let ((n (poly-number-of-points polygon))
	(points (poly-points polygon)))
    (case (poly-type polygon)
      (:2D-ABSOLUTE
       (if (poly-integerp polygon)
	   (iris:polf2i n points)
	 (iris:polf2 n points)))
      (:3D-ABSOLUTE
       (if (poly-integerp polygon)
	   (iris:polfi n points)
	 (iris:polf n points)))
      (:2D-RELATIVE
       (dotimes (i n)
	 (iris:rpmv2i 0 0)
	 (iris:rpdr2 (aref points i 0) (aref points i 1)))
       (iris:pclose))
      (:3D-RELATIVE
       (dotimes (i n)
	 (iris:rpmvi 0 0 0)
	 (iris:rpdr (aref points i 0) (aref points i 1) (aref points i 2)))
       (iris:pclose)))))


(defvicefun (SHADE-POLYGON IRIS) (polygon shade-array)
  (let ((n (poly-number-of-points polygon))
	(points (poly-points polygon)))
    (case (poly-type polygon)
      (:2D-ABSOLUTE (iris:splf2 n points shade-array))
      (:2D-RELATIVE
       (iris:setshade (aref shade-array 0))
       (iris:rpmv2i 0 0)
       (dotimes (i n)
	 (iris:setshade (aref shade-array (1+ i)))
	 (iris:rpdr2 (aref points i 0) (aref points i 1)))
       (iris:spclose))
      (:3D-ABSOLUTE (iris:splf n points shade-array))
      (:3D-RELATIVE
       (iris:setshade (aref shade-array 0))
       (iris:rpmvi 0 0 0)
	(dotimes (i n)
	 (iris:setshade (aref shade-array (1+ i)))
	  (iris:rpdr (aref points i 0) (aref points i 1) (aref points i 2)))
	(iris:spclose)))))


;---------------- Segments ----------------


(defstruct (IRIS-SEGMENT (:include segment))
  translate-tag
  x-rotate-tag
  y-rotate-tag
  z-rotate-tag
  scale-tag
  color-tag

  obj-number)

#|

defaults for segments
  
  host-device *current-display-device*

  x            0
  y            0
  z            0
  translatablep t

  x-rotation   0
  x-rotatablep  t

  y-rotation   0
  y-rotatablep  t

  z-rotation   0
  z-rotatablep  t

  x-scale      1
  y-scale      1
  z-scale      1
  scalablep     t

  color        1
  colorablep     t

  all tags and iris-obj-number will be initialized

|#

(defvicefun (OPEN-SEGMENT IRIS) (&key
				  (translatablep t)
				  (x 0)
				  (y 0)
				  (z 0)
				  (x-rotatablep t)
				  (x-rotation 0)
				  (y-rotatablep t)
				  (y-rotation 0)
				  (z-rotatablep t)
				  (z-rotation 0)
				  (scalablep t)
				  (x-scale 1.0)
				  (y-scale 1.0)
				  (z-scale 1.0)
				  (colorablep t)
				  (color 1))
  (let* ((translate-tag (if translatablep (iris:gentag) nil))
	 (x-rotate-tag (if x-rotatablep (iris:gentag) nil))
	 (y-rotate-tag (if y-rotatablep (iris:gentag) nil))
	 (z-rotate-tag (if z-rotatablep (iris:gentag) nil))
	 (scale-tag (if scalablep (iris:gentag) nil))
	 (color-tag (if colorablep (iris:gentag) nil))
	 (obj-number (iris:genobj))
	 )
    (setf (iris-open-segment)
	  (make-iris-segment
	    :translatablep translatablep
	    :x-rotatablep x-rotatablep
	    :y-rotatablep y-rotatablep
	    :z-rotatablep z-rotatablep
	    :scalablep scalablep
	    :colorablep colorablep
	    :translate-tag translate-tag
	    :x-rotate-tag x-rotate-tag
	    :y-rotate-tag y-rotate-tag
	    :z-rotate-tag z-rotate-tag
	    :scale-tag scale-tag
	    :color-tag color-tag
	    :obj-number obj-number
	    ))
						;make the segment on the iris
						;and do the transformation 
						;commands
    (iris:makeobj obj-number)
    (when (or translatablep x-rotatablep y-rotatablep z-rotatablep scalablep)
      (push-transform)
      (when translatablep
	(iris:maketag translate-tag)
	(translate x y z))
      (when x-rotatablep
	(iris:maketag x-rotate-tag)
	(rotate x-rotation :x))
      (when y-rotatablep
	(iris:maketag y-rotate-tag)
	(rotate y-rotation :y))
      (when z-rotatablep
	(iris:maketag z-rotate-tag)
	(rotate z-rotation :z))
      (when scalablep
	(iris:maketag scale-tag)
	(scale x-scale y-scale z-scale)))
    (when colorablep
      (iris:maketag color-tag)
      (set-color color))
    (iris-open-segment)
    )
  )

(defvicefun (CLOSE-SEGMENT IRIS) ()
  (let ((seg (iris-open-segment)))
    (when (or (iris-segment-translatablep seg)
	      (iris-segment-x-rotatablep seg)
	      (iris-segment-y-rotatablep seg)
	      (iris-segment-z-rotatablep seg)
	      (iris-segment-scalablep seg))
      (pop-transform))
    (iris:closeobj)
    (prog1
      seg
      (setf (iris-open-segment) nil))))

(defvicefun (CALL-SEGMENT IRIS) (segment)
  (iris:callobj (iris-segment-obj-number segment)))

(defvicefun (DELETE-SEGMENT IRIS) (segment)
  (iris:delobj (iris-segment-obj-number segment))
  (setf (iris-segment-obj-number segment) nil))

(defvicefun (SEGMENTP IRIS) (segment)
  (let ((obj-number (iris-segment-obj-number segment)))
    (and obj-number
	 (iris:isobj obj-number))))

(defvicefun (SET-SEGMENT-XYZ IRIS) (segment x y z)
  (unless (iris-segment-translatablep segment)
    (error "Can't change xyz of a non translatable segment"))
  (iris:editobj (iris-segment-obj-number segment))
  (iris:objreplace (iris-segment-translate-tag segment))
  (translate x y z)
  (iris:closeobj))

(defvicefun (SET-SEGMENT-X-ROTATION IRIS) (segment x-rotation)
  (unless (iris-segment-x-rotatablep segment)
    (error "Can't change x-rotation of a non-x-rotatablep segment"))
  (iris:editobj (iris-segment-obj-number segment))
  (iris:objreplace (iris-segment-x-rotate-tag segment))
  (rotate x-rotation :x)
  (iris:closeobj))

(defvicefun (SET-SEGMENT-Y-ROTATION IRIS) (segment y-rotation)
  (unless (iris-segment-y-rotatablep segment)
    (error "Can't change y-rotation of a non y-rotatablep segment"))
  (iris:editobj (iris-segment-obj-number segment))
  (iris:objreplace (iris-segment-y-rotate-tag segment))
  (rotate y-rotation :y)
  (iris:closeobj))

(defvicefun (SET-SEGMENT-Z-ROTATION IRIS) (segment z-rotation)
  (unless (iris-segment-z-rotatablep segment)
    (error "Can't change z-rotation of a non z-rotatablep segment"))
  (iris:editobj (iris-segment-obj-number segment))
  (iris:objreplace (iris-segment-z-rotate-tag segment))
  (rotate z-rotation :z)
  (iris:closeobj))

(defvicefun (SET-SEGMENT-SCALE IRIS) (segment x-scale y-scale z-scale)
  (unless (iris-segment-scalablep segment)
    (error "Can't change scale of a non scalablep segment"))
  (iris:editobj (iris-segment-obj-number segment))
  (iris:objreplace (iris-segment-scale-tag segment))
  (scale x-scale y-scale z-scale)
  (iris:closeobj))
  
(defvicefun (SET-SEGMENT-COLOR IRIS) (segment color)
  (unless (iris-segment-colorablep segment)
    (error "Can't change color of a non colorablep segment"))
  (iris:editobj (iris-segment-obj-number segment))
  (iris:objreplace (iris-segment-color-tag segment))
  (set-color color)
  (iris:closeobj))

;---------------- Modelling Transformations ----------------


(defvicefun (PUSH-TRANSFORM IRIS) ()
  (iris:pushmatrix))

(defvicefun (POP-TRANSFORM IRIS) ()
  (iris:popmatrix))

(defvicefun (SET-TRANSFORM IRIS) (transform)
  (iris:loadmatrix transform))

(defvicefun (GET-TRANSFORM IRIS) ()
  (declare (values matrix-copy))
  (iris:getmatrix (make-transform)))

(defvicefun (ROTATE IRIS) (angle axis)
  (iris:rotate (* 10. angle) (case axis
			       (:x #\x)
			       (:y #\y)
			       (:z #\z))))

(defvicefun (SCALE IRIS) (x y z)
  (iris:scale x y z))

(defvicefun (TRANSLATE IRIS) (x y z)
  (iris:translate X Y Z))

(defvicefun (TRANSFORM IRIS) (matrix)
  (iris:multmatrix matrix))

(defvicefun (TRANSFORM-POINT3 IRIS) (x y z)
  (iris:xfpt x y z))

(defvicefun (TRANSFORM-POINT2 IRIS) (x y)
  (iris:xfpt2 x y))

(defvicefun (TRANSFORM-POINT4 IRIS) (x y z w)
  (iris:xfpt4 x y z w))


;---------------- Viewing Transformations ----------------


(defvicefun (VIEW IRIS) (vx vy vz px py pz twist)
  (iris:lookat vx vy vz px py pz twist))

(defvicefun (POLAR-VIEW IRIS) (distance azimuth inclination twist)
  (iris:polarview distance (* 10. azimuth) (* 10. inclination) (* 10. twist)))


;---------------- Projection Transformations ----------------


(defvicefun (ORTHO2 IRIS) (left right bottom top)
  (iris:ortho2 left right bottom top))

(defvicefun (ORTHO3 IRIS) (left right bottom top near far)
  (iris:ortho left right bottom top near far))

(defvicefun (PERSPECTIVE IRIS) (field-of-view-angle aspect-ratio near far)
  (iris:perspective (* 10. field-of-view-angle) aspect-ratio near far))

(defvicefun (PERSPECTIVE-FRUSTUM IRIS) (left right bottom top near far)
  (iris:window left right bottom top near far))


;---------------- Viewports ----------------


(defvicefun (SET-VIEWPORT IRIS) (viewport)
  (let* (
	 (left (viewport-left viewport))
	 (right (viewport-right viewport))
	 (bottom (viewport-bottom viewport))
	 (top (viewport-top viewport))
	 )
    (when (or
	    (> left right)
	    (> bottom top)
	    (< left 0)
	    (< bottom 0)
	    (> right 1.0)
	    (> top 1.0)
	    )
      (error "Incorrect viewport args"))
  (iris:viewport (round (* 1023 left))
		 (round (* 1023 right))
		 (round (* 767  bottom))
		 (round (* 767  top)))
  ))

(defvicefun (SCREEN-ASPECT-RATIO IRIS) ()
  1.333768)

(defvicefun (GET-VIEWPORT IRIS) ()
  (multiple-value-bind (left right bottom top) (iris:getviewport)
    (make-viewport left right bottom top)))

(defvicefun (FILL-VIEWPORT IRIS) ()
  (iris:clear))


;---------------- Double Buffering ----------------

(defvicefun (DOUBLE-BUFFER IRIS) (&optional (enablep t))
  (if enablep (iris:doublebuffer) (iris:singlebuffer))
  (iris:gconfig))

(defvicefun (DOUBLE-BUFFER-P IRIS) ()
  (equal (iris:getdisplaymode) 2))

;(defvicefun (BACK-BUFFER IRIS) (&optional (enablep t))
;  (iris:backbuffer enablep))

;(defvicefun (FRONT-BUFFER IRIS) (&optional (enablep t))
;  (iris:frontbuffer enablep))

;(defvicefun (ENABLED-BUFFERS IRIS) ()
;  (let ((buffer-value (iris:getbuffer)))
;    (selectq buffer-value
;      (0 (values nil nil))			;SINGLEBUFFER ??? is this right PW
;      (1 (values nil t))			;BACKBUFFER
;      (2 (values t nil))			;FRONTBUFFER
;      (3 (values t t)))))			;BOTHBUFFERS

(defvicefun (SWAP-BUFFERS IRIS) ()
  (iris:swapbuffers))


;---------------- Text ----------------

(defvicefun (SET-TEXT-POS IRIS) (x y)
  (iris:cmov2 x y))

(defvicefun (GET-TEXT-POS IRIS) ()
  (iris:getcpos))
    
(defvicefun (STRING-OUT IRIS) (string)
  (iris:charstr string))

(defvicefun (CHAR-OUT IRIS) (char)
  (iris:charstr (string char)))

(defvicefun (STRING-WIDTH IRIS) (string)
  (declare (values string-width))
  (iris:strwidth string))

(defvicefun (FONT-HEIGHT IRIS) ()
  (declare (values maximum-height))
  (iris:getheight))


;---------------- Device Control ----------------

(defvicefun (BLANK-VIDEO IRIS) (&optional (enabledp t))
  (iris:blankscreen enabledp))


;---------------- Mouse ----------------

(defvicefun (MOUSE IRIS) (predicate)
  (setq *iris-stealing-mouse* (if predicate
				  *current-display-device*
				nil))
  (set-cursor-visibility predicate))

(defvicefun (MOUSEP IRIS) ()
  *iris-stealing-mouse*)

(defvicefun (GET-MOUSE-STATE IRIS) ()
  (zl:process-allow-schedule)  ;make sure cursor can track while dragging.
  (multiple-value-bind (b ignore x y) (tv:mouse-buttons)
    (zl:with-lock (*iris-lock*)
      (wait-for-iris)
      (let ((x (* x *inv-lm-max-x* *iris-screen-max-x*))
	    (y (* (- *lm-max-y* y) *inv-lm-max-y* *iris-screen-max-y*)))
	(apply #'values b
	       (multiple-value-list (iris:mapw 0 x y)))))))

(defvicefun (MOUSE-CLICK-P IRIS) ()
  (not (tv:io-buffer-empty-p (iris-mouse-buffer))))

(defvicefun (GET-MOUSE-CLICK IRIS) (&optional waitp)
  (let ((click (tv:io-buffer-get (iris-mouse-buffer) (not waitp))))
    (when click
      (setf (iris-last-mouse-click) click)
      (zl:with-lock (*iris-lock*)
	(wait-for-iris)
	(apply #'values (mouse-click-buttons click)
	       (multiple-value-list (iris:mapw 0
					       (mouse-click-x click)
					       (mouse-click-y click))))))))

(defvicefun (GET-LAST-MOUSE-CLICK IRIS) ()
  (let ((last-mouse-click (iris-last-mouse-click)))
    (multiple-value-bind (x1 y1 z1 x2 y2 z2)
      (zl:with-lock (*iris-lock*)
	(wait-for-iris)
	(iris:mapw 0
		   (mouse-click-x last-mouse-click)
		   (mouse-click-y last-mouse-click)))
      (values (mouse-click-buttons last-mouse-click)
	      x1 y1 z1 x2 y2 z2))))


;---------------- Reverse Transform Point ----------------

(defvicefun (REVERSE-TRANSFORM-POINT2 IRIS) (scr-x scr-y)
  (iris:mapw2 0 scr-x scr-y))

(defvicefun (REVERSE-TRANSFORM-POINT3 IRIS) (scr-x scr-y)
  (iris:mapw 0 scr-x scr-y))

;---------------- Other ----------------

(defvicefun (call-with-locked-device IRIS) (drawing-commands)
  (zl:with-lock (*iris-lock*)
    (wait-for-iris)
    (let ((cv (get-cursor-visibility)))
      (unwind-protect
	  (progn
	    (when cv (set-cursor-visibility nil))
	    (when (iris-blank-video-while-drawing-p) (iris:blankscreen 1))
	    (funcall drawing-commands))
	(when (iris-blank-video-while-drawing-p) (iris:blankscreen 0))
	(when cv (set-cursor-visibility t))))))

(defvicefun (blank-video-while-drawing IRIS) (predicate)
  (setf (iris-blank-video-while-drawing-p) predicate))



;----------------------------------------------------------------


(defdemo "Use Iris" 'use-iris
  "Use the Iris Device" "vista:library;iris lisp")

(defvar *demo-iris*)

(defun use-iris ()
  "Use an Iris device, creating one if neccesary"
  (unless (and (boundp '*demo-iris*)
	       (typep *demo-iris* 'iris))
    (setq *demo-iris* (make-iris)))
  (set-display-device *demo-iris*))