Added lots of new LSPLIB packages (and their sources).

src/graphs/graphs.102

@@ -0,0 +1,132 @@
+;;;-*-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)))))