#| -*- 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.

;;; *******************************************
;;; ***** PROPRIETARY AND CONFIDENTIAL!!! *****
;;; *******************************************

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

;;;; Other stuff

;;; This is the part of the vista library that
;;; is device independent.
;;; including some macros and data structures


(export '(MAKE-SEGMENT
	  SEGMENT-DEVICE
	  WITH-TRANSFORM
	  POINT LINE LINE-RELATIVE MOVE MOVE-RELATIVE ORTHO
	  MAKE-POLYGON
	  MAKE-VIEWPORT
	  VIEWPORT-LEFT VIEWPORT-RIGHT VIEWPORT-BOTTOM VIEWPORT-TOP
	  MAKE-ENVIRONMENT
	  %SET-ENVIRONMENT
	  make-2d-environment
	  make-3d-environment
	  make-perspective-environment
	  %MOUSE-ENVIRONMENT-SHAPE
	  DEFDEMO DEMO
	  DRAWING
	  WITH-VISTA-MOUSE
	  SHADE-COLORS FROB-COLORS
	  VIEWPORT-ASPECT-RATIO
	  READ-POINT))


;;; Changes
;;; 4/16/86 EFH    put (:constructor nil) in segment defstruct
;;; 5/05/86 PECANN macro DRAWING
;;; 5/14/86 PECANN struct mouse-click
;;; 5/15/86 PECANN macro WITH-VISTA-MOUSE
;;; 5/16/86 EFH    added exit to demo
;;; 5/28/86 PECANN extra point in relative polygons (for closing)
;;; 6/06/86 EFH    added VIEWPORT and ENVIRONMENT objects
;;; 6/11/86 PECANN removed %set-viewport
;;; 6/07/86 PW,RPK fixed (drawing ...) so that it works in a general way
;;; 6/07/86 PW     steal-mouse -> mouse in drawing and %mouse-environment-shape
;;; 8/22/86 PECANN used #+/- to keep non-lispms from seeing fonts:...
;;; 9/06/86 PECANN added function viewport-aspect-ratio
;;; 9/09/86 PECANN added nargs macro READ-POINT
;;; 9/13/86 PECANN ? -> -p
;;; 9/14/86 PECANN <single-word>-p -> <single-word>p
;;; 9/17/86 PECANN added message to frob-colors



(defmacro WITH-VISTA-MOUSE (&body body)
  `(unwind-protect
       (progn
	 (mouse t)
	 ,@body)
     (mouse nil)))

(defstruct (mouse-click (:conc-name mouse-click-)
			(:predicate nil))
  buttons
  x
  y)



(defmacro DRAWING (&body body)
  "Allow device to prevent mouse or cursor interference, etc."
  `(call-with-locked-device
     #'(lambda ()
	 #+(or lmi symbolics) (declare (sys:downward-function))
	 ,@body)))


;  `(zl:with-lock (*iris-lock*)
;     (if (typep *current-display-device* 'iris) (wait-for-iris))
;     (let ((cv (get-cursor-visibility)))
;       (unwind-protect
;	   (progn
;	     (when cv (set-cursor-visibility nil))
;	     ,@body)
;	 (when cv (set-cursor-visibility t))))))

;;; Does this need an unwind protect?
(defmacro MAKE-SEGMENT (keywords &body body)
  "Returns a segment containing the
 graphics commands executed in the body"
  `(unwind-protect
       (prog1 (open-segment ,@keywords)
	      ,@body)
     (close-segment)))

