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

src/graphs/close.42

@@ -0,0 +1,71 @@
+;;;-*-lisp-*-
+
+(herald closure)
+
+(eval-when (eval compile load)
+	   (cond ((status feature complr)
+		  (or (get 'closure-macros 'version)
+		      (load '((graphs)closem)))
+		  (*lexpr GCALL)
+		  (*expr make-closure))
+		 (t
+		  (mapc '(lambda (u) (putprop u '((graphs)closem) 'autoload))
+			'(open-GCALL self-GCALL defclosure make-closure-1)))))
+
+(DEFUN CLOSURE-SUBR-HOOK (X1 X2 X3 X4 X5)
+       ; this function MUST be compiled in order for the
+       ; system to work.
+       (FUNCALL (CLOSURE-NAME *SELF*) X1 X2 X3 X4 X5))
+				    
+(defun make-closure (name full-instance-vars full-instance-vals
+			  pre-instance-vars pre-instance-vals)
+       (let ((c
+	      (make-closure-1 name name
+			      subr-pointer (OR (get name 'subr)
+					       (GET 'CLOSURE-SUBR-HOOK 'SUBR)
+					       (ERROR "Can't hook" NAME))
+			      full-instance-vars full-instance-vars
+			      full-instance-vals full-instance-vals
+			      pre-instance-vars `(*self* ,@pre-instance-vars)
+			      pre-instance-vals pre-instance-vals)))
+	      (push c (closure-pre-instance-vals c))
+	      c))
+
+(defun GCALL (f &optional x1 x2 x3 x4 x5)
+       (open-GCALL f x1 x2 x3 x4 x5))
+
+(defvar traced-closure-msgfile tyo)
+(defvar traced-closure-linefeedp nil)
+
+(defclosure traced-closure (x1 x2 x3 x4 x5)
+	    ((level 0))
+	    (sub-closure)
+	    
+	    (setq level (1+ level))
+	    (setq traced-closure-linefeedp t)
+	    (format traced-closure-msgfile
+		    "~%~A ~A :~A ~:[~;<~A~:[>~;,~A~:[>~;,~A~:[>~;,~A>~]~]~]~]"
+		    (closure-name sub-closure)
+		    level
+		    x1 x2 x2 x3 x3 x4 x4 x5 x5)
+	    (let ((traced-closure-linefeedp nil))
+		 (setq x1 (GCALL sub-closure x1 x2 x3 x4 x5))
+		 (format traced-closure-msgfile
+			 "~:[~2*~;~%~A ~A~] =>~A"
+			 traced-closure-linefeedp
+			 (closure-name sub-closure)
+			 level
+			 x1))
+	    (setq level (1- level))
+	    x1)
+
+(defun make-traced-closure (sub-closure)
+       (make-traced-closure-closure () (sub-closure sub-closure)))
+
+(mapc '(lambda (u) (putprop u '((alan)dprint) 'autoload))
+      '(describe dprint))
+
+(defmap-self-GCALL fixnum 2)
+(defmap-self-GCALL fixnum 4)
+(defmap-self-GCALL flonum 2)
+(defmap-self-GCALL flonum 4)

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)))))

src/graphs/graphs.demo

@@ -0,0 +1,64 @@
+;;;-*-lisp-*-
+(comment)
+
+(progn 
+ (load '((gjc)gjc lisp))
+ (defaultf  '((dsk graphs)))
+
+ (load 'demo)
+ (setq prinlength 7)
+ (setq read-pause-time 0.1)
+
+ (cursorpos 'c tyo)
+ (format tyo 
+"This is a very short demo of graphics.
+To get the demo type (DEMO) which invokes the
+lisp function DEMO defined by this file.
+What you will see is a sequence of lisp forms
+which if you typed would have the effect that
+you see.
+")
+ (defun pause () (format tyo "~&-pause-") (cursorpos 'n))
+ (defun hpause () (cursorpos 'top) (pause))
+ (setq demo-forms
+       '((or (get 'plot 'version) (load 'plot))
+	 (comment "Set the input and output numeric radix to TEN.")
+	 (setq base 10. ibase 10.)
+	 (gcall graphic-stream 'open 'dsk '((graphs) demo ards))
+	 (comment "set the number of points.")
+	 (setq plotnum 200)
+	 (plot (times 3 x (cos (times 4 x)) (sin x)) x -5 5)
+	 (hpause)
+	 (plot sin -3.1416 3.1416)
+	 (pause)
+	 (comment "Or you can define a function.")
+	 (defun f1 (x) (*$ x x))
+	 (pause)
+	 (plot f1 -3 3)
+	 (pause)
+	 (comment "there is a nice function for making spirals")
+	 (defun sp (n m)
+		(draw-spiral graphic-stream 1.5 0.0 0.0 n m))
+	 (comment "use the auto-scaling of PLOT to set up the window.")
+	 (pause)
+	 (progn (plot x x -1 1) (sp 33 33))
+	 (hpause)
+	 (gcall graphic-stream 'cursorpos 'c)
+	 (sp 75. 3.)
+	 (hpause)
+	 (sp 75. 5.)
+	 (hpause)
+	 (comment " how about some 3d-graphics? ")
+	 (or (get 'plot3 'version) (load 'plot3))
+	 (gcall graphic-stream 'set-window -0.8 0.8 -0.8 0.8)
+	 (comment "set the euler angles. ")
+	 (gcall 3d-stream 'Set-theta -1.0)
+	 (gcall 3d-stream 'set-phi 0.1)
+	 (gcall 3d-stream 'set-psi 0.4)
+	 (gcall graphic-stream 'cursorpos 'c)
+	 (mobius 100 2)
+	 (hpause)
+	 (torus 100 10)
+	 (gcall graphic-stream 'close 'dsk)
+	 (comment "that is all. enjoy!")))
+ '*)

src/graphs/graphs.usage

@@ -0,0 +1,100 @@
+Date: 1 July 1980 14:57-EDT
+From: George J. Carrette <GJC at MIT-MC>
+To: "(FILE [GJC;GRAPHS USAGE])" at MIT-MC
+
+    Date: 1 July 1980 14:53-EDT
+    From: George J. Carrette <GJC at MIT-MC>
+    To: MEM at MIT-MC, JGA at MIT-MC
+    cc: "(FILE [FILE GJC;GRAPHS USAGE])" at MIT-MC
+
+
+    The generic functions are
+
+    set-pen, move-pen, vector-pen, draw-point, draw-line.
+
+    set-window, set-viewport, get-window, get-viewport.
+
+    The first argument to these functions is always a graphic object.
+    The rest of the arguments are always paired X,Y. e.g.
+    (set-pen foo x y) and (draw-line foo x1 y1 x2 y2).
+    The coordinate arguments can either be numbers, arrays of numbers,
+    or lists of numbers.
+
+    (make-ards-stream) makes you an ards-object.
+    (make-graphics-stream <ards-object>) takes an ards-object and returns
+    a flonum-scaling graphics stream.
+
+    Other operations are conviently accessed with the CALL function.
+
+    (call <stream> 'cursorpos 'c)
+    (call <stream> 'which-operations)
+    (call <stream> 'open 'tty)
+    (call <stream> 'open 'dsk '((foo) bar >))
+    (call <stream> 'close)
+
+    No compile-time considerations are needed when using the generic operators.
+    However, users of call should do (or (get 'closure 'version) (load '((gjc)close)))
+    at eval and compile times.
+
+
+
+ A graphics stream is a special object which these generic functions
+ can operate on. These objects keep an internal state, such as
+ the position of the last point plotted, and the values of the
+ scaling factors.
+
+ Loading GJC;GRAPHS FASL will make the the relevant functions
+ autoloading. Functions for hardware specific objects are in
+ different files.
+
+ See GRAPHZ DEMO for example usage.
+
+ (MAKE-ARDS-STREAM) returns an object which takes fixnum arguments
+ and outputs ARDs graphics codes to file or TTY objects which it
+ stores internaly. This is a primitive stream.
+
+ (MAKE-TEK-STREAM) is not yet implemented.
+
+ (MAKE-GRAPHICS-STREAM <OUTPUT-STREAM>) takes a primitive stream
+ as argument and returns a stream which can do floating point
+ scaling and clipping, and setting of windows and viewports.
+
+ (GRAPHICS-STREAM-OPEN <STREAM> <MODE> &OPTIONAL <ARG>)
+ <mode> is 'TTY or 'DSK. <arg> is the file name when opened
+ in 'DSK mode.
+
+ (GRAPHICS-STREAM-CLOSE <STREAM>) closes any DSK file.
+
+ (SET-PEN <GRAPHICS-STREAM> X Y)
+
+ (MOVE-PEN <GRAPHICS-STREAM> X Y) 
+ draws a line from the last point the new point.
+
+ (VECTOR-PEN <GRAPHICS-STREAM> X Y) does a relative move of the pen.
+
+ (DRAW-POINT <GRAPHICS-STREAM> X Y) draws a line of length 0.
+
+ (GRAPHICS-STREAM-TYO <STREAM> <ARG>) presently does a character
+ TYO. Does not try and enforce clipping. #\CR may cause lossage.
+ Line-drawing of characters and scaling may be supported in the
+ future.
+
+ The following are not supported in primitive graphic streams.
+
+ (SET-WINDOW <GRAPHIC-STREAM> X0 X1 Y0 Y1)
+ the window is the apparent flonum size.
+
+ (SET-VIEWPORT <GRAPHIC-STREAM> X0 X1 Y0 Y1)
+ The viewport is set in "hardware" or rather, primitive stream
+ dependant, fixnums.
+ The default values for these are usually reasonable, by definition.
+
+ (MAKE-GRAPHICS-SFA <GRAPHICS-STREAM>) takes a graphics stream
+ and returns and SFA which may be used as an argument to
+ PRINT, FORMAT, etc.
+
+ (MAKE-TRACED-FUNCTOR <FUNCTOR>) takes a functor (a graphics stream is
+ a functor) and returns a functor which is traced. Trace information
+ is output to the value of TRACED-FUNCTOR-MSGFILE which should NOT be
+ a stream which calls any traced functors! The returned functor is
+ not equal to the argument, i.e. the argument is not side effected.