1; SketchyLISP Example Program
2; Copyright (C) 2006,2007 Nils M Holm. All rights reserved.
3; See the file LICENSE of the SketchyLISP distribution
4; for conditions of use.
5
6; ---name---
7; draw-tree
8
9; ---language---
10; R5RS Scheme
11
12; ---purpose---
13; Draw a tree structure resembling a Scheme datum.
14
15; ---args---
16; N - object to draw
17
18; ---keywords---
19; DRAW-TREE function, tree, structurem, drawing
20
21; ---example---
22; (draw-tree '((a b) c (d . e))) => #<void>
23; ; Output:
24; ; [o|o]---[o|o]---[o|o]--- ()
25; ;  |       |       |
26; ;  |       c      [o|o]--- e
27; ;  |               |
28; ;  |               d
29; ;  |
30; ; [o|o]---[o|o]--- ()
31; ;  |       |
32; ;  a       b
33
34; (require "lib/if.scm")
35; (require "lib/letstar.scm") ; let*
36; (require "lib/substring.scm")
37; (require "lib/s-append.scm") ; string-append
38; (require "lib/s-length.scm") ; string-length
39; (require "lib/numtostr.scm") ; number->string
40; (require "lib/min.scm")
41; (require "lib/string.scm")
42; (require "lib/not.scm")
43; (require "lib/caar.scm") ; cadr
44; (require "lib/reverse.scm")
45; (require "lib/newline.scm")
46
47; ---code---
48; N marks empty slots in lists.
49(define N (cons 'N '()))
50
51(define nothing (let () (lambda () N)))
52
53(define (empty? x)
54  (eq? (nothing) x))
55
56; L marks partially processed lists.
57(define L (cons 'L '()))
58
59(define ls (let () (lambda () L)))
60
61(define (list-done? x)
62  (and (eq? (ls) (car x))
63       (null? (cdr x))))
64
65; Set to #t if you want [o|/] instead of [o|o]--- ()
66(define (brian) #f)
67
68(define (draw-string s)
69  (let* ((k (string-length s))
70         (s (if (> k 7) (substring s 0 7) s))
71         (s (if (< k 3) (string-append " " s) s))
72         (k (string-length s)))
73    (display (string-append s
74               (substring "        " 0
75                 (- 8 (min k 7)))))))
76
77(define (draw-atom n)
78  (cond ((null? n)
79      (draw-string "()"))
80    ((symbol? n)
81      (draw-string (symbol->string n)))
82    ((number? n)
83      (draw-string (number->string n)))
84    ((string? n)
85      (draw-string (string-append "\"" n "\"")))
86    ((char? n)
87      (draw-string (string-append "#\\" (string n))))
88    ((eq? n #t)
89      (draw-string "#t"))
90    ((eq? n #f)
91      (draw-string "#f"))
92    (else (bottom '(unknown type in draw-atom) n))))
93
94(define (draw-conses n)
95  (letrec
96    ((draw-c
97       (lambda (n)
98         (cond ((not (pair? n)) (draw-atom n))
99           (else (cond ((and (brian)
100                             (null? (cdr n)))
101                     (display "[o|/]"))
102                   (else (begin (display "[o|o]---")
103                                (draw-c (cdr n))))))))))
104    (begin (draw-c n)
105           (cons (ls) n))))
106
107(define (draw-bars n)
108  (cond ((not (pair? n)) '())
109    ((empty? (car n))
110      (begin (draw-string "")
111             (draw-bars (cdr n))))
112    ((and (pair? (car n)) (eq? (ls) (caar n)))
113      (begin (draw-bars (cdar n))
114             (draw-bars (cdr n))))
115    (else (begin (draw-string "|")
116                 (draw-bars (cdr n))))))
117
118(define (trim n)
119  (letrec
120    ((_trim
121       (lambda (n)
122         (cond ((null? n) '())
123           ((empty? (car n))
124             (_trim (cdr n)))
125           ((list-done? (car n))
126             (_trim (cdr n)))
127           (else (reverse n))))))
128    (_trim (reverse n))))
129
130(define (draw-objects n)
131  (letrec
132    ((draw-o
133       (lambda (n r)
134         (cond ((not (pair? n))
135             (trim (reverse r)))
136           ((empty? (car n))
137             (begin (draw-string "")
138                    (draw-o (cdr n)
139                            (cons (nothing) r))))
140           ((not (pair? (car n)))
141             (begin (draw-atom (car n))
142                    (draw-o (cdr n)
143                            (cons (nothing) r))))
144           ((null? (cdr n))
145             (draw-o (cdr n)
146                     (cons (draw-row (car n)) r)))
147           (else (begin (draw-string "|")
148                        (draw-o (cdr n)
149                                (cons (car n) r))))))))
150    (cons (ls) (draw-o (cdr n) '()))))
151
152(define (draw-row n)
153  (letrec
154    ((draw-r
155       (lambda (n r)
156         (cond ((null? n) (reverse r))
157           ((not (pair? (car n)))
158             (begin (draw-atom (car n))
159                    (draw-r (cdr n)
160                            (cons (nothing) r))))
161           ((eq? (ls) (caar n))
162             (draw-r (cdr n)
163                     (cons (draw-objects (car n))
164                           r)))
165           (else (draw-r (cdr n)
166                         (cons (draw-conses (car n))
167                               r)))))))
168    (car (draw-r (list n) '()))))
169
170(define (draw-tree n)
171  (letrec
172    ((draw-t
173       (lambda (n)
174         (cond ((list-done? n) '())
175           (else (begin (newline)
176                        (draw-bars (cdr n))
177                        (newline)
178                        (draw-t (draw-row n))))))))
179    (cond ((not (pair? n))
180        (begin (draw-atom n)
181               (newline)))
182      (else (begin (draw-t (draw-row n))
183                   (newline))))))
184