;;; The same-fringe problem

;;; Efficiently determine whether two binary trees
;;; have the same fringe.
;;; E.g., (same-fringe '(((a . b) . (c . d)) . e) 
;;;                    '((a . (b . c)) . (d . e))) ==> #t

;;; Naive definition:

(define (same-fringe1? t1 t2)
  (equal (fringe t1) (fringe t2)))

(define (fringe t)
  (if (pair? t)
      (append (fringe (car t)) (fringe (cdr t)))
      (list t)))

;;; This is very inefficient on:
;;; (same-fringe '((((((((a . b) . ... ))) ... ))))
;;;              '((((((((x . b) . ... )) ... )))))) ==> #f

;;; An equivalent Haskell solution solves this particular
;;; problem efficiently using lazy evaluation, but lacks flexibility.

(define call/cc call-with-current-continuation)

;;; Solution using two generators
;;; (Teach Yourself Scheme in Fixnum Days, Dorai Sitaram)

(define tree->generator
  (lambda (tree)
    (let ((caller '*))
      (letrec
          ((generate-leaves
            (lambda ()
              (let loop ((tree tree))
                (cond ((null? tree) 'skip)
                      ((pair? tree)
                       (loop (car tree))
                       (loop (cdr tree)))
                      (else
                       (call/cc
                        (lambda (rest-of-tree)
                          (set! generate-leaves
                            (lambda ()
                              (rest-of-tree 'resume)))
                          (caller tree))))))
              (caller '()))))
        (lambda ()
          (call/cc
           (lambda (k)
             (set! caller k)
             (generate-leaves))))))))

(define same-fringe2?
  (lambda (tree1 tree2)
    (let ((gen1 (tree->generator tree1))
          (gen2 (tree->generator tree2)))
      (let loop ()
        (let ((leaf1 (gen1))
              (leaf2 (gen2)))
          (if (eqv? leaf1 leaf2)
              (if (null? leaf1) #t (loop))
              #f))))))

;;; Solution using three coroutines 
;;; (as above)

;;; Some Scheme implementations do not use define-macro.
;;; (Need to replace define-macro with more current style.)
(define (comment exp) #f)

(comment (quote
(define-macro coroutine
  (lambda (x . body)
    `(letrec ((local-control-state
               (lambda (,x) ,@body))
              (resume
               (lambda (c v)
                 (call/cc
                  (lambda (k)
                    (set! local-control-state k)
                    (c v))))))
       (lambda (v)
         (local-control-state v)))))
))

(define make-matcher-coroutine
  (lambda (tree-cor-1 tree-cor-2)
    (coroutine dont-need-an-init-arg
      (let loop ()
        (let ((leaf1 (resume tree-cor-1 'get-a-leaf))
              (leaf2 (resume tree-cor-2 'get-a-leaf)))
          (if (eqv? leaf1 leaf2)
              (if (null? leaf1) #t (loop))
              #f))))))

(define make-leaf-gen-coroutine
  (lambda (tree matcher-cor)
    (coroutine dont-need-an-init-arg
      (let loop ((tree tree))
        (cond ((null? tree) 'skip)
              ((pair? tree)
               (loop (car tree))
               (loop (cdr tree)))
              (else
               (resume matcher-cor tree))))
      (resume matcher-cor '()))))

(define same-fringe3?
  (lambda (tree1 tree2)
    (letrec ((tree-cor-1
              (make-leaf-gen-coroutine
               tree1
               (lambda (v) (matcher-cor v))))
             (tree-cor-2
              (make-leaf-gen-coroutine
               tree2
               (lambda (v) (matcher-cor v))))
             (matcher-cor
              (make-matcher-coroutine
               (lambda (v) (tree-cor-1 v))
               (lambda (v) (tree-cor-2 v)))))
      (matcher-cor 'start-ball-rolling))))

;;; Exercise.  Construct an efficient, recursive solution
;;; without using call/cc, lazy evaluation,  complex
;;; control constructs, and with as little consing as possible.