;;;; The famous Samefringe problem:
;;; Do two finite trees have the same fringe?
;;; The fringe of a tree is the ordered list of terminal leaves of the
;;; tree when traversed in a standard order. We can easily compute
;;; the fringe of a tree represented as a list structure. Here we add
;;; an explicit test to exclude the empty list from the answer:
(define (fringe s)
(cond ((pair? s)
(append (fringe (car s))
(fringe (cdr s))))
((null? s) '())
(else (list s))))
;;; Where append is usually defined as:
(define (append l1 l2)
(if (pair? l1)
(cons (car l1)
(append (cdr l1) l2))
l2))
#|
(fringe '((a b) c ((d)) e (f ((g h)))))
;Value: (a b c d e f g h)
|#
;;; That was a horribly inefficient computation, because append keeps
;;; copying parts of the fringe over and over.
;;; Here is a nicer procedure that computes the fringe, without any
;;; nasty recopying.
(define (fringe s)
(define (walk s ans)
(cond ((pair? s)
(walk (car s)
(walk (cdr s)
ans)))
((null? s) ans)
(else (cons s ans))))
(walk s '()))
;;; So the problem appears really simple:
(define (samefringe t1 t2)
(equal? (fringe t1) (fringe t2)))
#|
(samefringe '((a b) c ((d)) e (f ((g h))))
'(a b c ((d) e) (f (g (h)))))
;Value: #t
(samefringe '((a b) c ((d)) e (f ((g h))))
'(a b c ((d) e) (g (f (h)))))
;Value: #f
|#
;;; Unfortunately, this requires computing the entire fringe of each
;;; tree before comparing the fringes. Suppose that the trees were
;;; very big, but that they were likely to differ early in the fringe.
;;; This would be a terrible strategy. We would rather have a way of
;;; generating the next element of the fringe of each tree as needed
;;; to compare them. One way to do this is with "lazy evaluation",
;;; (as in streams):
(define (lazy-fringe s)
(cond ((pair? s)
(stream-append (lazy-fringe (car s))
(lazy-fringe (cdr s))))
((null? s) the-empty-stream)
(else (stream s))))
(define (lazy-samefringe t1 t2)
(let lp ((f1 (lazy-fringe t1))
(f2 (lazy-fringe t2)))
(cond ((and (empty-stream? f1) (empty-stream? f2)) #t)
((or (empty-stream? f1) (empty-stream? f2)) #f)
((eq? (head f1) (head f2))
(lp (tail f1) (tail f2)))
(else #f))))
#|
(lazy-samefringe
'((a b) c ((d)) e (f ((g h))))
'(a b c ((d) e) (f (g (h)))))
;Value: #t
(lazy-samefringe
'((a b) c ((d)) e (f ((g h))))
'(a b c ((d) e) (g (f (h)))))
;Value: #f
|#
;;; This method only requires examining as much of the input trees as
;;; is necessary to decide that two fringes are not the same.
;;; An alternative incremental idea is to make coroutines that
;;; generate the fringes, using an explicit continuation argument and
;;; an assignment:
(define *done* (list '*done*))
(define (fringe-generator tree)
(define (next)
(walk tree (lambda () *done*)))
(define (walk subtree continue)
(cond ((null? subtree)
(continue))
((pair? subtree)
(walk (car subtree)
(lambda ()
(walk (cdr subtree)
continue))))
(else
(set! next continue)
subtree)))
(lambda () (next)))
;;; Why is it necessary to have the expression "(lambda () (next))"
;;; rather than just "next" as the returned value of the fringe
;;; generator? Aren't they the same?
(define (coroutine-samefringe t1 t2)
(let ((f1 (fringe-generator t1))
(f2 (fringe-generator t2)))
(let lp ((x1 (f1)) (x2 (f2)))
(cond ((and (eq? x1 *done*) (eq? x2 *done*)) #t)
((or (eq? x1 *done*) (eq? x2 *done*)) #f)
((eq? x1 x2) (lp (f1) (f2)))
(else #f)))))
#|
(coroutine-samefringe
'((a b) c ((d)) e (f ((g h))))
'(a b c ((d) e) (f (g (h)))))
;Value: #t
(coroutine-samefringe
'((a b) c ((d)) e (f ((g h))))
'(a b c ((d) e) (g (f (h)))))
;Value: #f
|#
;;; We can abstract this control structure, using continuations.
;;; Here, a procedure that is to be used as a coroutine takes an
;;; argument: return. Its value is a thunk that can be called to
;;; start the coroutine computing.
;;; When the execution of the coroutine thunk calls the return
;;; procedure that was passed to its creator, it saves its state as a
;;; new thunk that invokes the continuation of the return. It then
;;; invokes a procedure with a value that the caller of the thunk will
;;; see as the value of the thunk.
(define (make-coroutine proc)
(let ((my-state) (his-state))
(define (return value)
(call-with-current-continuation
(lambda (k)
(set! my-state
(lambda ()
(call-with-current-continuation
(lambda (his)
(set! his-state his)
(k unspecific)))))
(his-state value))))
(set! my-state (proc return))
(lambda ()
(call-with-current-continuation
(lambda (his)
(set! his-state his)
(my-state))))))
(define *done* (list '*done*))
(define (samefringe t1 t2)
(let ((f1 (make-coroutine (fringe-gen t1)))
(f2 (make-coroutine (fringe-gen t2))))
(let lp ((x1 (f1)) (x2 (f2)))
(cond ((and (eq? x1 *done*) (eq? x2 *done*)) #t)
((or (eq? x1 *done*) (eq? x2 *done*)) #f)
((eq? x1 x2) (lp (f1) (f2)))
(else #f)))))
(define ((fringe-gen tree) return)
(define (lp tree)
(cond ((pair? tree)
(lp (car tree))
(lp (cdr tree)))
((null? tree) )
(else
(return tree))))
(lambda ()
(lp tree)
(return *done*)))
#|
(samefringe
'((a b) c ((d)) e (f ((g h))))
'(a b c ((d) e) (f (g (h)))))
;Value: #t
(samefringe
'((a b) c ((d)) e (f ((g h))))
'(a b c ((d) e) (g (f (h)))))
;Value: #f
(samefringe
'((a b) c ((d)) e (f ((g h))))
'(a b c ((d) e) (g (f ))))
;Value: #f
|#
;;; With pipes, in time-sharing
(define *done* (list '*done*))
(define (samefringe t1 t2)
(let ((p1 (make-pipe)) (p2 (make-pipe)))
(let ((thread1
(conspire:make-thread
conspire:runnable
(lambda ()
(fringe-gen t1 (pipe-writer p1)))))
(thread2
(conspire:make-thread
conspire:runnable
(lambda ()
(fringe-gen t2 (pipe-writer p2)))))
(f1 (pipe-reader p1))
(f2 (pipe-reader p2)))
(let lp ((x1 (f1)) (x2 (f2)))
(cond ((and (eq? x1 *done*) (eq? x2 *done*)) #t)
((or (eq? x1 *done*) (eq? x2 *done*)) #f)
((eq? x1 x2) (lp (f1) (f2)))
(else #f))))))
(define (fringe-gen tree return)
(define (lp tree)
(cond ((pair? tree)
(lp (car tree))
(lp (cdr tree)))
((null? tree))
(else
(return tree))))
(lp tree)
(return *done*))
;;; With abstraction to be built in problem set...
(define (samefringe t1 t2)
(let ((f1 (make-threaded-filter (fringe-gen t1)))
(f2 (make-threaded-filter (fringe-gen t2))))
(let lp ((x1 (f1)) (x2 (f2)))
(cond ((and (eq? x1 *done*) (eq? x2 *done*)) #t)
((or (eq? x1 *done*) (eq? x2 *done*)) #f)
((eq? x1 x2) (lp (f1) (f2)))
(else #f)))))
(define ((fringe-gen tree) return)
(define (lp tree)
(cond ((pair? tree)
(lp (car tree))
(lp (cdr tree)))
((null? tree))
(else
(return tree))))
(lp tree)
(return *done*))