home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p1 / Examples / tree.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  9.3 KB  |  220 lines  |  [TEXT/gamI]
  1. ; Graphical display of trees (on a text oriented output device)
  2. ;
  3. ; try: (tree-display '((the dog) ate (the cat)))
  4.  
  5. (define (tree-display tree . optional)
  6.  
  7.   ; how many space characters between branches of tree
  8.   (define tree-spacing 1)
  9.  
  10.   ; print tree with all leaves at bottom level?
  11.   (define leaves-at-bottom? #f)
  12.  
  13.   ; define what a tree is (leaf & internal node) and how to get its components
  14.   (define (leaf? tree)             (not (pair? tree)))
  15.   (define (leaf-name tree)         (string->symbol "."))
  16.   (define (leaf-info tree)         tree)
  17.   (define (int-node-name tree)     (string->symbol "."))
  18.   (define (int-node-children tree) (list (car tree) (cdr tree)))
  19.  
  20.   (define (make-augm-leaf width root name info)
  21.     (vector 'leaf width root name info))
  22.  
  23.   (define (make-augm-pad width)
  24.     (vector 'pad width))
  25.  
  26.   (define (make-augm-int-node width root name lpad rpad children)
  27.     (vector #f width root name lpad rpad children))
  28.  
  29.   (define (augm-tree-int-node? x)    (not (vector-ref x 0)))
  30.   (define (augm-tree-pad? x)         (eq? (vector-ref x 0) 'pad))
  31.   (define (augm-tree-width x)        (vector-ref x 1))
  32.   (define (augm-tree-root x)         (vector-ref x 2))
  33.   (define (augm-tree-name x)         (vector-ref x 3))
  34.   (define (augm-leaf-info x)         (vector-ref x 4))
  35.   (define (augm-int-node-lpad x)     (vector-ref x 4))
  36.   (define (augm-int-node-rpad x)     (vector-ref x 5))
  37.   (define (augm-int-node-children x) (vector-ref x 6))
  38.  
  39.   (define (pad width l)
  40.     (if (> width 0)
  41.       (cons (make-augm-pad width) l)
  42.       l))
  43.  
  44.   (define (field-width x) ; return number of chars in the written repr of `x'
  45.     (cond ((boolean? x) 2)
  46.           ((symbol? x)  (string-length (symbol->string x)))
  47.           ((char? x)    (case x ((#\space) 7) ((#\newline) 9) (else 3)))
  48.           ((number? x)  (string-length (number->string x)))
  49.           ((vector? x)  (+ (field-width (vector->list x)) 1))
  50.           ((null? x)    2)
  51.           ((pair? x)    (let loop ((l (cdr x)) (w (+ (field-width (car x)) 2)))
  52.                           (cond ((null? l)
  53.                                  w)
  54.                                 ((pair? l)
  55.                                  (loop (cdr l) (+ w (field-width (car l)) 1)))
  56.                                 (else
  57.                                  (+ w (field-width l) 3)))))
  58.           ((string? x)  (let loop ((i (- (string-length x) 1)) (w 2))
  59.                           (if (>= i 0)
  60.                             (let ((c (string-ref x i)))
  61.                               (loop (- i 1)
  62.                                     (+ w (case c ((#\\ #\") 2) (else 1)))))
  63.                             w)))
  64.           (else         0)))
  65.  
  66.   (define (augment-tree tree)
  67.     (if (leaf? tree)
  68.  
  69.       (let* ((name (leaf-name tree))
  70.              (info (leaf-info tree))
  71.              (name-width (field-width name))
  72.              (info-width (field-width info))
  73.              (tree-width (max name-width info-width)))
  74.         (make-augm-leaf tree-width (quotient tree-width 2) name info))
  75.  
  76.       (let* ((children (map augment-tree (int-node-children tree)))
  77.              (name (int-node-name tree))
  78.              (name-width (field-width name))
  79.              (name-left (quotient name-width 2))
  80.              (name-right (- name-width name-left)))
  81.         (if (null? children)
  82.           (make-augm-int-node name-width name-left name 0 0 '())
  83.           (let* ((first-child (car children))
  84.                  (last-child (list-ref children (- (length children) 1)))
  85.                  (width
  86.                    (+ (* (- (length children) 1) tree-spacing)
  87.                       (apply + (map augm-tree-width children))))
  88.                  (left
  89.                    (quotient (+ (- width (augm-tree-width last-child))
  90.                                 (+ (augm-tree-root first-child)
  91.                                    (augm-tree-root last-child)))
  92.                              2))
  93.                  (right
  94.                    (- width left))
  95.                  (max-left
  96.                    (max name-left left))
  97.                  (max-right
  98.                    (max name-right right)))
  99.             (make-augm-int-node (+ max-left max-right) max-left name
  100.                                 (- max-left left) (- max-right right)
  101.                                 children))))))
  102.  
  103.   (define (any-int-nodes? trees)
  104.     (if (null? trees)
  105.       #f
  106.       (or (augm-tree-int-node? (car trees))
  107.           (any-int-nodes? (cdr trees)))))
  108.  
  109.   (define (all-done? trees)
  110.     (if (null? trees)
  111.       #t
  112.       (and (augm-tree-pad? (car trees))
  113.            (all-done? (cdr trees)))))
  114.  
  115.   (define (seq c n port)
  116.     (if (> n 0)
  117.       (begin
  118.         (write-char c port)
  119.         (seq c (- n 1) port))))
  120.  
  121.   (define (print-trees trees port)
  122.     (if (not (all-done? trees))
  123.       (let ((delay-leaves? (and leaves-at-bottom? (any-int-nodes? trees))))
  124.  
  125.         (let loop1 ((l trees))
  126.           (if (pair? l)
  127.             (let* ((tree (car l))
  128.                    (tree-width (augm-tree-width tree)))
  129.               (if (augm-tree-pad? tree)
  130.                 (begin
  131.                   (seq #\space tree-width port)
  132.                   (loop1 (cdr l)))
  133.                 (let* ((root (augm-tree-root tree))
  134.                        (name (augm-tree-name tree))
  135.                        (name-width (field-width name))
  136.                        (name-left (quotient name-width 2))
  137.                        (name-right (- name-width name-left)))
  138.                   (if (or (not delay-leaves?) (augm-tree-int-node? tree))
  139.                     (begin
  140.                       (seq #\space (- root name-left) port)
  141.                       (write name port)
  142.                       (seq #\space (- tree-width root name-right) port)
  143.                       (loop1 (cdr l)))
  144.                     (begin
  145.                       (seq #\space root port)
  146.                       (write-char #\. port)
  147.                       (seq #\space (- tree-width root 1) port)
  148.                       (loop1 (cdr l)))))))))
  149.  
  150.         (newline port)
  151.  
  152.         (let loop2 ((l trees) (new-trees '()))
  153.           (if (pair? l)
  154.             (let* ((tree (car l))
  155.                    (tree-width (augm-tree-width tree)))
  156.               (if (augm-tree-pad? tree)
  157.                 (begin
  158.                   (seq #\space tree-width port)
  159.                   (loop2 (cdr l) (append new-trees (list tree))))
  160.                 (let* ((root (augm-tree-root tree))
  161.                        (name (augm-tree-name tree))
  162.                        (name-width (field-width name))
  163.                        (name-left (quotient name-width 2))
  164.                        (name-right (- name-width name-left)))
  165.                   (if (augm-tree-int-node? tree)
  166.                     (let ((children (augm-int-node-children tree)))
  167.                       (if (null? children)
  168.                         (begin
  169.                           (seq #\space (- root name-left) port)
  170.                           (write name port)
  171.                           (seq #\space (- tree-width root name-right) port)
  172.                           (loop2 (cdr l)
  173.                                  (append new-trees (pad tree-width '()))))
  174.                         (let* ((child1 (car children))
  175.                                (root1 (augm-tree-root child1))
  176.                                (width1 (augm-tree-width child1))
  177.                                (lpad (augm-int-node-lpad tree))
  178.                                (rpad (augm-int-node-rpad tree)))
  179.                           (seq #\space (+ lpad root1) port)
  180.                           (write-char #\. port)
  181.                           (let loop3 ((l1 (cdr children))
  182.                                       (l2 (cons child1 (pad lpad '())))
  183.                                       (right (- width1 (+ root1 1))))
  184.                             (if (pair? l1)
  185.                               (let* ((child (car l1))
  186.                                      (root (augm-tree-root child))
  187.                                      (width (augm-tree-width child)))
  188.                                 (seq #\- (+ root tree-spacing right) port)
  189.                                 (write-char #\. port)
  190.                                 (loop3 (cdr l1)
  191.                                        (cons child (pad tree-spacing l2))
  192.                                        (- width (+ root 1))))
  193.                               (begin
  194.                                 (seq #\space (+ right rpad) port)
  195.                                 (loop2 (cdr l)
  196.                                        (append new-trees
  197.                                                (reverse (pad rpad l2))))))))))
  198.                     (if delay-leaves?
  199.                       (begin
  200.                         (seq #\space root port)
  201.                         (write-char #\. port)
  202.                         (seq #\space (- tree-width root 1) port)
  203.                         (loop2 (cdr l) (append new-trees (list tree))))
  204.                       (let* ((info (augm-leaf-info tree))
  205.                              (info-width (field-width info))
  206.                              (info-left (quotient info-width 2))
  207.                              (info-right (- info-width info-left)))
  208.                         (seq #\space (- root info-left) port)
  209.                         (write info port)
  210.                         (seq #\space (- tree-width root info-right) port)
  211.                         (loop2 (cdr l)
  212.                                (append new-trees (pad tree-width '())))))))))
  213.  
  214.             (begin
  215.               (newline port)
  216.               (print-trees new-trees port)))))))
  217.  
  218.   (print-trees (list (augment-tree tree))
  219.                (if (null? optional) (current-output-port) (car optional))))
  220.