(defmacro WITH-TRANSFORM (&body body)
  `(unwind-protect
       (progn (push-transform)
	      ,@body)
     (pop-transform)))


;;; WITH-POSITION


;; This doesn't work??
;(defmacro POINT (x y &optional ((z zp)))
;  (if zp
;      `(POINT3 ,x ,y ,z)
;    `(POINT2 ,x ,y)))


(defun nargs-macro-nargs-error (n nargses)
  (error "Wrong number of args to a macro: ~d passed, ~a required."
	 n nargses))

(eval-when (eval compile load)
(defun nargses (clauses)
  (let ((nargses ())
	n)
    (dolist (c clauses)
      (setq n (car c))
      (cond ((numberp n)
	     (push n nargses))
	    ((listp n)
	     (setq nargses
		   (append n nargses)))
	    (t (error "Malconstructed case in nargs macro: ~a" n))))
    (nreverse nargses)))
)

(defmacro def-nargs-macro (name lambda-list &body clauses)
  `(defmacro ,name (&rest args)
     #+lispm (declare (zl:arglist . ,lambda-list))
     ,(if (stringp (car clauses)) (pop clauses))
     `(,(case (length args)
	  ,@clauses
	  (T (nargs-macro-nargs-error
	       (length args)
	       ',(nargses clauses))))

       ,@args)))


(defmacro def-2d-or-3d-macro (name lambda-list doc-string 2d-op 3d-op)
  `(def-nargs-macro ,name ,lambda-list
     ,doc-string
     (2 ',2d-op)
     (3 ',3d-op)))


(def-2d-or-3d-macro POINT (x y &optional z)
  "Draws a point at the specified position."
  POINT2
  POINT3)


(def-2d-or-3d-macro LINE (x y &optional z)
  "Draws a line from the current graphics position
to the specified position."
  LINE2
  LINE3)

(def-2d-or-3d-macro LINE-RELATIVE (dx dy &optional dz)
  "Draws a line from the current graphics position
to the position (dx, dy, dz) away."
  LINE-RELATIVE2
  LINE-RELATIVE3)


(def-2d-or-3d-macro MOVE (x y &optional z)
  "Sets the current graphics position."
  MOVE2
  MOVE3)

(def-2d-or-3d-macro MOVE-RELATIVE (x y &optional z)
  "Sets the current graphics position."
  MOVE-RELATIVE2
  MOVE-RELATIVE3)

(def-2d-or-3d-macro READ-POINT (x y &optional z)
  "Returns the color of the pixel corresponding to a point on the screen"
  READ-POINT2
  READ-POINT3)

(def-nargs-macro ORTHO (left right bottom top &optional near far)
  "Set the current transform to specify an orthographic projection"
  (4 'ORTHO2)
  (6 'ORTHO3))




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

(defstruct (SEGMENT (:constructor nil)
		    (:print-function print-segment))
  (device *current-display-device*)
  translatablep
  x-rotatablep
  y-rotatablep
  z-rotatablep
  scalablep
  colorablep)

(defun print-segment (seg stream depth)
  (format stream "#<~a ~a>" (type-of seg) #+lispm (zl:%pointer seg) #-lispm ""))

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

(defstruct (POLYGON (:conc-name poly-)
		    (:constructor %make-polygon))
  type
  (number-of-points 0 :type integer)
  (integerp t)
  points)


(defun MAKE-POLYGON (type &rest coords)
  (let* ((2dp (member type '(:2d :2d-relative) :test #'eq))
	 (relativep (member type '(:2d-relative :3d-relative) :test #'eq))
	 (integerp (every #'(lambda (c) (typep c 'integer)) coords)) 
	 (d (if 2dp 2 3))
	 (n-points (/ (length coords) d))
	 (point-array (make-array (list (+ n-points
					   (if relativep
					       1
					     0))
					d)
				  :element-type t)) ;(if integerp 'integer t))))
	 (sum-x 0)
	 (sum-y 0)
	 (sum-z 0))
    (cond (2dp
	   (dotimes (i n-points)
	     (incf sum-x (setf (aref point-array i 0) (car coords)))
	     (incf sum-y (setf (aref point-array i 1) (cadr coords)))
	     (setq coords (cddr coords)))
	   (when relativep
	     (setf (aref point-array n-points 0) (- sum-x))
	     (setf (aref point-array n-points 1) (- sum-y))))
	  (t
	   (dotimes (i n-points)
	     (incf sum-x (setf (aref point-array i 0) (car coords)))
	     (incf sum-y (setf (aref point-array i 1) (cadr coords)))
	     (incf sum-z (setf (aref point-array i 2) (caddr coords)))
	     (setq coords (cdddr coords)))
	   (when relativep
	     (setf (aref point-array n-points 0) (- sum-x))
	     (setf (aref point-array n-points 1) (- sum-y))
	     (setf (aref point-array n-points 2) (- sum-z)))))
    (%make-polygon :number-of-points (+ n-points (if relativep 1 0))
		   :type type
		   :integerp integerp
		   :points point-array)))


(defmacro POLY-POINT-X (poly point-index)
  `(aref (poly-points ,poly) ,point-index 0))

(defun SET-POLY-POINT-X (poly point-index new-x)
  (unless (typep new-x 'integer)
    (setf (poly-integerp poly) nil))
  (setf (poly-point-x poly point-index) new-x))

(defmacro POLY-POINT-Y (poly point-index)
  `(aref (poly-points ,poly) ,point-index 1))

(defun SET-POLY-POINT-Y (poly point-index new-y)
  (unless (typep new-y 'integer)
    (setf (poly-integerp poly) nil))
  (setf (poly-point-y poly point-index) new-y))

(defmacro POLY-POINT-Z (poly point-index)
  `(aref (poly-points ,poly) ,point-index 2))

(defun SET-POLY-POINT-Z (poly point-index new-z)
  (unless (typep new-z 'integer)
    (setf (poly-integerp poly) nil))
  (setf (poly-point-z poly point-index) new-z))
       
   
    
(defun POLY-POINT (poly point-index)
  (let ((type (poly-type poly))
	(points (poly-points poly)))
    (if (or (eq type :2d) (eq type :2d-relative))
	(values (aref points point-index 0)
		(aref points point-index 1))
      (values (aref points point-index 0)
	      (aref points point-index 1)
	      (aref points point-index 2)))))


(def-nargs-macro SET-POLY-POINT (poly point-index x y &optional z)
  "Set the polygon vertex coordinates of the point at point-index in poly
to the specified values"
  (4 'set-poly-point2)
  (5 'set-poly-point3))

(defun SET-POLY-POINT2 (poly point-index x y)
  (let ((points (poly-points poly)))
    (unless (and (typep x 'integer)
		 (typep y 'integer))
      (setf (poly-integerp poly) nil))
    (setf (aref points point-index 0) x)
    (setf (aref points point-index 1) y)))

(defun SET-POLY-POINT3 (poly point-index x y z)
  (let ((points (poly-points poly)))
    (unless (and (typep x 'integer)
		 (typep y 'integer)
		 (typep z 'integer))
      (setf (poly-integerp poly) nil))
    (setf (aref points point-index 0) x)
    (setf (aref points point-index 1) y)
    (setf (aref points point-index 2) z)))

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

(defstruct (viewport (:print-function print-viewport)
		     (:constructor make-viewport (left right bottom top)))
	   ; these values are fractions.  min = 0, max = 1.0
  left
  right
  bottom
  top)

(defun print-viewport (viewport stream depth)
  depth
  (format stream "#<Viewport ~d ~d ~d ~d ~o>"
	  (viewport-left viewport)
	  (viewport-right viewport)
	  (viewport-bottom viewport)
	  (viewport-top viewport)
	  #+lispm (zl:%pointer viewport) #-lispm ""))

(defun viewport-aspect-ratio (viewport)
  "Returns the physical aspect ratio of the viewport on the
current display device, i.e. the ratio of its width to its
height in units of physical linear measure such as millimeters."
  (* (/ (- (viewport-right viewport)
	   (viewport-left viewport))
	(- (viewport-top viewport)
	   (viewport-bottom viewport)))
     (screen-aspect-ratio)))

;---------------- Environments ----------------

(defstruct (environment (:include viewport)
			(:print-function print-environment))
  display-device
  (background-color nil)
  (border-color nil)
  (label nil)
;  (color 1)
;  (graphpos-x 0)
;  (graphpos-y 0)
;  (graphpos-z 0)
;  transform
  )

(defparameter *full-screen-viewport* (make-viewport 0.0 1.0 0.0 1.0))
(defparameter *default-mouse-viewport-border-color* 1)

(defun print-environment (environment stream depth)
  depth
  (format stream "#<Environment ~d ~d ~d ~d ~s ~d ~d ~o>"
	  (environment-left environment)
	  (environment-right environment)
	  (environment-top environment)
	  (environment-bottom environment)
	  (environment-display-device environment)
	  (environment-background-color environment)
	  (environment-border-color environment)
	  #+lispm (zl:%pointer environment) #-lispm ""))

;;; environment with a 2d ortho transformation matrix

(defstruct (2d-environment (:include environment))
  ortho-left
  ortho-right
  ortho-top
  ortho-bottom
  )

;;; environment with a 3d ortho transformation matrix

(defstruct (3d-environment (:include environment))
  ortho-left
  ortho-right
  ortho-top
  ortho-bottom
  ortho-near
  ortho-far
  )

;;; environment with a perspective transformation matrix

(defstruct (perspective-environment (:include environment))
  field-of-view-angle
  aspect-ratio
  near-clipping-plane
  far-clipping-plane
  )

(defparameter *full-screen-environment* (make-environment :left 0 :right 1 :bottom 0 :top 1))
(defvar *current-environment* *full-screen-environment*)

(defun %set-environment (environment)
  (setq *current-environment* environment)
  (if (environment-display-device environment)
      (set-display-device (environment-display-device environment)))
  (set-viewport environment)
  (when (environment-background-color environment)
    (set-color (environment-background-color environment))
    (fill-viewport))
  (when (environment-border-color environment)
    (set-viewport *full-screen-viewport*)
    (ortho 0.0 1.0 0.0 1.0)
    (set-color (environment-border-color environment))
    (rectangle (max 0.0 (- (environment-left environment) .001))
	       (max 0.0 (- (environment-bottom environment) .001))
	       (min 1.0 (+ .001 (environment-right environment)))
	       (min 1.0 (+ .001 (environment-top environment))))
    (set-viewport environment))
  (when (environment-label environment)
    (ortho 0 1 0 1)
    (set-color (if (environment-border-color environment) (environment-border-color environment) 7))
    (set-text-pos .05 .95)
    (string-out (environment-label environment)))
  (case (type-of environment)
    (perspective-environment
     (perspective
       (perspective-environment-field-of-view-angle environment)
       (perspective-environment-aspect-ratio environment)
       (perspective-environment-near-clipping-plane environment)
       (perspective-environment-far-clipping-plane environment)))
    (3d-environment
     (ortho
      (3d-environment-ortho-left environment)
      (3d-environment-ortho-right environment)
      (3d-environment-ortho-top environment)
      (3d-environment-ortho-bottom environment)
      (3d-environment-ortho-near environment)
      (3d-environment-ortho-far environment)))
    (2d-environment
     (ortho
      (2d-environment-ortho-left environment)
      (2d-environment-ortho-right environment)
      (2d-environment-ortho-top environment)
      (2d-environment-ortho-bottom environment)))
    (environment
     ;; do nothing every thing is cool!!!
     NIL)
    )
  )

(defun %mouse-environment-shape (environment)
  (let ((mouse-viewport-border-color 
	  (if (environment-border-color environment)
	      (environment-border-color environment)
	    *default-mouse-viewport-border-color*)))
    (if (environment-display-device environment)
	(set-display-device (environment-display-device environment)))
    (set-viewport *full-screen-viewport*)
    (set-color mouse-viewport-border-color)
    (ortho 0.0 1.0 0.0 1.0)
    (with-vista-mouse
      (multiple-value-bind (b1 first-x first-y) (get-mouse-click t)
;	(do ((last-x first-x) (last-y first-y))
;	    ((mouse-click-p))
;	  (multiple-value-bind (b x y) (get-mouse-state)
;	    (zl:process-allow-schedule)		;make sure cursor can track while dragging.
;	    (drawing
;	      (set-color 0)
;	      (rectangle first-x first-y last-x last-y)
;	      (set-color mouse-viewport-border-color)
;	      (rectangle first-x first-y x y)
;	      (setq last-x x last-y y))))
	(multiple-value-bind (b2 last-x last-y) (get-mouse-click t)
	  (if (< first-x last-x)
	      (setf (environment-left environment) first-x
		    (environment-right environment) last-x)
	    (setf (environment-left environment) last-x
		  (environment-right environment) first-x))
	  (if (< first-y last-y)
	      (setf (environment-bottom environment) first-y
		    (environment-top environment) last-y)
	    (setf (environment-bottom environment) last-y
		  (environment-top environment) first-y))
;	  (print (list first-x last-x first-y last-y))
	  ))
      )
    (%set-environment environment)))
      
;----------------------------------------------------------------
;;; Hacks

(defun shade-colors (col1 r1 g1 b1 col2 r2 g2 b2)
  "Set up a range of colors"
  (do* ((ncolors (float (- col2 col1)))
  	(dr (/ (- r2 r1) ncolors))
	(dg (/ (- g2 g1) ncolors))
	(db (/ (- b2 b1) ncolors))
	(color col1 (+ color 1))
	(r r1 (+ r dr))
	(g g1 (+ g dg))
	(b b1 (+ b db)))
       ((> color col2))
      (set-map-color color r g b)))



(defun frob-colors (&optional (end 100) (start 1))
  "Random shades"
  (format t "~&Type any character to exit.")
  (do ()
      ((read-char-no-hang))
    (shade-colors start (random 1.0s0)(random 1.0s0)(random 1.0s0)
  		  end   (random 1.0s0)(random 1.0s0)(random 1.0s0)))
  (format t "~%"))

;----------------------------------------------------------------
;;; Demos

#+lispm (defvar *demo-list* '(("Exit" :funcall exit-demo :documentation "Exit the Demo Menu" :font fonts:tr12bi)))
#-lispm (defvar *demo-list* '(("Exit" :funcall exit-demo :documentation "Exit the Demo Menu")))
(defvar *demo-menu* nil)

#+lispm
(defun defdemo (name fcn-or-form documentation &optional file)
  "Define a Demonstration
NAME is the name of the demo which will appear in menus
FCN-OR-FORM is either a list which is evaled or a function to be funcalled
DOCUMENTATION is a string describing the demo
FILE is the name of the file containing the demo"
  (setq *demo-list*
	(cons `(,name
		,(if (listp fcn-or-form) :eval :funcall) ,fcn-or-form
		:documentation ,documentation
		:font fonts:tr12b
		)
	      (delete (assoc name *demo-list* :test #'equal)
		      *demo-list*))))

#-lispm
(defun defdemo (name fcn-or-form documentation &optional file)
  "Define a Demonstration
NAME is the name of the demo which will appear in menus
FCN-OR-FORM is either a list which is evaled or a function to be funcalled
DOCUMENTATION is a string describing the demo
FILE is the name of the file containing the demo"
  (setq *demo-list*
	(cons `(,name
		,(if (listp fcn-or-form) :eval :funcall) ,fcn-or-form
		:documentation ,documentation
		)
	      (delete (assoc name *demo-list* :test #'equal)
		      *demo-list*))))

(defun exit-demo ()
  (throw 'exit-demo nil))

#+lispm
(defun demo ()
  (when (null *demo-menu*)
    (setq *demo-menu*
	  (tv:make-window 'tv:momentary-menu
			  :label '(:string "Choose a Demo"
				   :font fonts:tr12b))))
  (zl:send *demo-menu* :set-item-list *demo-list*)
  (catch 'exit-demo
    (do () (())
      (tv:expose-window-near *demo-menu* '(:mouse))
      (zl:send *demo-menu* :choose))))


#-lispm
(defun demo ()
  (let ((n 0)
	item)
    (dolist (item *demo-list*)
      (incf n)
      (format t "~&~d. ~a" n (car item)))
    
    (do ()
	((and (typep (progn (format t "~%~&Choose a Demo: ")
			    (setq n (read)))
		     'integer)
	      (<= n (length *demo-list*))
	      (> n 0))))
    (setq item (nth (1- n) *demo-list*))
    (cond ((get item :funcall)
	   (funcall (get item :funcall)))
	  ((get item :eval)
	   (eval (get item :eval)))
	  (t (error "bad item")))))