;;;BTREE.LSP Reini Urban, Graz 1995
;;; You wanted a pretty printer for a binary tree in AutoLisp?
;;; Of course it's possible but I cannot think of any practical use, so
;;; I assume that you are familiar with Common Lisp, and want to know if
;;; AutoLisp (as a crippled brother) can do this. So here it is!
;;; (You could load it into XLisp 1.6 too, but redefine the C: functions
;;; and use let for the local symbols)
;;;
;;; Input:
;;; TreeList={{a},{{b},{c,{{d},{e}}}}}
;;;
;;; Output:
;;;
;;; a
;;; b c
;;; d e
;;;
;;; In Lisp notation:
;;; (a ((b) (c ((d) (e)))))
;;; the first approach is to convert the tree structure to a simple queue
;;; as in a depth- or breath-first search
;;; (a ((b) (c ((d) (e))))) -> ((a)(b c)(nil nil d e))
;;; start with: (traverse1 tree nil 0)
;;; returns the queue according to the wanted depth
(defun traverse1 (tree queue depth)
(cond ((= depth (length queue)) ;only dive into depth
(list (car tree)))
(T (append (traverse1 (caadr tree) ;simplified for binary trees
(append queue (list (car tree)))
depth)
(traverse1 (cadadr tree)
(append queue (list (car tree)))
depth)))))
;;; Do an iterative breath-first traversion
;;; (here easier than recursion or a mapcar)
;;; Append the results of each depth, starting with 0
;;;
;;; Of course this implementation is not optimal at all,
;;; you traverse the head nodes for every single depth again and again,
;;; but this way it's a very easy recursive algorithm. Otherwise you had
;;; to use a priority queue, with the property VISITED.
;;; It's only a simple tree. You have no room at your screen for deep
;;; trees anyway.
;;;
;;; Note: In AutoLisp there is no (let), but you can define
;;; local symbols after a slash '/' in the argument list.
;;; Note: There is no special '# (function ..) macro.
;;; (except with the additional Lispcompiler)
(defun traverse (tree / lst depth)
(setq depth 0 lst nil tst '(1))
(while (apply 'or tst) ;continue till there are only nil's in tst
(setq tst (traverse1 tree nil depth))
;;since there is no (do) in AutoLisp you have to test it twice
(if (apply 'or tst)
(setq lst (append lst (list tst))))
(setq depth (1+ depth))
)
lst
)
;;; Second print the queue with the right indentation.
;;; Assume only one char per symbol.
;;; Otherwise it gets hairy, see (print-tree1)
(defun print-tree (tree / queue maxlev)
(setq queue (traverse tree))
(setq maxlev (length (last queue)))
(foreach lst queue
(n-spaces maxlev) ;first spaces
(foreach symb lst
(princ (if symb symb " ")) ;space for nil
(n-spaces (1- (* 2 maxlev))) ;intermediate spaces
)
(setq maxlev (/ maxlev 2))
(terpri)
)
(princ)
)
(defun n-spaces (n) (repeat n (princ " ")))
(setq tree1 '(a ((b) (c ((d) (e))))))
(defun C:TEST1 ()
(print-tree tree1))
;;; That's it basically!
;;; If you want more than binary trees, eg. graphs,
;;; the traverse function will get a bit more complicated.
;;; AutoLisp knows no (setf (get ...)) form, so you cannot store links
;;; in property lists as stated in Winston-Horn.
;;; Furtheron the tree must be better formatted for symbols
;;; longer than one char. (quite tricky)
;;;*******************************************
;;; now with more than one char per symbol
(defun print-tree-better (tree / queue maxsymlen maxlinelen)
(setq queue (traverse tree))
;;maximal symbol-length in tree
(setq maxsymlen (apply 'max
(mapcar 'max-symlen queue)))
;;length of the last line
(setq maxlinelen (* (1+ maxsymlen) (length (last queue))))
(foreach lst queue
(n-spaces (/ maxlinelen 2))
(foreach symb lst
(princ (if symb symb " "))
;; 0: - 8 1
;; 1: - 4 1
;; 2: - 2 1
(n-spaces (- maxlinelen (strlen (symstr symb)))) ;there's bug, but where?
)
(setq maxlinelen (/ maxlinelen 2))
(terpri)
)
(princ)
)
;;; maximal symbol-length in list
(defun max-symlen (l)
(apply 'max
(mapcar
'(lambda (s) (if s (strlen (symstr s)) 1))
l)))
;;; A problem in AutoLisp is to convert symbols to strings :)
;;; Not the fastest, but the only way!
(defun symstr (symb / f str tmp)
(setq tmp "$temp.ac$")
(setq f (open tmp "w"))(princ symb f) (close f)
(setq f (open tmp "r") str (read-line f) f (close f))
str
)
;;;***************************************************************
;;; A few test trees and functions:
(setq tree1 '(a ((b) (c ((d) (e))))))
(setq tree2 '(a ((a1) (a2 ((a21 ((a211) (a212))) (a22))))))
(defun C:TEST1A ()
(traverse1 tree1 nil (getint "Depth: ")))
(defun C:TEST1B ()
(traverse tree1))
(defun C:TEST1 ()
(print-tree tree1))
(defun C:TEST2a ()
(traverse1 tree2 nil (getint "Depth: ")))
(defun C:TEST2b ()
(traverse tree2))
(defun C:TEST2 ()
(print-tree-better tree2))