draw-tree

Conformance: R5RS

Purpose: Draw a tree structure resembling a Scheme object.

Arguments:
N - object to draw

Implementation:

; N marks empty slots in lists.
(define N (cons 'N '()))

(define nothing (let ((N N)) (lambda () N)))

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

; L marks partially processed lists.
(define L (cons 'L '()))

(define ls (let ((L L)) (lambda () L)))

(define (list-done? x)
  (and (eq? (ls) (car x))
       (null? (cdr x))))

; Set to #t if you want [o|/] instead of [o|o]--- ()
(define (brian) #f)

(define (draw-string s)
  (let ((k (string-length s)))
    (let ((s (cond ((> k 7) (substring s 0 7))
                   (#t s))))
      (let ((s (cond ((< k 3) (string-append " " s))
                     (#t s))))
        (let ((k (string-length s)))
          (display (string-append s
                     (substring "        " 0
                       (- 8 (min k 7))))))))))

(define (draw-atom n)
  (cond ((null? n)
      (draw-string "()"))
    ((symbol? n)
      (draw-string (symbol->string n)))
    ((number? n)
      (draw-string (number->string n)))
    ((string? n)
      (draw-string (string-append "\"" n "\"")))
    ((char? n)
      (draw-string (string-append "#\\" (string n))))
    ((eq? n #t)
      (draw-string "#t"))
    ((eq? n #f)
      (draw-string "#f"))
    (#t (bottom '(unknown type in draw-atom) n))))

(define (draw-conses n)
  (letrec
    ((draw-c (lambda (n)
      (cond ((not (pair? n)) (draw-atom n))
        (#t (cond ((and (brian)
                        (null? (cdr n)))
                (display "[o|/]"))
              (#t (begin
                    (display "[o|o]---")
                    (draw-c (cdr n))))))))))
    (begin
      (draw-c n)
      (cons (ls) n))))

(define (draw-bars n)
  (cond ((not (pair? n)) '())
    ((empty? (car n))
      (begin
        (draw-string "")
        (draw-bars (cdr n))))
    ((and (pair? (car n)) (eq? (ls) (caar n)))
      (begin (draw-bars (cdar n))
             (draw-bars (cdr n))))
    (#t (begin
          (draw-string "|")
          (draw-bars (cdr n))))))

(define (trim n)
  (letrec
    ((_trim (lambda (n)
      (cond ((null? n) '())
        ((empty? (car n))
          (_trim (cdr n)))
        ((list-done? (car n))
          (_trim (cdr n)))
        (#t (reverse n))))))
    (_trim (reverse n))))

(define (draw-objects n)
  (letrec
    ((draw-o (lambda (n r)
      (cond ((not (pair? n))
          (trim (reverse r)))
        ((empty? (car n))
          (begin
            (draw-string "")
            (draw-o (cdr n)
                    (cons (nothing) r))))
        ((not (pair? (car n)))
          (begin
            (draw-atom (car n))
            (draw-o (cdr n)
                    (cons (nothing) r))))
        ((null? (cdr n))
          (draw-o (cdr n)
                  (cons (draw-row (car n)) r)))
        (#t (begin
              (draw-string "|")
              (draw-o (cdr n)
                      (cons (car n) r))))))))
    (cons (ls) (draw-o (cdr n) '()))))

(define (draw-row n)
  (letrec
    ((draw-r (lambda (n r)
      (cond ((null? n) (reverse r))
        ((not (pair? (car n)))
          (begin
            (draw-atom (car n))
            (draw-r (cdr n)
                    (cons (nothing) r))))
        ((eq? (ls) (caar n))
          (draw-r (cdr n)
                  (cons (draw-objects (car n))
                        r)))
        (#t (draw-r (cdr n)
                    (cons (draw-conses (car n))
                          r)))))))
    (car (draw-r (list n) '()))))

(define (draw-tree n)
  (letrec
    ((draw-t (lambda (n)
      (cond ((list-done? n) '())
        (#t (begin
              (newline)
              (draw-bars (cdr n))
              (newline)
              (draw-t (draw-row n))))))))
    (cond ((not (pair? n))
        (begin
          (draw-atom n)
          (newline)))
      (#t (begin
            (draw-t (draw-row n))
            (newline))))))

Example:

(draw-tree '((a b) c (d . e))) => #<void>
; Output:
; [o|o]---[o|o]---[o|o]--- ()     
;  |       |       |      
;  |       c      [o|o]--- e      
;  |               |      
;  |               d      
;  |      
; [o|o]---[o|o]--- ()     
;  |       |      
;  a       b