From wand@ccs.neu.edu Wed Feb  4 09:45:04 1998
Received: from dyna.ccs.neu.edu (dyna.ccs.neu.edu [129.10.123.102])
	by amber.ccs.neu.edu (8.8.6/8.8.6) with SMTP id JAA02704
	for <lieber>; Wed, 4 Feb 1998 09:45:03 -0500 (EST)
Message-Id: <3.0.2.32.19980204094534.006a3c2c@ccs.neu.edu>
X-Sender: wand@ccs.neu.edu (Unverified)
X-Mailer: QUALCOMM Windows Eudora Light Version 3.0.2 (32)
Date: Wed, 04 Feb 1998 09:45:34 -0500
To: lieber@ccs.neu.edu
From: Mitchell Wand <wand@ccs.neu.edu>
Subject: Traversal automata, v[1,2].scm
Mime-Version: 1.0
Content-Type: multipart/mixed; boundary="=====================_886621534==_"
Status: R

--=====================_886621534==_
Content-Type: text/plain; charset="us-ascii"

As of last night, I got some nice concrete syntax for this, but it's not
quite finished.  I'll give a report when it is.

Here are v1.scm and v2.scm, which I demo'ed yesterday.

--Mitch
--=====================_886621534==_
Content-Type: text/plain; charset="us-ascii"

;; Traversal automata 

;; version 1 -- all Scheme, all the time

(define reload
  (lambda () (load "v1.scm")))

;;; ****************************************************************

;; Object Model

;; object interface:
;; (make-object class)
;; (get-class obj)
;; (set-field obj field-name value)  -- this may add a new field
;; (get-field obj field-name)
;; (visit obj visitor)  -- built into model; this may change

