#lang racket (require racket/control) ; this tells Scheme to let us use shift and reset (define (visit yield t) (cond [(pair? t) (visit yield (car t)) (visit yield (cdr t))] [else (yield t)])) ; delimcc-based implementation of coroutines, following http://okmij.org/ftp/continuations/implementations.html#caml-shift (define (coroutine2 main start thread) (letrec ([yield (lambda (x) (shift0 k (cons x k)))] [loop (lambda (curk data) (let ([x (car data)] [k (cdr data)]) (cond [(eq? k 'finished) (loop curk (curk x))] [(eq? k 'exit) x] [else (loop k (curk x))])))]) (loop (lambda (x) (reset0 (cons (thread yield x) 'finished))) (reset0 (cons (main yield start) 'exit))))) ; call/cc-based, following Xavier Leroy's ocaml-callcc (define (coroutine2^ main start thread) (let/cc initk (let* ([curk initk] [yield (lambda (x) (let/cc k (let ([oldk curk]) (set! curk k) (oldk x))))]) (main yield (begin (thread yield (let/cc k2 (set! curk k2) start))))))) (define (proc coroutine2 max1 max2) (letrec ([proc1 (lambda (yield n) (if (>= n max1) (begin (displayln "1: exit") 100) (begin (display "1: received ") (displayln n) (proc1 yield (yield (+ 1 n))))))] [proc2 (lambda (yield n) (if (>= n max2) (begin (displayln "2: finished") -2) (begin (display "2: received ") (displayln n) (proc2 yield (yield (+ 1 n))))))]) (coroutine2 proc1 0 proc2))) ; the following is meant to be a general-purpose handler with the following behavior: ; 1. call main with start ; 2. first yield to proc1, which yields back to main, ; 3. then main yields to proc2, which yields back to main; and so on ; 4. when either proc finishes, subsequent yields from main which would have gone to that procedure instead always return #f ; 5. we stop looping only when main finishes (define (coroutine3 main start proc1 proc2) (letrec ([yield (lambda (x) (shift0 k (cons x k)))] [false (lambda (x) (reset0 (false (shift0 k (cons #f k)))))] [loop (lambda (inmain curk otherk data) (let ([x (car data)] [k (cdr data)]) (cond [(eq? k 'finished) (loop #t otherk false (curk x))] [(eq? k 'exit) x] [inmain (loop #f k otherk (curk x))] [else (loop #t otherk k (curk x))])))]) (loop #t (lambda (x) (reset0 (cons (proc1 yield x) 'finished))) (lambda (x) (reset0 (cons (proc2 yield x) 'finished))) (reset0 (cons (main yield start) 'exit))))) ; the same-fringe application doesn't make use of the 'start or 'restart parameters ; the 'blah values yielded to the leaf-iterators are ignored too (define (same-fringe1 tree1 tree2) (letrec ([next1 (lambda (yield x) (visit yield tree1))] [next2 (lambda (yield x) (visit yield tree2))] [main (lambda (yield x) (let* ([leaf1 (yield 'blah)] [leaf2 (yield 'blah)]) (cond [(and leaf1 leaf2) (and (equal? leaf1 leaf2) (main yield 'blah))] [(or leaf1 leaf2) #f] [else #t])))]) (coroutine3 main 'restart next1 next2))) ; another delimcc solution, based on Biernacki, Danvy and Shan "On the static and dynamic extents of delimited continuations" 2006, section 4.1.4 ; here, next1 = '(leaf1 . thunk_for_more_leaves); final thunk => '(finished . #f) (define (make-enumerator2 tree) (define (yield x) (shift k (cons x k))) (reset (visit yield tree) '(finished . #f))) (define (same-fringe2 tree1 tree2) (define next1 (make-enumerator2 tree1)) (define next2 (make-enumerator2 tree2)) (letrec ([loop (lambda (res1 res2) (let* ([leaf1 (car res1)] [leaf2 (car res2)] [next1 (cdr res1)] [next2 (cdr res2)]) (cond [(and next1 next2) (and (equal? leaf1 leaf2) (loop (next1) (next2)))] [(or next1 next2) #f] [else #t])))]) (loop next1 next2))) ; call/cc solution, from http://c2.com/cgi/wiki?SameFringeProblem ("Scheme Language, using CoRoutines") ; here, (next1) => '(1 . #t); (next1) => '(2 . #t); (next1) => '(finished . #f) (define (make-enumerator3 t) (letrec ([resk #f] [yieldk #f] [resume (lambda () (let/cc k (set! yieldk k) (cond [(eq? resk #f) (visit yield t) (set! resk 'finished) (yieldk (cons 'finished #f))] [(eq? resk 'finished) #;(error "End of generator") (yieldk (cons 'finished #f)) ] [else (resk)])))] [yield (lambda (x) (let/cc k (set! resk k) (yieldk (cons x #t))))]) resume)) (define (same-fringe3 tree1 tree2) (define next1 (make-enumerator3 tree1)) (define next2 (make-enumerator3 tree2)) (letrec ([loop (lambda (res1 res2) (let* ([leaf1 (car res1)] [leaf2 (car res2)] [isleaf1 (cdr res1)] [isleaf2 (cdr res2)]) (cond [(and isleaf1 isleaf2) (and (equal? leaf1 leaf2) (loop (next1) (next2)))] [(or isleaf1 isleaf2) #f] [else #t])))]) (loop (next1) (next2)))) (define (test same-fringe) (define tree1 '(((1 . 2) . (3 . 4)) . (5 . 6))) (define tree2 '(1 . (((2 . 3) . (4 . 5)) . 6))) (define tree3 '(1 . (((2 . 3) . (4 . 5)) . 7))) (define tree4 '(((1 . 2) . (4 . 5)) . 7)) (define tree5 '(((1 . 2) . (3 . 4)) . 5)) (define tree6 '(((10 . 2) . (3 . 4)) . 5)) (define tree7 8) (and (same-fringe tree1 tree2) (same-fringe tree7 tree7) (not (or (same-fringe tree1 tree3) (same-fringe tree1 tree4) (same-fringe tree4 tree1) (same-fringe tree5 tree1) (same-fringe tree1 tree5) (same-fringe tree1 tree6) (same-fringe tree6 tree1) (same-fringe tree6 tree7) )))) #| In Lua, using CoRoutines: function tree_leaves(tree) if tree.leaf then coroutine.yield(tree.leaf) else tree_leaves(tree.left) tree_leaves(tree.right) end end function same_fringe(tree1, tree2) local iter1 = coroutine.wrap(tree_leaves) local iter2 = coroutine.wrap(tree_leaves) for node in iter1, tree1 do if node ~= iter2(tree2) then return false end end return iter2() == nil end In OCaml: # #require "delimcc";; # open Delimcc;; # type seq = End | Next of int * seq computation and 'a computation = unit -> 'a;; # type 'a tree = Leaf of 'a | Node of 'a tree * 'a tree;; # 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;; # let prompt mid = let p = new_prompt() in push_prompt p (mid p);; val prompt : ('a Delimcc.prompt -> unit -> 'a) -> 'a = # let make_seq t = prompt (fun p () -> let () = visit p t in End);; val make_seq : int tree -> seq = # let tree1 = Node (Node (Node(Leaf 1,Leaf 2), Node(Leaf 3,Leaf 4)), Node(Leaf 5,Leaf 6));; # let next1 = make_seq tree1;; val next1 : seq = Next (1, ) # let next2 = match next1 with Next(_,f) -> f ();; val next2 : seq = Next (2, ) # let next3 = match next2 with Next(_,f) -> f ();; val next3 : seq = Next (3, ) # let next4 = match next3 with Next(_,f) -> f ();; val next4 : seq = Next (4, ) # let next5 = match next4 with Next(_,f) -> f ();; val next5 : seq = Next (5, ) # let next6 = match next5 with Next(_,f) -> f ();; val next6 : seq = Next (6, ) # let next7 = match next6 with Next(_,f) -> f ();; val next7 : seq = End |#