From wand@ccs.neu.edu Tue Jan 20 16:29:10 1998
Received: from dyna.ccs.neu.edu (honey-combs.ccs.neu.edu [129.10.112.32])
	by amber.ccs.neu.edu (8.8.6/8.8.6) with SMTP id QAA28327;
	Tue, 20 Jan 1998 16:29:03 -0500 (EST)
Message-Id: <3.0.2.32.19980119222948.00692d9c@ccs.neu.edu>
X-Sender: wand@ccs.neu.edu
X-Mailer: QUALCOMM Windows Eudora Light Version 3.0.2 (32)
Date: Mon, 19 Jan 1998 22:29:48 -0800
To: johan@ccs.neu.edu
From: Mitchell Wand <wand@ccs.neu.edu>
Subject: Progress on traversal automata
Cc: lieber@ccs.neu.edu
Mime-Version: 1.0
Content-Type: multipart/mixed; boundary="=====================_885306588==_"
Status: R

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

Johan, here's what I've gotten so far.  See if you can think about some of
the examples I've labelled as exercises.  See you next week. 

Karl, I'd be happy to give an update and demo at the next seminar I'll be
at (T 2/3).

--Mitch



--=====================_885306588==_
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))
               ((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

(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-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))))))))


;;; 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.

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

;;; 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

(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))
     ((person visit-spouse)
      (visit check-for-spouse)
      (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
           (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)))
          ((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....




--=====================_885306588==_--