mirror of
https://github.com/PDP-10/its.git
synced 2026-02-22 15:27:38 +00:00
315 lines
7.3 KiB
Common Lisp
Executable File
315 lines
7.3 KiB
Common Lisp
Executable File
;;;-*-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)))))
|
||
|