Scheme (Lisp dialect) module for drawing trees

draw-tree.scm

(module draw-tree mzscheme
  (require (lib "class.ss")
           (lib "mred.ss" "mred"))

; -------------------------------------------------------------
; Draws a tree of lists downwards from given coordinates on
; given MrEd device context, possibly with customized
; visualization options.
;
; Examples:
;
;  (draw-tree '("+" 1 ("*" ("/" 2 3) "a")) 320 20 dc '(node-spacing-y 40))
;  (draw-tree '("animal" "elephant" ("insect" "bee" "fly")) 320 20 dc))
;
; Written by Jarno Elonen <elonen@iki.fi>, 2003
; Released in Public Domain.
; -------------------------------------------------------------
(define (draw-tree tree x y dc . options )

  ; Default settings, overrideable through "options"
  (define node-spacing-x 10)
  (define node-spacing-y 20)
  (define node-padding 5)
  (define node-corner-radius 8)
  (define arc-curvature 0.75) ; from 0=concave, 0.5=straight, 1=convex

  ; Creates a drawable boxed string object
  (define (make-text-box str)
    (define x 0)
    (define y 0)
    (define text str)
    (let-values (((width height bot-dist top-dist)
                  (send dc get-text-extent text)))
      (lambda (m)
        (let ((txt-top (- y (/ height 2)))
              (txt-left (- x (/ width 2))))
          (define (bounds)
            (list (- txt-left node-padding) (- txt-top node-padding)
                  (+ width (* node-padding 2)) (+ height (* node-padding 2))))
          (cond ((eq? m 'draw)
                 (lambda (dc)
                   (send dc draw-text text txt-left txt-top)
                   (send dc draw-rounded-rectangle
                         (car (bounds)) (cadr (bounds))
                         (caddr (bounds)) (cadddr (bounds))
                         node-corner-radius)))
                ((eq? m 'move!)
                 (lambda (new-x new-y)
                   (set! x new-x)
                   (set! y new-y)))
                ((eq? m 'bounds) (bounds))
                (else error "Unknown message: " m))))))

  ; Calculates the width and height of given (sub)tree
  (define (tree-size tree)
    (if (list? tree)
        (let ((w (- node-spacing-x)) (h 0))
          (for-each
           (lambda (x)
             (let ((cs  (tree-size x)))
               (set! w (+ w (car cs) node-spacing-x))
               (set! h (max h (cadr cs)))
               ))
           (cdr tree))
          (list (max w (car (tree-size (car tree))))
                (+ h node-spacing-y (cadr (tree-size (car tree))))))
        (list (caddr (tree 'bounds))
              (cadddr (tree 'bounds)))))

  ; Draws a tree of boxed string objects
  (define (draw-text-box-tree tree x y dc)
    (if (list? tree)
        (begin
          (if (list? (car tree))
              (error "The root of any subtree must not be a list. "))
          (let ((size (tree-size tree))
                (root (car tree))
                (rx x) (ry y)
                (root-size (cddr ((car tree) 'bounds))))
            (draw-text-box-tree root x y dc)
            (set! x (- x (/ (car size) 2)))
            (for-each
             (lambda (child)
               (let ((cs (tree-size child))
                     (cx (+ x (/ (car(tree-size child)) 2)))
                     (cy (+ y (cadr root-size) node-spacing-y))
                     (child-root-size
                      ((if (list? child) (car child) child) 'bounds)))
                 (draw-text-box-tree child cx cy dc)
                 (let ((root-bott (+ ry (/ (cadr root-size) 2)))
                       (child-top (- cy (/ (cadddr child-root-size) 2))))
                   (send dc draw-spline
                         rx
                         root-bott
                         (+ rx (* (- cx rx) arc-curvature))
                         (+ root-bott (* (- child-top root-bott) (- 1 arc-curvature)))
                         cx
                         child-top))
                 (set! x (+ x (car (tree-size child)) node-spacing-x))))
             (cdr tree))))
        (begin
          ((tree 'move!) x y)
          ((tree 'draw) dc))))

  ; Convert given object to string - extend this!
  (define (to-string x)
    (cond ((string? x) x)
          ((char? x) (list->string (list x)))
          ((number? x) (number->string x))
          (else (error "Doesn't know how to convert to string: " x))))

  ; Creates an equivalent text box tree from given generic tree
  (define (make-text-box-tree tree)
    (map (lambda (x)
           (if (list? x)
               (make-text-box-tree x)
               (make-text-box (to-string x))))
         tree))

  ; Walk through the (possible) options
  (for-each
   (lambda (x)
     (if (and (list? x) (not (null? (cdr x))) (number? (cadr x)))
         (let ((name (car x)) (val (cadr x)))
           (cond ((eq? name 'node-spacing-x)
                  (set! node-spacing-x val))
                 ((eq? name 'node-spacing-y)
                  (set! node-spacing-y val))
                 ((eq? name 'node-padding)
                  (set! node-padding val))
                 ((eq? name 'node-corner-radius)
                  (set! node-corner-radius val))
                 ((eq? name 'arc-curvature)
                  (set! arc-curvature val))
                 (else (error "Unknown option: " name))))
         (error "Bad option '" x "'. Should be '(<option> <number>)")))
   options)

  ; Do the drawing
  (draw-text-box-tree (make-text-box-tree tree) x y dc))

(provide draw-tree))