SketchyLISP Stuff | Copyright (C) 2006 Nils M Holm |
[ More Sketchy LISP Stuff ] |
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 () (lambda () N))) (define (empty? x) (eq? (nothing) x)) ; L marks partially processed lists. (define L (cons 'L '())) (define ls (let () (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)) (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 " " 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
[ More Sketchy LISP Stuff ] |