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

;;; Reorganized 3:26pm  Thursday, 9 July 1981 -GJC

(eval-when (eval compile)
  (or (get 'graphm 'version)
      (load (list (car (namelist infile)) 'graphm))))

(herald graphs)

;; Autoload definitions:
;; Go to some hair to make sure these are in the directory from
;; which this file is being loaded.

(PUTPROP 'GRAPHS
	 '(LAMBDA (GRAPHS)
	    (PUTPROP 'MAKE-ARDS-STREAM (LIST GRAPHS 'GRAPHA)'AUTOLOAD)
	    (PUTPROP 'MAKE-TEK-STREAM (LIST GRAPHS 'GRAPHT)'AUTOLOAD)
	    (PUTPROP 'MAKE-GRAPHICS-STREAM (LIST GRAPHS 'GRAPH$)'AUTOLOAD)
	    (PUTPROP 'MAKE-Z-CLIP-STREAM (LIST GRAPHS 'GRAPH3)'AUTOLOAD)
	    (PUTPROP 'MAKE-Z-PERSPECTIVE-STREAM (LIST GRAPHS 'GRAPH3)'AUTOLOAD)
	    )
	 'GRAPHS)

(EVAL-WHEN (LOAD)
  (FUNCALL (GET 'GRAPHS 'GRAPHS) (CAR (NAMELIST (STATUS FASLOAD)))))
(EVAL-WHEN (EVAL)
  (FUNCALL (GET 'GRAPHS 'GRAPHS) (CAR (NAMELIST INFILE))))
(REMPROP 'GRAPHS 'GRAPHS)

;; Runtime primitives:

(DEFUN CALL N
  (LEXPR-FUNCALL (CAR (ARG 1)) (ARG 1) (LISTIFY (- 1 N))))

(DEFUN NARG-ERROR (N-ACTUAL N-NEEDED THE-FUNCTION)
  (ERROR (LIST "wanted" N-NEEDED "arguments but got" N-ACTUAL)
	 THE-FUNCTION
	 'FAIL-ACT))

(DEFUN NARG-CHECK (N-ACTUAL N-NEEDED THE-FUNCTION)
  (UNLESS (= N-ACTUAL N-NEEDED)
	  (NARG-ERROR N-ACTUAL N-NEEDED THE-FUNCTION)))

(DEFUN UNKNOWN-COMMAND (COMMAND THE-FUNCTION)
  (ERROR (LIST "Unknown command to" THE-FUNCTION) COMMAND
	 'FAIL-ACT))

;; the generic graphics functions.

(DEFUN SET-PEN (F X Y) 
  (CALL F 'SET-PEN X Y))

(DEFUN MOVE-PEN (F X Y)
  (CALL3-MAP2-DISPATCH F 'MOVE-PEN X Y))

(DEFUN VECTOR-PEN (F X Y)
  (CALL3-MAP2-DISPATCH F 'VECTOR-PEN X Y))

(DEFUN DRAW-POINT (F X Y)
  (CALL3-MAP2-DISPATCH F 'DRAW-POINT X Y))

(DEFUN DRAW-LINE (F X1 Y1 X2 Y2)
  (CALL5-MAP2-DISPATCH F 'DRAW-LINE X1 Y1 X2 Y2))

(DEFUN GRAPHICS-STREAM-TYO (F ARG) (CALL F 'TYO ARG))

(DEFUN SET-VIEWPORT (F X0 X1 Y0 Y1)
  (CALL F 'SET-VIEWPORT X0 X1 Y0 Y1))

(DEFUN GET-VIEWPORT (F)
  (CALL F 'VIEWPORT))

(DEFUN SET-WINDOW (F X0 X1 Y0 Y1)
  (CALL F 'SET-WINDOW X0 X1 Y0 Y1))

(DEFUN GET-WINDOW (F)
  (CALL F 'WINDOW))

(DEFUN SET-INVISIBLEP (F FLAG)
  (CALL F 'SET-INVISIBLEP FLAG))

(DEFUN SET-DOTTEP (F FLAG)
  (CALL F 'SET-DOTTEP FLAG))

(DEFUN DRAW-FRAME (S)
  (LET (((X0 X1 Y0 Y1) (GET-WINDOW S)))
    (SET-PEN S X0 Y0)
    (MOVE-PEN S X1 Y0)
    (MOVE-PEN S X1 Y1)
    (MOVE-PEN S X0 Y1)
    (MOVE-PEN S X0 Y0)))

;; Splitting interface

(defun broadcast-stream n
  (let* ((broadcast-stream (arg 1))
	 (l (broadcast-stream-out-streams)))
    (caseq n
      ((1)
       (do ()((null l))
	 (call (pop l))))
      ((2)
       (do ()((null l))
	 (call (pop l) (arg 2))))
      ((3)
       (do ()((null l))
	 (call (pop l) (arg 2) (arg 3))))
      ((4)
       (do ()((null l))
	 (call (pop l) (arg 2) (arg 3) (arg 4))))
      ((5)
       (do ()((null l))
	 (call (pop l) (arg 2) (arg 3) (arg 4) (arg 5))))
      ((6)
       (do ()((null l))
	 (call (pop l) (arg 2) (arg 3) (arg 4) (arg 5) (arg 6))))
      (t
       (do ((rest (listify (- 6 n))))
	   ((null l))
	 (lexpr-funcall #'call (pop l)
			(arg 2) (arg 3) (arg 4) (arg 5) (arg 6)
			rest))))))

(defun make-broadcast-stream (&rest l)
  (make-broadcast-stream-1 out-streams l))

;; SFA Interface.

(defun make-graphics-sfa (out-stream)
  (make-graphics-sfa-1 out-stream out-stream))

(defun graphics-sfa (sfa command arg)
  (caseq command
    ((tyo)
     (CALL (graphics-sfa-out-stream sfa) 'tyo arg))
    ((which-operations)
     '(tyo))
    (t
     (unknown-command command 'graphics-sfa))))

(defun make-broadcast-sfa (&rest l)
  (make-broadcast-sfa-1 l l))

(defun broadcast-sfa (broadcast-sfa command arg)
  (caseq command
    ((tyo)
     (do ((l (broadcast-sfa-l)))
	 ((null l))
       (+tyo arg (pop l))))
    ((print)
     (do ((l (broadcast-sfa-l)))
	 ((null l))
       (print arg (pop l))))
    ((princ)
     (do ((l (broadcast-sfa-l)))
	 ((null l))
       (princ arg (pop l))))
    ((prin1)
     (do ((l (broadcast-sfa-l)))
	 ((null l))
       (prin1 arg (pop l))))
    ((open)
     (do ((l (broadcast-sfa-l)))
	 ((null l))
       (open (pop l)))
     broadcast-sfa)
    ((close)
     (do ((l (broadcast-sfa-l)))
	 ((null l))
       (close (pop l))))
    ((which-operations)
     '(tyo print princ prin1 open close))
    (t
     (unknown-command command 'broadcast-sfa))))
    

;; Optimizations.

(DEFUN CALL0 (F)
  (FUNCALL (CAR F) F))
(DEFUN CALL1 (F A)
  (FUNCALL (CAR F) F A))
(DEFUN CALL2 (F A B)
  (FUNCALL (CAR F) F A B))
(DEFUN CALL3 (F A B C)
  (FUNCALL (CAR F) F A B C))
(DEFUN CALL4 (F A B C D)
  (FUNCALL (CAR F) F A B C D))
(DEFUN CALL5 (F A B C D E)
  (FUNCALL (CAR F) F A B C D E))

;; Specialized mapping functions 
;; CALL3 version.

(DEFUN CALL3-MAP2L (F A B C)
  (DO ()
      ((NULL B))
    (CALL F A (POP B) (POP C))))

(DEFUN CALL3-MAP2A (F A B C)
  (DO ((J 0 (1+ J))
       (N (ARRAY-DIMENSION-N 1 B)))
      ((= J N))
    (DECLARE (FIXNUM J N))
    (CALL F A (ARRAYCALL T B J) (ARRAYCALL T C J))))

(DEFUN CALL3-MAP2A$ (F A B C)
  (DO ((J 0 (1+ J))
       (N (ARRAY-DIMENSION-N 1 B)))
      ((= J N))
    (DECLARE (FIXNUM J N))
    (CALL F A (ARRAYCALL FLONUM B J) (ARRAYCALL FLONUM C J))))

(DEFUN CALL3-MAP2A% (F A B C)
  (DO ((J 0 (1+ J))
       (N (ARRAY-DIMENSION-N 1 B)))
      ((= J N))
    (DECLARE (FIXNUM J N))
    (CALL F A (ARRAYCALL FIXNUM B J) (ARRAYCALL FIXNUM C J))))

(DEFUN CALL3-MAP2-DISPATCH-WTA (M F A B C)
  (CALL3-MAP2-DISPATCH F A
		       (ERROR M B 'WRNG-TYPE-ARG)
		       C))

(DEFUN CALL3-MAP2-DISPATCH (F A B C)
  (IF (NOT (NULL B)) ; Stupid NIL is a SYMBOL.
      (CASEQ (TYPEP B)
	((FIXNUM FLONUM)
	 (CALL F A B C))
	((LIST)
	 (CALL3-MAP2L F A B C))
	((ARRAY)
	 (CASEQ (ARRAY-TYPE B)
	   ((T NIL)
	    (CALL3-MAP2A F A B C))
	   ((FLONUM)
	    (CALL3-MAP2A$ F A B C))
	   ((FIXNUM)
	    (CALL3-MAP2A% F A B C))
	   (T
	    (CALL3-MAP2-DISPATCH-WTA "Bad type of array to map over"
				     F A B C))))
	(T
	 (CALL3-MAP2-DISPATCH-WTA "Unknown type to MAP over" F A B C)))))

;; CALL5 version.

(DEFUN CALL5-MAP2L (F A B C D E)
  (DO ()
      ((NULL B))
    (CALL F A (POP B) (POP C) (POP D) (POP E))))

(DEFUN CALL5-MAP2A (F A B C D E)
  (DO ((J 0 (1+ J))
       (N (ARRAY-DIMENSION-N 1 B)))
      ((= J N))
    (DECLARE (FIXNUM J N))
    (CALL F A
	  (ARRAYCALL T B J)
	  (ARRAYCALL T C J)
	  (ARRAYCALL T D J)
	  (ARRAYCALL T E J))))

(DEFUN CALL5-MAP2A$ (F A B C D E)
  (DO ((J 0 (1+ J))
       (N (ARRAY-DIMENSION-N 1 B)))
      ((= J N))
    (DECLARE (FIXNUM J N))
    (CALL F A
	  (ARRAYCALL FLONUM B J)
	  (ARRAYCALL FLONUM C J)
	  (ARRAYCALL FLONUM D J)
	  (ARRAYCALL FLONUM E J))))

(DEFUN CALL5-MAP2A% (F A B C D E)
  (DO ((J 0 (1+ J))
       (N (ARRAY-DIMENSION-N 1 B)))
      ((= J N))
    (DECLARE (FIXNUM J N))
    (CALL F A
	  (ARRAYCALL FIXNUM B J)
	  (ARRAYCALL FIXNUM C J)
	  (ARRAYCALL FIXNUM D J)
	  (ARRAYCALL FIXNUM E J))))

(DEFUN CALL5-MAP2-DISPATCH-WTA (M F A B C D E)
  (CALL5-MAP2-DISPATCH F A
		       (ERROR M B 'WRNG-TYPE-ARG)
		       C D E))

(DEFUN CALL5-MAP2-DISPATCH (F A B C D E)
  (IF (NOT (NULL B)) ; Stupid NIL is a SYMBOL.
      (CASEQ (TYPEP B)
	((FIXNUM FLONUM)
	 (CALL F A B C D E))
	((LIST)
	 (CALL5-MAP2L F A B C D E))
	((ARRAY)
	 (CASEQ (ARRAY-TYPE B)
	   ((T NIL)
	    (CALL5-MAP2A F A B C D E))
	   ((FLONUM)
	    (CALL5-MAP2A$ F A B C D E))
	   ((FIXNUM)
	    (CALL5-MAP2A% F A B C D E))
	   (T
	    (CALL5-MAP2-DISPATCH-WTA "Bad type of array to map over"
				     F A B C D E))))
	(T
	 (CALL5-MAP2-DISPATCH-WTA "Unknown type to MAP over" F A B C D E)))))