# `draw-tree`

Location: contrib, 134 Lines

```; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2009-2012
; Placed in the Public Domain
;
; (draw-tree object)  ==>  unspecific
; (dt)                ==>  unspecific
;
; Print a tree structure resembling a Scheme datum. Each cons
; cell is represented by [o|o] with lines leading to their car
; and cdr parts. Conses with a cdr value of () are represented
; by [o|/].
;
; DT is an abbrevation for DRAW-TREE.
;
; (Example): (draw-tree '((a) (b . c) (d e)))  ==>  unspecific
;
;            Output:  [o|o]---[o|o]---[o|/]
;                      |       |       |
;                     [o|/]    |      [o|o]---[o|/]
;                      |       |       |       |
;                      a       |       d       e
;                              |
;                             [o|o]--- c
;                              |
;                              b

(define (draw-tree n)

(define *nothing* (cons 'N '()))

(define *visited* (cons 'V '()))

(define (empty? x) (eq? x *nothing*))

(define (visited? x) (eq? (car x) *visited*))

(define (mark-visited x) (cons *visited* x))

(define (members-of x) (cdr x))

(define (done? x)
(and (pair? x)
(visited? x)
(null? (cdr x))))

(define (draw-fixed-string s)
(let* ((b (make-string 8 #\space))
(k (string-length s))
(s (if (> k 7) (substring s 0 7) s))
(s (if (< k 3) (string-append " " s) s))
(k (string-length s)))
(display (string-append s (substring b 0 (- 8 k))))))

(define (draw-atom n)
(cond ((null? n)
(draw-fixed-string "()"))
((symbol? n)
(draw-fixed-string (symbol->string n)))
((number? n)
(draw-fixed-string (number->string n)))
((string? n)
(draw-fixed-string (string-append "\"" n "\"")))
((char? n)
(draw-fixed-string (string-append "#\\" (string n))))
((eq? n #t)
(draw-fixed-string "#t"))
((eq? n #f)
(draw-fixed-string "#f"))
(else
(error "draw-atom: unknown type" n))))

(define (draw-conses n)
(let draw-conses ((n n)
(r '()))
(cond ((not (pair? n))
(draw-atom n)
(reverse! r))
((null? (cdr n))
(display "[o|/]")
(reverse! (cons (car n) r)))
(else
(display "[o|o]---")
(draw-conses (cdr n) (cons (car n) r))))))

(define (draw-bars n)
(let draw-bars ((n (members-of n)))
(cond ((not (pair? n)))
((empty? (car n))
(draw-fixed-string "")
(draw-bars (cdr n)))
((and (pair? (car n))
(visited? (car n)))
(draw-bars (members-of (car n)))
(draw-bars (cdr n)))
(else
(draw-fixed-string "|")
(draw-bars (cdr n))))))

(define (skip-empty n)
(if (and (pair? n)
(or (empty? (car n))
(done? (car n))))
(skip-empty (cdr n))
n))

(define (remove-trailing-nothing n)
(reverse (skip-empty (reverse n))))

(define (all-vertical? n)
(or (not (pair? n))
(and (null? (cdr n))
(all-vertical? (car n)))))

(define (draw-members n)
(let draw-members ((n (members-of n))
(r '()))
(cond ((not (pair? n))
(mark-visited
(remove-trailing-nothing
(reverse r))))
((empty? (car n))
(draw-fixed-string "")
(draw-members (cdr n)
(cons *nothing* r)))
((not (pair? (car n)))
(draw-atom (car n))
(draw-members (cdr n)
(cons *nothing* r)))
((null? (cdr n))
(draw-members (cdr n)
(cons (draw-final (car n)) r)))
((all-vertical? (car n))
(draw-fixed-string "[o|/]")
(draw-members (cdr n)
(cons (caar n) r)))
(else
(draw-fixed-string "|")
(draw-members (cdr n)
(cons (car n) r))))))

(define (draw-final n)
(cond ((not (pair? n))
(draw-atom n)
*nothing*)
((visited? n)
(draw-members n))
(else
(mark-visited (draw-conses n)))))

(if (not (pair? n))
(draw-atom n)
(let draw-tree ((n (mark-visited (draw-conses n))))
(if (not (done? n))
(begin (newline)
(draw-bars n)
(newline)
(draw-tree (draw-members n))))))
(newline))

(define dt draw-tree)
```