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