;;;-*-LISP-*-
;;; A graphics utility package. - George Carrette.

;; Macros and compile-time environment.

(herald graphm)

;; A form to put at the begining of the modules.
;; Works if the modules are in the same directory as
;; this macro file.
;;
;;(eval-when (eval compile)
;;   (or (get 'graphm 'version)
;;       (load (list (car (namelist infile)) 'graphm))))
;;
;; (graphs-module <name>)

(eval-when (eval compile load)
  (or (get 'umlmac 'version)
      (load '((lisp)umlmac)))
  (or (fboundp 'defstruct)
      (load (caseq (status opsys)
	      ((tops-20)
	       "<GJC>struct")
	      ((its)
	       "liblsp;struct")
	      (t
	       (error "unknown opsys" (status opsys) 'fail-act))))))

(defmacro graphs-module (name)
  `(progn 'compile
	  (herald ,name)
	  (eval-when (eval)
	    (or (get 'graphs 'version)
		(load (list (car (namelist infile)) 'graphs))))
	  (eval-when (load)
	    (or (get 'graphs 'version)
		(load (list (car (namelist (status fasload))) 'graphs))))))

(defmacro defstream (name &rest slots)
  `(defstruct (,name named conc-name default-pointer
		     (constructor ,(symbolconc 'make- name '-1)))
     ,@slots))

;; For GRAPHS module:

(when (status feature complr)
      (*expr set-pen move-pen vector-pen draw-point
	     draw-frame NARG-CHECK NARG-ERROR
	     UNKNOWN-COMMAND
	     set-viewport get-viewport set-window get-window
	     call0 call1 call2 call3 call4 call5
	     graphics-stream-tyo
	     )
      (*lexpr graphics-stream-close graphics-stream-open call
	      make-broadcast-stream
	      make-broadcast-sfa
	      ))

(defstream broadcast-stream
  out-streams)

(defstruct (graphics-sfa sfa conc-name
			 (constructor make-graphics-sfa-1))
  out-stream)

(defstruct (broadcast-sfa sfa default-pointer conc-name
			  (constructor make-broadcast-sfa-1))
  l)

;; For GRAPHA module.

(WHEN (STATUS FEATURE COMPLR)
      (*expr make-ards-stream)
      (special out-stream graphic-mode invisiblep
	       dottedp last-pos
	       ards-stream))

(defstream ards-stream
  (out-stream nil)
  (graphic-mode nil)
  (invisiblep nil)
  (dottedp nil)
  (last-pos (make-ards-last-pos))
  ;; default information for GRAPH$
  (X-MIN -400.)
  (X-MAX 400.)
  (Y-MIN -400.)
  (Y-MAX 400.)
  )

(defstruct (ards-last-pos fixnum-array conc-name) x y)

;; For GRAPH$ module:

(WHEN (STATUS FEATURE COMPLR)
      (SPECIAL GRAPHICS-STREAM WINDOW VIEWPORT SCALING-COEF WLAST-POS
	       OUT-STREAM)
      (flonum (y-intercept flonum flonum flonum flonum flonum))
      (*expr y-intercept make-graphics-stream))


(defstream GRAPHICS-STREAM
  (window (make-window))
  (viewport (make-viewport))
  (scaling-coef (make-scaling-coef))
  (wlast-pos (make-wlast-pos))
  out-stream
  )

(defstruct (window flonum-array conc-name)
  (x0 -1.0)
  (x1 +1.0)
  (y0 -1.0)
  (y1 +1.0))

(defstruct (viewport fixnum-array conc-name) 
  (x0 0)
  (x1 100)
  (y0 0)
  (y1 100))

(defstruct (scaling-coef flonum-array conc-name)
  k-x k-y m-x m-y)

(defstruct (wlast-pos flonum-array conc-name)
  x y)

(defmacro scale (k w m)
  `(ifix (+$ (*$ ,k ,w) ,m)))

(defmacro scale-x (x)
  `(scale (scaling-coef-k-x scaling-coef)
	  ,x
	  (scaling-coef-m-x scaling-coef)))

(defmacro scale-y (y)
  `(scale (scaling-coef-k-y scaling-coef)
	  ,y
	  (scaling-coef-m-y scaling-coef)))


(DEFMACRO X-INTERCEPT (A B C D E)
  `(Y-INTERCEPT ,B ,A ,D ,C ,E))

;; For GRAPH3 module:

(WHEN (STATUS FEATURE COMPLR)
      (SPECIAL Z-CLIP-STREAM OUT-STREAM 3D-CLIP
	       Z-PERSPECTIVE-STREAM PERSPECTIVE
	       ORTHOGONAL-3D-STREAM EULER
	       ))

  
(defstream Z-CLIP-STREAM
  out-stream
  (3d-clip (make-3d-clip)))


(defstruct (3d-perspective conc-name flonum-array)
  z-eye z-screen)

(defstruct (3d-clip conc-name flonum-array)
  x y z clip)


(defstream Z-PERSPECTIVE-STREAM
  out-stream
  (perspective (make-3d-perspective)))

(defmacro x-intercept3 (z0 x0 z1 x1 z)
  ;; this is not scewed as is the 2-dim case.
  `(y-intercept ,z0 ,x0 ,z1 ,x1 ,z))

(defmacro y-intercept3 (z0 y0 z1 y1 z)
  `(y-intercept ,z0 ,y0 ,z1 ,y1 ,z))

(defmacro y-screen (z-eye z-screen z y)
  `(x-screen ,z-eye ,z-screen ,z ,y)))

(defstruct (3matrix conc-name flonum-array
		    size-macro)
  x-x x-y x-z
  y-x y-y y-z
  z-x z-y z-z)

(defmacro 3row*col (row col m1 m2)
  `(+$ (*$ (,(symbolconc '3matrix- row '-x) ,m1)
	   (,(symbolconc '3matrix-x- col) ,m2))
       (*$ (,(symbolconc '3matrix- row '-y) ,m1)
	   (,(symbolconc '3matrix-y- col) ,m2))
       (*$ (,(symbolconc '3matrix- row '-z) ,m1)
	   (,(symbolconc '3matrix-z- col) ,m2))))

(defmacro 3matrix-copy (m1 &optional (m2 (make-3matrix)))
  `(fillarray ,m2 ,m1))

;; The euler matrix will keep various matricies around so that
;; certain kinds of updates will be efficient.

(defstruct (euler conc-name)
  ;; matrix used in transformations.
  (rot (phi-matrix 0.0))
  ;; for differential updates of rot.
  (drot (phi-matrix 0.0))
  ; for reference.
  (ident (phi-matrix 0.0))
  (phi (phi-matrix 0.0))
  (phi-val 0.0)
  (dphi (phi-matrix 0.0))
  (dphi-val 0.0)
  (theta (theta-matrix 0.0))
  (theta-val 0.0)
  (dtheta (theta-matrix 0.0))
  (dtheta-val 0.0)
  (psi (psi-matrix 0.0))
  (psi-val 0.0)
  (dpsi (psi-matrix 0.0))
  (dpsi-val 0.0))

(defstream orthogonal-3d-stream
  out-stream
  (euler (make-euler)))


;; For GRAPHT module:

(WHEN (STATUS FEATURE COMPLR)
      (*expr make-tek-stream)
      (SPECIAL tek-stream VIEWPORT GRAPHIC-OUTPUT))

(defstruct (tek conc-name fixnum-array (default-pointer viewport))
  (x-min 0)
  (x-max #o1777)
  (y-min 0)
  (y-max #o1377)
  (x-pen 0)
  (y-pen 0)
  (graphic-mode TEK-GRAPHMODE)
  (high-y 0)
  (low-y 0)
  (high-x 0)
  (low-x 0))

(defstream tek-stream
  (viewport (make-tek))
  (graphic-output))


;; Optimizations.

(DEFPROP CALL (CALL-ST) SOURCE-TRANS)
(DEFUN CALL-ST (FORM)
  (LET ((ARG-N (LENGTH (CDDR FORM))))
    (IF (> ARG-N 5)
	(VALUES FORM NIL)
	(VALUES (CONS (CDR (ASSOC ARG-N '((0 . CALL0)
					  (1 . CALL1)
					  (2 . CALL2)
					  (3 . CALL3)
					  (4 . CALL4)
					  (5 . CALL5))))
		      (CDR FORM))
		T))))

(DEFPROP NARG-CHECK (NARG-CHECK-ST) SOURCE-TRANS)
(DEFUN NARG-CHECK-ST (FORM)
  (IF (TRIVIAL-ARG-LIST? (CDR FORM))
      (VALUES `(OR (= ,(CADR FORM) ,(CADDR FORM))
		   (NARG-ERROR ,@(CDR FORM)))
	      T)
      (VALUES FORM NIL)))

(DEFUN TRIVIAL-ARG-LIST? (L)
  (DO ()
      ((NULL L) T)
    (LET ((FORM (POP L)))
      (IF (NOT (ATOM FORM))
	  (IF (NOT (EQ (CAR FORM) 'QUOTE))
	      (RETURN NIL))))))