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