mirror of
https://github.com/PDP-10/its.git
synced 2026-01-18 09:12:08 +00:00
132 lines
3.7 KiB
Common Lisp
132 lines
3.7 KiB
Common Lisp
;;;-*-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))))) |