;;;-*-LISP-*-
;;; a package for graphics.
;;; 'graphics-stream' takes floating point coordinates, can do
;;; Scaling and clipping, and sends the resulting fixnums to
;;; a stream which presumably translates those into hardware commands.
;;; an example is the 'ards-stream' which of course can be used
;;; directly also. Other possible sub-streams include Tektronics,
;;; and pseudo-graphics (e.g. character display hacking)
;;; a possible super-stream to the 'graphics-stream' is one
;;; which takes 3 dimensional set-point and move-point messages
;;; and translates them to.

(herald graphs)

(eval-when (eval compile load)
	   (or (get 'closure 'version)
	       (load '((graphs)close))))

(defprop make-ards-stream ((dsk graphs) grapha fasl) autoload)
(defprop make-graphics-stream ((dsk graphs)graph$ fasl) autoload)
(mapc '(lambda (u) (putprop u '((dsk graphs)circle fasl) 'autoload))
      '(draw-circle draw-spiral))
(defprop make-clipping-stream ((dsk graphs) clip fasl) autoload)

(eval-when (compile load)
	   (cond ((status feature complr)
		  (*expr set-pen move-pen vector-pen draw-point
			 set-viewport get-viewport set-window get-window)
		  (*lexpr graphics-stream-close graphics-stream-open))))


;;; the generic graphics functions. these all take a closure argument
;;; and map over cannonical uniform structures.

(defun set-pen (f x y)
       (GCALL f 'set-pen x y))

(eval-when (compile eval)
	   (defmacro gen-maptest (u)
		     `(in-closure-env
		       f
		       (cond ((fixnum-configurationp x)
			      (fixnum-map-self-GCALL-2 ',u x y))
			     (t
			      (flonum-map-self-GCALL-2 ',u x y))))))

(defun move-pen (f x y) (gen-maptest move-pen))

(defun vector-pen (f x y)(gen-maptest vector-pen))

(defun draw-point (f x y)(gen-maptest draw-point))

(defun draw-line (f x1 y1 x2 y2)
       (in-closure-env
	f
	(cond ((fixnum-configurationp x1)
	       (fixnum-map-self-GCALL-4 'draw-line x1 y1 x2 y2))
	      (t
	       (flonum-map-self-GCALL-4 'draw-line x1 y1 x2 y2)))))

(defun fixnum-configurationp (x)
       (cond ((numberp x) (fixp x))
	     ((and x (atom x) (eq (typep x) 'array))
	      (eq (car (arraydims x)) 'fixnum))
	     (t
	      (or (null x) (fixp (car x))))))

(defun graphics-stream-close (f &optional mode)(GCALL f 'close mode))

(defun graphics-stream-tyo (f arg) (GCALL f 'tyo arg))

(defun graphics-stream-open (f &optional (mode 'tty) (name nil))
       (GCALL f 'open mode name))

(defun set-viewport (f x0 x1 y0 y1)
       (GCALL f 'set-viewport x0 x1 y0 y1))

(defun get-viewport (f)
       (GCALL f 'viewport))

(defun set-window (f x0 x1 y0 y1)
       (GCALL f 'set-window x0 x1 y0 y1))

(defun get-window (f)
       (GCALL f 'window))

(defun set-invisiblep (f flag)
       (GCALL f 'set-invisiblep flag))

(defun set-dottep (f flag)
       (GCALL 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)))



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

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

(defun graphics-sfa (sfa com arg)
       (caseq com
	      (tyo
	       (GCALL (graphics-sfa-out-stream sfa) 'tyo arg))
	      (open
	       (graphics-stream-open (graphics-sfa-out-stream sfa)
				     (cond ((atom arg) arg)
					   (t (car arg)))
				     (cond ((atom arg) nil)
					   (t (cadr arg)))))
	      (close
	       (graphics-stream-close (graphics-sfa-out-stream sfa)))
	      (which-operations
	       '(tyo open close))))


(defun operations-union (s1 s2)
       (do ()
	   ((null s1) s2)
	   (let ((elem (pop s1)))
		(or (memq elem s2)
		    (push elem s2)))))