home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / interpreter / Examples / tree.scm < prev    next >
Encoding:
Text File  |  1992-03-18  |  9.3 KB  |  117 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.       (begi