mirror of
https://github.com/PDP-10/its.git
synced 2026-02-09 01:40:58 +00:00
150 lines
4.0 KiB
Common Lisp
Executable File
150 lines
4.0 KiB
Common Lisp
Executable File
;;;-*-LISP-*-
|
||
;;; A graphics utility package. - George Carrette.
|
||
|
||
;;; ARDS codes.
|
||
|
||
(eval-when (eval compile)
|
||
(or (get 'graphm 'version)
|
||
(load (list (car (namelist infile)) 'graphm))))
|
||
|
||
(graphs-module grapha)
|
||
|
||
;;; local declarations to eliminate fixnum consing.
|
||
|
||
(declare (fixnum (ards-basic-1 fixnum)
|
||
(ards-basic-2 fixnum))
|
||
(*expr (ards-mode-check-out nil fixnum)
|
||
(ards-basic-io fixnum fixnum fixnum fixnum)
|
||
(ards-basic-io-s fixnum fixnum)
|
||
(ards-set-point-out fixnum fixnum)
|
||
(ards-long-vector-out fixnum fixnum)
|
||
(ards-short-vector-out fixnum fixnum)
|
||
(ards-gen-vector fixnum fixnum)))
|
||
|
||
(defun ards-stream NARGS
|
||
(COMMENT (ARG 1) = ARDS-STREAM
|
||
(ARG 2) = COMMAND
|
||
(ARG 3) = X1
|
||
(ARG 4) = Y1
|
||
(ARG 5) = X2
|
||
(ARG 6) = Y2)
|
||
(LET ((ARDS-STREAM (ARG 1)))
|
||
(LET ((OUT-STREAM (ARDS-STREAM-OUT-STREAM))
|
||
(GRAPHIC-MODE (ARDS-STREAM-GRAPHIC-MODE))
|
||
(INVISIBLEP (ARDS-STREAM-INVISIBLEP))
|
||
(DOTTEDP (ARDS-STREAM-DOTTEDP))
|
||
(LAST-POS (ARDS-STREAM-LAST-POS)))
|
||
(caseq (ARG 2)
|
||
((move-pen)
|
||
(NARG-CHECK NARGS 4 'ARDS-STREAM)
|
||
(ards-gen-vector (- (ARG 3) (ards-last-pos-x last-pos))
|
||
(- (ARG 4) (ards-last-pos-y last-pos)))
|
||
(setf (ards-last-pos-x last-pos) (ARG 3))
|
||
(setf (ards-last-pos-y last-pos) (ARG 4))
|
||
t)
|
||
((vector-pen)
|
||
(NARG-CHECK NARGS 4 'ARDS-STREAM)
|
||
(ards-gen-vector (ARG 3) (ARG 4))
|
||
(setf (ards-last-pos-x last-pos)
|
||
(+ (ards-last-pos-x last-pos) (ARG 3)))
|
||
(setf (ards-last-pos-y last-pos)
|
||
(+ (ards-last-pos-y last-pos) (ARG 4)))
|
||
t)
|
||
((draw-point)
|
||
(NARG-CHECK NARGS 4 'ARDS-STREAM)
|
||
(CALL ards-stream 'set-pen (ARG 3) (ARG 4))
|
||
(CALL ards-stream 'vector-pen 0 0))
|
||
((draw-line)
|
||
(NARG-CHECK NARGS 6 'ARDS-STREAM)
|
||
(CALL ards-stream 'set-pen (ARG 3) (ARG 4))
|
||
(CALL ards-stream 'move-pen (ARG 5) (ARG 6)))
|
||
((set-pen)
|
||
(NARG-CHECK NARGS 4 'ARDS-STREAM)
|
||
(cond ((and (= (ARG 3) (ards-last-pos-x last-pos))
|
||
(= (ARG 4) (ards-last-pos-y last-pos))))
|
||
(t
|
||
(ards-mode-check-out 'set-point #/ )
|
||
(ards-set-point-out (ARG 3) (ARG 4))
|
||
(setf (ards-last-pos-x last-pos) (ARG 3))
|
||
(setf (ards-last-pos-y last-pos) (ARG 4))
|
||
t)))
|
||
((tyo)
|
||
(NARG-CHECK NARGS 3 'ARDS-STREAM)
|
||
(ards-gen-tyo (ARG 3)))
|
||
((SET-DOTTEDP)
|
||
(NARG-CHECK NARGS 3 'ARDS-STREAM)
|
||
(setf (ards-stream-dottedp) (ARG 3)))
|
||
((set-invisiblep)
|
||
(NARG-CHECK NARGS 3 'ARDS-STREAM)
|
||
(setf (ards-stream-invisiblep) (ARG 3)))
|
||
((boundaries)
|
||
(list (ards-stream-x-min)
|
||
(ards-stream-x-max)
|
||
(ards-stream-y-min)
|
||
(ards-stream-y-max)))
|
||
((which-operations)
|
||
(NARG-CHECK NARGS 2 'ARDS-STREAM)
|
||
'(tyo set-pen move-pen vector-pen draw-point
|
||
set-dottedp set-invisiblep size))
|
||
(t
|
||
(UNKNOWN-COMMAND (ARG 2) 'ARDS-STREAM))))))
|
||
|
||
(defun make-ards-stream (s)
|
||
(make-ards-stream-1 out-stream s))
|
||
|
||
(defun ards-mode-check-out (mode signal)
|
||
(when (not (eq graphic-mode mode))
|
||
(setq graphic-mode mode)
|
||
(setf (ards-stream-graphic-mode) mode)
|
||
(+tyo (+ signal #o200) OUT-STREAM)))
|
||
|
||
(defun ards-basic-1 (x)
|
||
(+ (lsh (logand (abs x) #o37) 1)
|
||
(if (minusp x) 1 0)
|
||
#o100))
|
||
|
||
(defun ards-basic-2 (x)
|
||
(+ (logand (lsh (abs x) #o-5) #o37) #o100))
|
||
|
||
(defun ards-basic-io (x1 x2 y1 y2)
|
||
(+tyo x1 OUT-STREAM)
|
||
(+tyo x2 OUT-STREAM)
|
||
(+tyo y1 OUT-STREAM)
|
||
(+tyo y2 OUT-STREAM))
|
||
|
||
(defun ards-basic-io-s (x1 y1)
|
||
(+tyo x1 OUT-STREAM)
|
||
(+tyo y1 OUT-STREAM))
|
||
|
||
|
||
(defun ards-set-point-out (x y)
|
||
(ards-basic-io (ards-basic-1 x)
|
||
(ards-basic-2 x)
|
||
(ards-basic-1 y)
|
||
(ards-basic-2 y)))
|
||
|
||
|
||
(defun ards-long-vector-out (x y)
|
||
(ards-basic-io (ards-basic-1 x)
|
||
(+ (ards-basic-2 x) (if invisiblep #o40 0))
|
||
(ards-basic-1 y)
|
||
(+ (ards-basic-2 y) (if dottedp #o40 0))))
|
||
|
||
(defun ards-short-vector-out (x y)
|
||
(ards-basic-io-s (ards-basic-1 x)
|
||
(ards-basic-1 y)))
|
||
|
||
(defun ards-gen-vector (x y)
|
||
(declare (fixnum x y))
|
||
(cond ((and (< (abs x) #o40) (< (abs y) #o40) (not invisiblep) (not dottedp))
|
||
(ards-mode-check-out 'short-vector #/ )
|
||
(ards-short-vector-out x y))
|
||
(t
|
||
(ards-mode-check-out 'long-vector #/ )
|
||
(ards-long-vector-out x y))))
|
||
|
||
(defun ards-gen-tyo (C)
|
||
(ards-mode-check-out nil #/ )
|
||
(tyo C OUT-STREAM))
|
||
|