code/same-fringe.rkt

   1 #lang racket
   2 (require racket/control) ; this tells Scheme to let us use shift and reset
   3
   4 (define (visit yield t)
   5   (cond [(pair? t) (visit yield (car t)) (visit yield (cdr t))]
   6         [else (yield t)]))
   7
   8
   9 ; delimcc-based implementation of coroutines, following http://okmij.org/ftp/continuations/implementations.html#caml-shift
  10 (define (coroutine2 main start thread)
  11   (letrec ([yield (lambda (x) (shift0 k (cons x k)))]
  12            [loop (lambda (curk data)
  13                    (let ([x (car data)] [k (cdr data)])
  14                      (cond
  15                        [(eq? k 'finished) (loop curk (curk x))]
  16                        [(eq? k 'exit) x]
  17                        [else (loop k (curk x))])))])
  18     (loop (lambda (x) (reset0 (cons (thread yield x) 'finished))) (reset0 (cons (main yield start) 'exit)))))
  19
  20 ; call/cc-based, following Xavier Leroy's ocaml-callcc
  21 (define (coroutine2^ main start thread)
  22   (let/cc initk (let* ([curk initk]
  23                        [yield (lambda (x) (let/cc k (let ([oldk curk]) (set! curk k) (oldk x))))])
  24                   (main yield (begin (thread yield (let/cc k2 (set! curk k2) start)))))))
  25
  26 (define (proc coroutine2 max1 max2)
  27   (letrec ([proc1 (lambda (yield n) (if (>= n max1) (begin (displayln "1: exit") 100) (begin (display "1: received ") (displayln n) (proc1 yield (yield (+ 1 n))))))]
  28            [proc2 (lambda (yield n) (if (>= n max2) (begin (displayln "2: finished") -2) (begin (display "2: received ") (displayln n) (proc2 yield (yield (+ 1 n))))))])
  29     (coroutine2 proc1 0 proc2)))
  30
  31 ; the following is meant to be a general-purpose handler with the following behavior:
  32 ; 1. call main with start
  33 ; 2. first yield to proc1, which yields back to main,
  34 ; 3. then main yields to proc2, which yields back to main; and so on
  35 ; 4. when either proc finishes, subsequent yields from main which would have gone to that procedure instead always return #f
  36 ; 5. we stop looping only when main finishes
  37 (define (coroutine3 main start proc1 proc2)
  38   (letrec ([yield (lambda (x) (shift0 k (cons x k)))]
  39            [false (lambda (x) (reset0 (false (shift0 k (cons #f k)))))]
  40            [loop (lambda (inmain curk otherk data)
  41                    (let ([x (car data)] [k (cdr data)])
  42                      (cond
  43                        [(eq? k 'finished) (loop #t otherk false (curk x))]
  44                        [(eq? k 'exit) x]
  45                        [inmain (loop #f k otherk (curk x))]
  46                        [else (loop #t otherk k (curk x))])))])
  47     (loop #t (lambda (x) (reset0 (cons (proc1 yield x) 'finished)))
  48           (lambda (x) (reset0 (cons (proc2 yield x) 'finished)))
  49           (reset0 (cons (main yield start) 'exit)))))
  50
  51 ; the same-fringe application doesn't make use of the 'start or 'restart parameters
  52 ; the 'blah values yielded to the leaf-iterators are ignored too
  53 (define (same-fringe1 tree1 tree2)
  54   (letrec ([next1 (lambda (yield x) (visit yield tree1))]
  55            [next2 (lambda (yield x) (visit yield tree2))]
  56            [main (lambda (yield x)
  57                    (let* ([leaf1 (yield 'blah)]
  58                           [leaf2 (yield 'blah)])
  59                      (cond [(and leaf1 leaf2) (and (equal? leaf1 leaf2) (main yield 'blah))]
  60                            [(or leaf1 leaf2) #f]
  61                            [else #t])))])
  62            (coroutine3 main 'restart next1 next2)))
  63
  64
  65 ; another delimcc solution, based on Biernacki, Danvy and Shan "On the static and dynamic extents of delimited continuations" 2006, section 4.1.4
  66 ; here, next1 = '(leaf1 . thunk_for_more_leaves); final thunk => '(finished . #f)
  67 (define (make-enumerator2 tree)
  68   (define (yield x) (shift k (cons x k)))
  69   (reset (visit yield tree) '(finished . #f)))
  70
  71 (define (same-fringe2 tree1 tree2)
  72   (define next1 (make-enumerator2 tree1))
  73   (define next2 (make-enumerator2 tree2))
  74   (letrec ([loop (lambda (res1 res2)
  75                    (let* ([leaf1 (car res1)]
  76                           [leaf2 (car res2)]
  77                           [next1 (cdr res1)]
  78                           [next2 (cdr res2)])
  79                      (cond
  80                        [(and next1 next2) (and (equal? leaf1 leaf2) (loop (next1) (next2)))]
  81                        [(or next1 next2) #f]
  82                        [else #t])))])
  83     (loop next1 next2)))
  84
  85
  86 ; call/cc solution, from http://c2.com/cgi/wiki?SameFringeProblem ("Scheme Language, using CoRoutines")
  87 ; here, (next1) => '(1 . #t); (next1) => '(2 . #t); (next1) => '(finished . #f)
  88 (define (make-enumerator3 t)
  89   (letrec ([resk #f]
  90            [yieldk #f]
  91            [resume (lambda () (let/cc k
  92                                 (set! yieldk k)
  93                                 (cond [(eq? resk #f)
  94                                        (visit yield t)
  95                                        (set! resk 'finished)
  96                                        (yieldk (cons 'finished #f))]
  97                                       [(eq? resk 'finished)
  98                                        #;(error "End of generator")
  99                                        (yieldk (cons 'finished #f))
 100                                        ]
 101                                       [else (resk)])))]
 102            [yield (lambda (x) (let/cc k
 103                                  (set! resk k)
 104                                  (yieldk (cons x #t))))])
 105     resume))
 106
 107 (define (same-fringe3 tree1 tree2)
 108   (define next1 (make-enumerator3 tree1))
 109   (define next2 (make-enumerator3 tree2))
 110   (letrec ([loop (lambda (res1 res2)
 111                    (let* ([leaf1 (car res1)]
 112                           [leaf2 (car res2)]
 113                           [isleaf1 (cdr res1)]
 114                           [isleaf2 (cdr res2)])
 115                      (cond
 116                        [(and isleaf1 isleaf2) (and (equal? leaf1 leaf2) (loop (next1) (next2)))]
 117                        [(or isleaf1 isleaf2) #f]
 118                        [else #t])))])
 119     (loop (next1) (next2))))
 120
 121
 122
 123 (define (test same-fringe)
 124   (define tree1 '(((1 . 2) . (3 . 4)) . (5 . 6)))
 125   (define tree2 '(1 . (((2 . 3) . (4 . 5)) . 6)))
 126   (define tree3 '(1 . (((2 . 3) . (4 . 5)) . 7)))
 127   (define tree4 '(((1 . 2) . (4 . 5)) . 7))
 128   (define tree5 '(((1 . 2) . (3 . 4)) . 5))
 129   (define tree6 '(((10 . 2) . (3 . 4)) . 5))
 130   (define tree7 8)
 131   (and (same-fringe tree1 tree2)
 132        (same-fringe tree7 tree7)
 133        (not (or
 134              (same-fringe tree1 tree3)
 135              (same-fringe tree1 tree4)
 136              (same-fringe tree4 tree1)
 137              (same-fringe tree5 tree1)
 138              (same-fringe tree1 tree5)
 139              (same-fringe tree1 tree6)
 140              (same-fringe tree6 tree1)
 141              (same-fringe tree6 tree7)
 142              ))))
 143
 144 #|
 145
 146 In Lua, using CoRoutines:
 147  function tree_leaves(tree)
 148     if tree.leaf then
 149         coroutine.yield(tree.leaf)
 150     else
 151         tree_leaves(tree.left)
 152         tree_leaves(tree.right)
 153     end
 154  end
 155  function same_fringe(tree1, tree2)
 156     local iter1 = coroutine.wrap(tree_leaves)
 157     local iter2 = coroutine.wrap(tree_leaves)
 158     for node in iter1, tree1 do
 159         if node ~= iter2(tree2) then
 160             return false
 161         end
 162     end
 163     return iter2() == nil
 164  end
 165
 166 In OCaml:
 167 # #require "delimcc";;
 168 # open Delimcc;;
 169 # type seq = End | Next of int * seq computation
 170   and 'a computation = unit -> 'a;;
 171 # type 'a tree = Leaf of 'a | Node of 'a tree * 'a tree;;
 172 # let rec visit p = function Leaf i -> shift p (fun a -> Next (i, a)) | Node (t1,t2) -> let () = visit p t1 in visit p t2;;
 173 # let prompt mid = let p = new_prompt() in push_prompt p (mid p);;
 174 val prompt : ('a Delimcc.prompt -> unit -> 'a) -> 'a = <fun>
 175 # let make_seq t = prompt (fun p () -> let () = visit p t in End);;
 176 val make_seq : int tree -> seq = <fun>
 177 # let tree1 = Node (Node (Node(Leaf 1,Leaf 2), Node(Leaf 3,Leaf 4)), Node(Leaf 5,Leaf 6));;
 178 # let next1 = make_seq tree1;;
 179 val next1 : seq = Next (1, <fun>)
 180 # let next2 = match next1 with Next(_,f) -> f ();;
 181 val next2 : seq = Next (2, <fun>)
 182 # let next3 = match next2 with Next(_,f) -> f ();;
 183 val next3 : seq = Next (3, <fun>)
 184 # let next4 = match next3 with Next(_,f) -> f ();;
 185 val next4 : seq = Next (4, <fun>)
 186 # let next5 = match next4 with Next(_,f) -> f ();;
 187 val next5 : seq = Next (5, <fun>)
 188 # let next6 = match next5 with Next(_,f) -> f ();;
 189 val next6 : seq = Next (6, <fun>)
 190 # let next7 = match next6 with Next(_,f) -> f ();;
 191 val next7 : seq = End
 192
 193 |#