(define make-object
  ;; makes an object with the given class, with no fields
  (lambda (class)
    (cons '*object
          (cons class '()))))

(define get-class cadr)

(define get-field
  (lambda (object field-name)
    (let ((alist (cddr object)))
      (let ((ans (assq field-name alist)))
        (if ans 
          (cdr ans)
          (error 'get-field "couldn't find field ~s in object ~s"
            field-name object))))))

(define set-field
  (lambda (object field-name value)
    (let ((pair (assq field-name (cddr object))))
      (if (pair? pair)
        (set-cdr! pair value)
        (set-cdr! (cdr object)
          (cons (cons field-name value) 
                (cddr object)))))))

(define visit
  (lambda (obj visitor) (visitor obj)))

;; (visitor obj) may still be a procedure...

;;; ****************************************************************

;;; Traveral Automata

;; syntax of automata:

;; automaton = (initial-state transition ..)
;; transition = (lhs . rhs)
;; lhs = (class state)
;; rhs = (rhs-item ...)
;; rhs-item = (VISIT parameter) 
;;          | (TRAVERSE field-name state)
;;          | (FOR-EACH field-name state)

(define traverse
  (lambda (object automaton visitor)
    (traverse-object object (car automaton) automaton visitor)))

(define traverse-object
  (lambda (object state automaton visitor)
    (let* ((class (get-class object))
           (the-pair (list class state)))
      (letrec
        ((loop              
           ;; search for appropriate transition
           (lambda (transitions)
             (cond
               ((null? transitions)
                (error 'traverse-object
                  "couldn't find transition for class ~s in state ~s"
                  class state))
               ;; or could search again using superclass of class.h
               ((and (equal? (caar transitions) the-pair))
                ;; ok, this is it
                (traverse-rhs object (cdar transitions) automaton visitor))
               (else 
                 ;; keep looking
                 (loop (cdr transitions)))))))
        (loop (cdr automaton))))))

(define traverse-rhs
  (lambda (object rhs automaton visitor)
    (call/cc                            
      (lambda (break)
        (for-each-return-last                       
          ;; use custom version of for-each that returns last value
          (lambda (rhs-item)
            (traverse-rhs-item object rhs-item automaton visitor 
              (lambda () (break #f))))
          rhs)))))

(define traverse-rhs-item
  (lambda (object rhs-item automaton visitor break-thunk)
;; rhs-item = (VISIT parameter) | (TRAVERSE field-name state)
;;          | (FOR-EACH field-name state)
    (case (car rhs-item)
      ((visit) 
       ;; visit the current object with the given parameter.
       ;; break-thunk is a thunk that aborts the rest of the traversal
       ;; of this object.
       (let ((parameter (cadr rhs-item)))
         ((visit object visitor) parameter break-thunk)))
      ((traverse)
       ;; field-name gets us to another object.  Traverse it in the
       ;; given state.
       (let ((field-name (cadr rhs-item))
             (state     (caddr rhs-item)))
         (traverse-object 
           (get-field object field-name)
           state
           automaton 
           visitor)))
      ((for-each)
       ;; field-name gets us to a list of objects.  Traverse them all
       ;; in the given state.
       (let ((field-name (cadr rhs-item))
             (state (caddr rhs-item)))
         (for-each
           (lambda (object)
             (traverse-object object state automaton visitor))
           (get-field object field-name))))
      (else 
        (error 'traverse-rhs-item
          "unknown rhs item ~s" rhs-item)))))

(define for-each-return-last
  (lambda (proc list)
    (cond
      ((null? list) #f)
      ((null? (cdr list)) (proc (car list)))
      (else (proc (car list))
            (for-each-return-last proc (cdr list))))))


;;; ****************************************************************
;;; ****************************************************************

;;; simple examples

;;; red/blue tree from COM 3351 lecture notes

;; class tree
;; class top {tree: tree}
;; subclass red of tree {left:tree, right:tree}
;; subclass blue of tree {sons:(list tree)}
;; subclass leaf of tree {data:int}

(define trav1
  '(q1
     ((top q1)
      (traverse tree q1) (visit finish))
     ((red q1)
      (traverse left q1) (traverse right q1))
     ((blue q1)
      (for-each sons q1))
     ((leaf q1)
      (visit search))))

(define make-summing-visitor
  (lambda ()
    (let ((sum 0))
      (lambda (obj)
        (lambda (param break)
          (printf "visiting ~s~%parameter = ~s~%" obj param)
          (case param
            ((initial)
             (print "starting"))
            ((search)
             (if (eq? (get-class obj) 'leaf) ; always true when called
               (let ((data (get-field obj 'data)))
                 (set! sum (+ sum data)))
               '()))
            ((finish)
             (print "finishing")
             (print sum))
            (else 
              (error 'summing-visitor 
                "unknown parameter ~s" param))))))))

;;; here's one that doesn't work as intended, because the (break) has
;;; nothing to shortcut in the traversal
;   ((leaf q1)
;    (visit search))))

(define make-cautious-summing-visitor
  (lambda ()
    (let ((sum 0))
      (lambda (obj)
        (lambda (param break)
          (printf "visiting ~s~%parameter = ~s~%" obj param)
          (case param
            ((initial)
             (print "starting"))
            ((search)
             (if (eq? (get-class obj) 'leaf)
               (let ((data (get-field obj 'data)))
                 (if (> data 100)
                   (begin
                     (printf 
                       "found data ~s > 100; aborting this traversal~%"
                       data)
                     (break))
                   (set! sum (+ sum data))))
               '()))
            ((finish)
             (print "finishing")
             (print sum))
            (else 
              (error 'summing-visitor 
                "unknown parameter ~s" param))))))))

;; build data for this example

(define top
  (lambda (tree)
    (let ((o (make-object 'top)))
      (set-field o 'tree tree)
      o)))

(define red
  (lambda (left right)
    (let ((o (make-object 'red)))
      (set-field o 'left left)
      (set-field o 'right right)
      o)))

(define blue
  (lambda (sons)
    (let ((o (make-object 'blue)))
      (set-field o 'sons sons)
      o)))

(define leaf
  (lambda (num)
    (let ((o (make-object 'leaf)))
      (set-field o 'data num)
      o)))

(define tree1
  (top
    (red
      (blue
        (list (leaf 3) (leaf 4) (leaf 120) (leaf 17)))
      (red
        (leaf 200)
        (leaf 7)))))

(define test1
  (lambda ()
    (traverse tree1 trav1 (make-summing-visitor))))

(define test2
  (lambda ()
    (traverse tree1 trav1 (make-cautious-summing-visitor))))

;;; exercise:  write a visitor that annotates each leaf with the
;;; number of red nodes above it.

;;; ****************************************************************

;;; In-laws example

;;; class person {name: symbol,
;;;               married?: bool, 
;;;               spouse: person, 
;;;               siblings: list person}

;;; an inlaw is a spouse of a sibling or a sibling of a spouse.

;;; only problem is what to do with a missing spouse-- use married?
;;; field to abort the traversal.  This works nicely, since the visit
;;; is not tail-recursive.

;; states:
;  start        -- you're at the person whose inlaws we are looking for.
;  visit-spouse -- you're at a sibling, go look for a spouse and visit
;                  her.
;  visit-siblings  -- you're at a spouse, go look for siblings and
;                     visit them.
;  visit-self -- congratulations! You've reached an in-law.

(define inlaw-traversal
  '(start
     ((person start)
      (visit start)
      (for-each siblings visit-spouse) 
      (visit check-for-spouse)          ; this visit aborts if single
      (traverse spouse visit-siblings)) ; so this line gets skipped
     ((person visit-spouse)
      (visit check-for-spouse)          ; similarly here
      (traverse spouse visit-self))
     ((person visit-siblings)
      (for-each siblings visit-self))
     ((person visit-self)
      (visit real-visit))))

(define in-law-visitor
  (lambda (obj)
    (lambda (param break)
      (case param
        ((start)
         (printf "in-laws of ~s:~%" (get-field obj 'name)))
        ((check-for-spouse)
         (if (get-field obj 'married)
           #t                           ; ok
           (break)                      ; single -- abort traversal
           ))
        ((real-visit)
         (printf " ~s~%" (get-field obj 'name)))
        (else (error 'in-law-vistor "unknown parameter ~s" param))))))

;;; ****************

;;; Build data structures for in-law problem

(define family-spec1
  '((married mitch barbara)
    (siblings mitch marilyn)
    (siblings barbara ellie bill)
    (married ellie joe)
    (married marilyn bruce)
    (siblings bruce ken)
    (siblings joe emily frank bob)))

(define make-family
  (lambda (family-spec)
    (let ((the-family '()))
      (letrec
        ((make-person 
           (lambda (name)
             (let ((ans (assq name the-family)))
               (if ans
                 (cdr ans)
                 (let ((person (make-object 'person)))
                   (set-field person 'name name)
                   (set-field person 'married #f)
                   (set-field person 'siblings '())
                   (set! the-family (cons 
                                      (cons name person)
                                      the-family))
                   person)))))
         (find-person
           (lambda (name)
             (let ((ans (assq name the-family)))
               (if ans (cdr ans)
                 (make-person name)))))
         (make-married
           (lambda (p1 p2)
             (set-field p1 'married #t)
             (set-field p1 'spouse p2)
             (set-field p2 'married #t)
             (set-field p2 'spouse p1)))
         (make-sibling
           (lambda (p1 p2)
             (set-field p1 'siblings (cons p2 (get-field p1 'siblings)))
             (set-field p2 'siblings (cons p1 (get-field p2 'siblings)))))
         (make-siblings
           (lambda (persons)
             (for-each-triangular make-sibling persons)))
         (for-each-triangular    ;; note separation of traversal and actions!
           (lambda (proc list)
             (let outer ((list list))
               (if (null? list) #t
                 (let inner ((first (car list))
                             (rest  (cdr list)))
                   (if (null? rest) 
                     (outer (cdr list))
                     (begin
                       (proc first (car rest))
                       (inner first (cdr rest))))))))))
        (for-each
          (lambda (spec)
            (case (car spec)
              ((married) 
               (make-married 
                 (find-person (cadr spec))
                 (find-person (caddr spec))))
              ((siblings)
               (make-siblings (map find-person (cdr spec))))
              (else
                (error 'make-family
                  "unknown specification ~s" spec))))
          family-spec)
        the-family))))

(define fam1 (make-family family-spec1))

(define test3
  (lambda ()
    (for-each
      (lambda (pair)
        (let ((name (car pair))
              (person (cdr pair)))
          (traverse person inlaw-traversal in-law-visitor)))
      fam1)))

;;; ****************************************************************

;;; Graph Examples

;;; graph = {nodes: node list}
;;; node = {name: symbol, targets : node list,
;;;         // the following are set by the traversal:
;;;         mark : bool, start: int, finish:int}


; specify graph as list of edges, eg:
(define graph-spec-1
  '((a b) (b c) (a c) (c d) (c e)))

(define make-graph
  (lambda (edge-list)
    (let ((the-graph '()))
      (letrec
        ((find-node
           (lambda (name)
             (linear-search             ; return #f if not found
               (lambda (node) (eq? (get-field node 'name) name))
               the-graph)))
         (linear-search 
           (lambda (proc list)
             (cond
               ((null? list) #f)
               ((proc (car list)) (car list))
               (else (linear-search proc (cdr list))))))
         (make-node
           (lambda (name)
             (let ((ans (find-node name)))
               (if ans ans 
                 (let ((node (make-object 'node)))
                   (set-field node 'name name)
                   (set-field node 'targets '())
                   (set! the-graph (cons node the-graph))
                   node))))))
        (for-each
          (lambda (edge)
            (let ((source (make-node (car edge)))
                  (target (make-node (cadr edge))))
              (let ((targets (get-field source 'targets)))
                (if (not (memq target targets))
                  (set-field source 'targets (cons target
                                                   targets))))))
          edge-list))
      (let ((graph-object (make-object 'graph)))
        (set-field graph-object 'nodes the-graph)
        graph-object))))

(define dfs-traversal
  '(start
     ((graph start)
      (for-each nodes whiten)
      (for-each nodes real-visit)
      (visit finish))
    ((node whiten)           ; whiten each node exactly once
     (visit whiten))
    ((node real-visit)
     (visit preorder)                   ; preorder visit
     (for-each targets real-visit)   
     (visit postorder))))               ; postorder visit

;; exercise:  how do you do inorder visits?

(define preorder-printing-visitor
  (lambda (obj)
    (lambda (param break)
      (if (eq? param 'preorder)
        (printf "~s " (get-field obj 'name))
        '()))))

(define make-dfs-visitor
  (lambda (visitor)
    (let ((timer 0))
      (lambda (obj)
        (lambda (param break)
          (set! timer (+ timer 1))
          ;(printf "tick: ~s~%" timer)
          (case param
            ((start finish) #f)                ; nothing to do here
            ((whiten)
             (set-field obj 'mark #f))
            ((preorder)
             (if (get-field obj 'mark)
               (break)                  ; already visited -- do nothing
               (begin
                 (set-field obj 'mark #t)
                 (set-field obj 'start timer)
                 )))
            ((postorder)
             (set-field obj 'finish timer))
            (else
              (error 'dst-visitor "unknown parameter ~s" param)))
          ;; (break) is a continuation, so we never get back here if
          ;; we break.
          ((visitor obj) param break))))))

(define make-dfs-sort-visitor
  (lambda ()
    (let ((the-list '()))
      (lambda (obj)
        (lambda (param break)
          (case param
            ((preorder)
             (set! the-list (cons (get-field obj 'name) the-list)))
            ((finish)
             (reverse the-list))
            (else #f)))))))

(define make-top-sort-visitor
  (lambda ()
    (let ((the-list '()))
      (lambda (obj)
        (lambda (param break)
          (case param
            ((postorder)
             (set! the-list (cons (get-field obj 'name) the-list)))
            ((finish)
             the-list)
            (else #f)))))))

;; example from Fig 23.5 of CLR:

(define edge-list-2
  '((s z) (s w) (z y) (z w) (y x) (x z) (w x)
    (t v) (v s) (t u) (u t) (u v)))

(define test4
  (lambda ()
    (traverse 
      (make-graph edge-list-2)
      dfs-traversal
      (make-dfs-visitor preorder-printing-visitor))))

(define test5
  (lambda ()
    (traverse 
      (make-graph edge-list-2)
      dfs-traversal
      (make-dfs-visitor (make-dfs-sort-visitor)))))

(define test6
  (lambda ()
    (traverse 
      (make-graph edge-list-2)
      dfs-traversal
      (make-dfs-visitor (make-top-sort-visitor)))))

(define top-sort
  (lambda (graph)
    (traverse graph dfs-traversal
      (make-dfs-visitor 
        (let ((the-list '()))
          (lambda (obj)
            (lambda (param break)
              (case param
                ((postorder)
                 (set! the-list (cons obj the-list)))
                ((finish)
                 the-list)
                (else #f)))))))))


(define test-top-sort
  (lambda ()
    (map
      (lambda (node)
        (list (get-field node 'name)
              (get-field node 'finish)))
      (top-sort (make-graph edge-list-2)))))

;;; next:
;;; do strongly-connected components, using algorithm on p 489 of CLR.
;;; Need to traverse G, and then
;;; traverse transpose of G, AND must traverse nodes of G in the
;;; top-sort order.  How to arrange all this?

;;; then think about inheritance....




--=====================_886621534==_
Content-Type: text/plain; charset="us-ascii"

;; Traversal automata 

;; version 2 -- all Scheme, all the time, but visitors as objects

(define reload
  (lambda () (load "v2.scm")))

;;; ****************************************************************

;; Object Model

;; object interface:
;; (make-object class)
;; (get-class obj)
;; (set-field obj field-name value)  -- this may add a new field
;; (get-field obj field-name)
;; (set-method obj field-name)   -- same as set-field
;; (get-method obj field-name)   

;; set-field and set-method return the object as their value.  This is
;; handy & should have been done in v1.

(define make-object
  ;; makes an object with the given class, with no fields
  (lambda (class)
    (cons '*object
          (cons class '()))))

(define get-class cadr)

(define get-field
  (lambda (object field-name)
    (let ((alist (cddr object)))
      (let ((ans (assq field-name alist)))
        (if ans 
          (cdr ans)
          (error 'get-field "couldn't find field ~s in object ~s"
            field-name object))))))

(define set-field
  (lambda (object field-name value)
    (let ((pair (assq field-name (cddr object))))
      (if (pair? pair)
        (set-cdr! pair value)
        (set-cdr! (cdr object)
          (cons (cons field-name value) 
                (cddr object))))
      object)))

; added:

(define set-method set-field)

(define get-method
  (lambda (object method-name)
    (let ((field (get-field object method-name)))
      (field object))))                 ; apply it to self.

; (define visit
;   (lambda (obj visitor) (visitor obj)))

(define visit
  (lambda (object visitor param)
    ((get-method visitor param) object)))

;;; ****************************************************************

;;; Traveral Automata

;; syntax of automata:

;; automaton = (initial-state transition ..)
;; transition = (lhs . rhs)
;; lhs = (class state)
;; rhs = (rhs-item ...)
;; rhs-item = (VISIT parameter) 
;;          | (TRAVERSE field-name state)
;;          | (FOR-EACH field-name state)

(define traverse
  (lambda (object automaton visitor)
    (traverse-object object (car automaton) automaton visitor)))

(define traverse-object
  (lambda (object state automaton visitor)
    (let* ((class (get-class object))
           (the-pair (list class state)))
      (letrec
        ((loop              
           ;; search for appropriate transition
           (lambda (transitions)
             (cond
               ((null? transitions)
                (error 'traverse-object
                  "couldn't find transition for class ~s in state ~s"
                  class state))
               ;; or could search again using superclass of class.h
               ((and (equal? (caar transitions) the-pair))
                ;; ok, this is it
                (traverse-rhs object (cdar transitions) automaton visitor))
               (else 
                 ;; keep looking
                 (loop (cdr transitions)))))))
        (loop (cdr automaton))))))

(define traverse-rhs
  (lambda (object rhs automaton visitor)
    (call/cc                            
      (lambda (break)
        (for-each-return-last                       
          ;; use custom version of for-each that returns last value
          (lambda (rhs-item)
            (traverse-rhs-item object rhs-item automaton visitor 
              (lambda () (break #f))))
          rhs)))))

(define traverse-rhs-item
  (lambda (object rhs-item automaton visitor break-thunk)
;; rhs-item = (VISIT parameter) | (TRAVERSE field-name state)
;;          | (FOR-EACH field-name state)
    (case (car rhs-item)
      ((visit) 
       ;; visit the current object with the given parameter.
       ;; break-thunk is a thunk that aborts the rest of the traversal
       ;; of this object.
       (let ((parameter (cadr rhs-item)))
         ;; ((visit object visitor) parameter break-thunk)))
         ((visit object visitor parameter) break-thunk)))
      ((traverse)
       ;; field-name gets us to another object.  Traverse it in the
       ;; given state.
       (let ((field-name (cadr rhs-item))
             (state     (caddr rhs-item)))
         (traverse-object 
           (get-field object field-name)
           state
           automaton 
           visitor)))
      ((for-each)
       ;; field-name gets us to a list of objects.  Traverse them all
       ;; in the given state.
       (let ((field-name (cadr rhs-item))
             (state (caddr rhs-item)))
         (for-each
           (lambda (object)
             (traverse-object object state automaton visitor))
           (get-field object field-name))))
      (else 
        (error 'traverse-rhs-item
          "unknown rhs item ~s" rhs-item)))))

(define for-each-return-last
  (lambda (proc list)
    (cond
      ((null? list) #f)
      ((null? (cdr list)) (proc (car list)))
      (else (proc (car list))
            (for-each-return-last proc (cdr list))))))


;;; ****************************************************************
;;; ****************************************************************

;;; simple examples

; (define make-summing-visitor
;   (lambda ()
;     (let ((sum 0))
;       (lambda (obj)
;         (lambda (param break)
;           (printf "visiting ~s~%parameter = ~s~%" obj param)
;           (case param
;             ((initial)
;              (print "starting"))
;             ((search)
;              (if (eq? (get-class obj) 'leaf)
;                (let ((data (get-field obj 'data)))
;                  (set! sum (+ sum data)))
;                '()))
;             ((finish)
;              (print "finishing")
;              (print sum))
;             (else 
;               (error 'summing-visitor 
;                 "unknown parameter ~s" param))))))))

(define make-summing-visitor
  (lambda ()
    (let ((visitor (make-object 'visitor))) ; the class doesn't matter now
      (set-field visitor 'sum 0)        ; make sum a field, just for fun
      (set-method visitor 'initial
        (lambda (self)
          (lambda (obj)
            (lambda (break)
              ;; this printf was shared among methods before
              (printf "visiting ~s~%parameter = ~s~%" obj 'initial)
              (print "starting")))))
      (set-method visitor 'search
        (lambda (self)
          (lambda (obj)
            (lambda (break)
              (printf "visiting ~s~%parameter = ~s~%" obj 'search)
              ;; here we know we are at a leaf node
               (let ((data (get-field obj 'data)))
                 (set-field self 'sum
                   (+ data (get-field self 'sum))))))))

      (set-method visitor 'finish
        (lambda (self)
          (lambda (obj)
            (lambda (break)
              (printf "visiting ~s~%parameter = ~s~%" obj 'finish)
              (print "finishing")
              (print (get-field self 'sum)))))))))

;             (else 
;               (error 'summing-visitor 
;                 "unknown parameter ~s" param))))))))

;; note that we've lost some user interface here:  on an unknown
;; parameter, we'll no longer get a custom error message like this
;; one-- instead we'll get the generic "unknown field" method.  This
;; is the standard bug of letting the implementation (of visitors as
;; objects) show through.


            
;; build cautious-summing-visitor by overriding (nice!)

(define make-cautious-summing-visitor
  (lambda ()
    (let ((visitor (make-summing-visitor)))
      (set-method visitor 'search
        (lambda (self)
          (lambda (obj)
            (lambda (break)
              (printf "visiting ~s~%parameter = ~s~%" obj 'search)
              (let ((data (get-field obj 'data)))
                (if (> data 100)
                  (begin
                    (printf 
                      "found data ~s > 100; aborting this traversal~%"
                      data)
                    (break))
                  (set-field self 'sum
                    (+ data (get-field self 'sum)))))


;;; data for testing summing visitor

;; class tree
;; subclass red of tree {left:tree, right:tree}
;; subclass blue of tree {sons:(list tree)}
;; subclass leaf of tree {data:int}

(define top
  (lambda (tree)
    (let ((o (make-object 'top)))
      (set-field o 'tree tree)
      o)))

(define red
  (lambda (left right)
    (let ((o (make-object 'red)))
      (set-field o 'left left)
      (set-field o 'right right)
      o)))

(define blue
  (lambda (sons)
    (let ((o (make-object 'blue)))
      (set-field o 'sons sons)
      o)))

(define leaf
  (lambda (num)
    (let ((o (make-object 'leaf)))
      (set-field o 'data num)
      o)))

(define trav1
  '(q1
     ((top q1)
      (traverse tree q1) (visit finish))
     ((red q1)
      (traverse left q1) (traverse right q1))
     ((blue q1)
      (for-each sons q1))
     ((leaf q1)
      (visit search))))

(define tree1
  (top
    (red
      (blue
        (list (leaf 3) (leaf 4) (leaf 120)))
      (red
        (leaf 6)
        (leaf 7)))))

(define test1
  (lambda ()
    (traverse tree1 trav1 (make-summing-visitor))))

(define test2
  (lambda ()
    (traverse tree1 trav1 (make-cautious-summing-visitor))))

;;; exercise:  write a visitor that annotates each leaf with the
;;; number of red nodes above it.

;;; other examples in v1.scm should translate the same way.


--=====================_886621534==_--