mirror of
https://github.com/PDP-10/its.git
synced 2026-04-05 13:41:09 +00:00
342 lines
8.9 KiB
Common Lisp
Executable File
342 lines
8.9 KiB
Common Lisp
Executable File
-*- Mode:LISP; -*-
|
||
|
||
(herald TREEPR)
|
||
|
||
(declare (special *terminal-horizontal-size*
|
||
*terminal-vertical-size*)
|
||
(*expr clear-screen)
|
||
(*lexpr output recorded-read query))
|
||
|
||
(defvar *old-list* nil)
|
||
(defvar *form-map* nil)
|
||
(defvar *sfa* nil)
|
||
(defvar *error-print-flag* nil)
|
||
|
||
(defun display-list-doc ()
|
||
(output
|
||
"~2&The function /"DISPLAY-LIST/" is used to display the tree representation
|
||
of a list. If it is given an argument, it takes the value of that argument and
|
||
displays it for you. If no argument is given, it will offer to redisplay the
|
||
last argument you gave to DISPLAY-LIST (this option is selected by typing NIL
|
||
at that point) or it will accept a new list to display.~%"))
|
||
|
||
;;; *FORM-MAP* is left set from the last time this was invoked,
|
||
;;; so if DISPLAY-LIST is called with no args and it's not the
|
||
;;; first time it's been called, the last list shown can be reshown.
|
||
|
||
|
||
(declare (*lexpr display-list))
|
||
|
||
(defun display-list-no-arg ()
|
||
(cond ((and *old-list* *form-map*
|
||
(query "The last list you looked at was:~
|
||
~2% ~N~
|
||
~2%Shall I redisplay it for you?"
|
||
*old-list*))
|
||
(clear-screen)
|
||
(display))
|
||
(t (output "~&Type in a list: ")
|
||
(let ((list (recorded-read)))
|
||
(cond ((memq list '(? help))
|
||
(if (query "That's not a list! Want help?")
|
||
(display-list-doc)))
|
||
((and (not (atom list))
|
||
(eq (car list) 'quote))
|
||
(output
|
||
"~2&Don't bother to quote it. That makes it look messy...~
|
||
~%I'll pretend you didn't use quote.~%")
|
||
(display-list (cadr list)))
|
||
(t
|
||
(display-list list)))))))
|
||
|
||
|
||
(defun display-list (&optional (form nil form?))
|
||
(cond ((not form?)
|
||
(display-list-no-arg))
|
||
((not form)
|
||
(output
|
||
"~2&NIL, or (), is a special thing to Maclisp. It is both an atom ~
|
||
~%and an empty list. The CAR and CDR of NIL are both NIL! NIL is ~
|
||
~%also the false thing in Maclisp. In truth-value tests, anything ~
|
||
~%that is not NIL is true.~%"))
|
||
((atom form)
|
||
(cond ((memq form '(? help))
|
||
(if (query "That's not a list! Want help?")
|
||
(display-list-doc)))
|
||
(t (output "~&~S is not a list!~%" form))))
|
||
((eq (car form) 'quote)
|
||
(output
|
||
"~2&Don't bother to quote it. That makes it look messy...~
|
||
~%I'll pretend you didn't use quote.~%")
|
||
(display-list (cadr form)))
|
||
((make-display-array form t)
|
||
(clear-screen)
|
||
(display))
|
||
(t form)))
|
||
|
||
|
||
;;; Figure out how much space printing the input will take and return NIL if
|
||
;;; it's too big for the terminal. *ERROR-PRINT-FLAG* says whether this program
|
||
;;; should take care of error messages or if the calling program will.
|
||
|
||
(defun plot-mistake (message)
|
||
(if *error-print-flag*
|
||
(progn (output "~2&I'm afraid that won't fit on your terminal.~%")
|
||
(output message)))
|
||
nil)
|
||
|
||
(defun abort-make-display (&rest stuff)
|
||
(setq *form-map* nil)
|
||
(lexpr-funcall #'plot-mistake stuff)
|
||
(*throw '*make-display-array-tag* nil))
|
||
|
||
(defun make-display-array (form *error-print-flag*)
|
||
(*catch '*make-display-array-tag*
|
||
(setq *form-map*
|
||
(let ((*form-map*
|
||
(*array nil t
|
||
(// *terminal-horizontal-size* 5.)
|
||
(// *terminal-vertical-size* 12.))))
|
||
(plot form 0 0 *error-print-flag*)
|
||
(setq *old-list* form)
|
||
*form-map*))))
|
||
|
||
|
||
;;; Selector functions for *FORM-MAP*
|
||
|
||
(defun vertical-dimension ()
|
||
(caddr (arraydims *form-map*)))
|
||
|
||
(defun horizontal-dimension ()
|
||
(cadr (arraydims *form-map*)))
|
||
|
||
(defun call-form-map (x y)
|
||
(arraycall t *form-map* x y))
|
||
|
||
(defun store-form-map (x y val)
|
||
(store (arraycall t *form-map* x y) val))
|
||
|
||
(defun plot (form x y *error-print-flag*)
|
||
(if (= y (vertical-dimension))
|
||
(abort-make-display "try something that isn't so long.~%"))
|
||
(store-form-map x y form)
|
||
(cond ((atom (cdr form)) nil)
|
||
(t (plot (cdr form) x (1+ y) *error-print-flag*)))
|
||
(cond ((atom (car form)) nil)
|
||
(t (plot (car form)
|
||
(downp (car form) (1+ x) y *error-print-flag*)
|
||
y
|
||
*error-print-flag*))))
|
||
|
||
(defun downp (form x y *error-print-flag*)
|
||
(if (= x (horizontal-dimension))
|
||
(abort-make-display "try something with fewer nested parentheses.~%"))
|
||
(do ((f form (cdr f))
|
||
(j y (1+ j)))
|
||
((atom f) x)
|
||
(if (= j (vertical-dimension))
|
||
(abort-make-display "try something with shorter lists in it.~%"))
|
||
(if (call-form-map x j)
|
||
(progn (store-form-map x y 0.)
|
||
(return (downp form (1+ x) y *error-print-flag*))))))
|
||
|
||
|
||
;;; Main routine for printing *FORM-MAP*
|
||
|
||
(defun display ()
|
||
(let ((*sfa*))
|
||
(setq *sfa* (sfa-create 'sfa-handler 3 'foo))
|
||
(sfa-call *sfa* 'init ())
|
||
(arrayprint)
|
||
(close *sfa*)
|
||
(call-form-map 0 0)))
|
||
|
||
(defun arrayprint ()
|
||
(let ((*error-print-flag* nil)
|
||
(width (vertical-dimension))
|
||
(length (horizontal-dimension)))
|
||
(do ((i 0 (1+ i)))
|
||
((or *error-print-flag* (= i length)))
|
||
(setq *error-print-flag* t)
|
||
(do ((j 0 (1+ j)))
|
||
((= j width))
|
||
(cond ((null (call-form-map i j)) nil)
|
||
(t (setq *error-print-flag* nil)
|
||
(sfa-cursorpos (* 5 i) (* 12. j))
|
||
(print-cons (call-form-map i j)
|
||
(* 5 i) (* 12. j))))))))
|
||
|
||
(defmacro dimens ()
|
||
`(sfa-get self 0.))
|
||
|
||
(defmacro y-coord ()
|
||
`(sfa-get self 1.))
|
||
|
||
(defmacro x-coord ()
|
||
`(sfa-get self 2.))
|
||
|
||
(defun sfa-handler (self op data)
|
||
(caseq op (which-operations '(init cursorpos close tyo))
|
||
(init (setf (dimens) (array nil fixnum
|
||
*terminal-horizontal-size*
|
||
(1- *terminal-vertical-size*)))
|
||
(setf (y-coord) 0.)
|
||
(setf (x-coord) 0.))
|
||
(cursorpos (cond ((equal data '(b))
|
||
(setf (x-coord) (1- (x-coord))))
|
||
((equal data '(d))
|
||
(setf (y-coord) (1+ (y-coord))))
|
||
(t (setf (y-coord) (car data))
|
||
(setf (x-coord) (cadr data)))))
|
||
(tyo (store (arraycall fixnum (dimens)
|
||
(y-coord) (x-coord))
|
||
data)
|
||
(setf (x-coord) (1+ (x-coord))))
|
||
(close (let ((width (caddr (arraydims (dimens))))
|
||
(length (cadr (arraydims (dimens))))
|
||
(c nil)
|
||
(*error-print-flag* nil))
|
||
(do ((i 0 (1+ i)))
|
||
((or (= i length) *error-print-flag*))
|
||
(setq *error-print-flag* t)
|
||
(do ((j 0 (1+ j)))
|
||
((= j width))
|
||
(setq c (arraycall fixnum
|
||
(dimens)
|
||
i j))
|
||
(cond ((zerop c) (tyo #\space tyo))
|
||
(t (setq *error-print-flag* nil)
|
||
(tyo c tyo))))
|
||
(terpri))))))
|
||
|
||
|
||
;;; Functions for writing to the sfa and for printing standard pieces
|
||
;;; of a list.
|
||
|
||
(defun sfa-output (&rest stuff)
|
||
(lexpr-funcall #'format *sfa* stuff))
|
||
|
||
(defun sfa-cursorpos (x y) (cursorpos x y *sfa*))
|
||
|
||
(defun sfa-cursor-down-and-back ()
|
||
(cursorpos 'd *sfa*)
|
||
(cursorpos 'b *sfa*))
|
||
|
||
(defun print-vertical-bar () (sfa-output "/|"))
|
||
|
||
(defun print-horizontal-arrow () (sfa-output " --+-->"))
|
||
|
||
;;; PRINT-CELL-TOP outputs the following:
|
||
;;;
|
||
;;; |---|---|
|
||
|
||
(defun print-cell-top () (sfa-output"/|---/|---/|"))
|
||
|
||
;;; PRINT-NIL outputs the following:
|
||
;;;
|
||
;;; / |
|
||
;;; assuming the front of the NIL cell has already been printed.
|
||
|
||
(defun print-nil () (sfa-output " // /|"))
|
||
|
||
;;; PRINT-VERTICAL-ARROW outputs the following:
|
||
;;;
|
||
;;; |
|
||
;;; |
|
||
;;; |
|
||
;;; |
|
||
;;; v
|
||
|
||
(defun print-vertical-arrow ()
|
||
(sfa-output " /|")
|
||
(do ((i 0 (+ i 1)))
|
||
((= i 3))
|
||
(sfa-cursor-down-and-back)
|
||
(sfa-output "/|"))
|
||
(sfa-cursor-down-and-back)
|
||
(sfa-output "v"))
|
||
|
||
;;; PRINT-TREE outputs the following:
|
||
;;;
|
||
;;; |---|---|
|
||
;;; | | |
|
||
;;; |---|---|
|
||
;;; |
|
||
;;; v
|
||
|
||
(defun print-tree (x y)
|
||
(print-cell-top)
|
||
(sfa-cursorpos (+ x 2) y)
|
||
(print-cell-top)
|
||
(sfa-cursorpos (+ x 3) (+ y 2))
|
||
(print-vertical-bar)
|
||
(sfa-cursorpos (+ x 4) (+ y 2))
|
||
(sfa-output "v")
|
||
(sfa-cursorpos (+ x 1) y)
|
||
(sfa-output "/| /| /|"))
|
||
|
||
;;; PRINT-SINGLE-CELL outputs the following:
|
||
;;;
|
||
;;; |---|---|
|
||
;;; | A |
|
||
;;; |---|---|
|
||
;;;
|
||
;;; with the assumption that fix-atom-name has appropriately truncated
|
||
;;; or padded A.
|
||
|
||
(defun print-single-cell (a x y)
|
||
(print-cell-top)
|
||
(sfa-cursorpos (+ x 2) y)
|
||
(print-cell-top)
|
||
(sfa-cursorpos (+ x 1) y)
|
||
(print-vertical-bar)
|
||
(sfa-output (fix-atom-name a))
|
||
(print-vertical-bar))
|
||
|
||
|
||
(defun print-cons (form i j)
|
||
(cond ((numberp form) (print-vertical-arrow))
|
||
((atom (car form))
|
||
(print-single-cell (car form) i j)
|
||
(print-which-cdr (cdr form)))
|
||
(t (print-tree i j)
|
||
(print-which-cdr (cdr form)))))
|
||
|
||
(defun print-which-cdr (a)
|
||
(cond ((null a)
|
||
(print-nil))
|
||
((atom a)
|
||
(print-cdr a))
|
||
(t (print-horizontal-arrow))))
|
||
|
||
|
||
(defun print-cdr (a)
|
||
(sfa-output (fix-atom-name a))
|
||
(print-vertical-bar))
|
||
|
||
|
||
;;; Takes an atom and makes it exactly 3 chars long. This means that if
|
||
;;; the atom is longer than 3 chars, it is truncated. Otherwise, 1 or 2
|
||
;;; " "'s are added to it.
|
||
|
||
(defun fix-atom-name (x)
|
||
(implode
|
||
(do ((l (explodec x) (cdr l))
|
||
(nl () (cons (car l) nl))
|
||
(i 0. (1+ i)))
|
||
((> i 2.)
|
||
(if l (output "~&[Note that your long atom names have been ~
|
||
truncated for prettier display.]~2%"))
|
||
(nreverse nl))
|
||
(and (null l)
|
||
(return (cond ((= i 2.)
|
||
(cons " " (nreverse nl)))
|
||
(t (cons " "
|
||
(nreverse (cons " " nl))))))))))
|
||
|
||
|
||
;;; Local Modes:;
|
||
;;; Mode:LISP;
|
||
;;; Comment Column:50;
|
||
;;; End:;
|