-*- 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:;