From 220e27baa06a76e6cd94cdf5ca69cda045a7d1a9 Mon Sep 17 00:00:00 2001 From: Jim Pryor Date: Thu, 2 Jun 2011 19:46:28 -0400 Subject: [PATCH] added same-fringe Signed-off-by: Jim Pryor --- code/same-fringe.rkt | 193 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 193 insertions(+) create mode 100644 code/same-fringe.rkt diff --git a/code/same-fringe.rkt b/code/same-fringe.rkt new file mode 100644 index 00000000..8a8a7ba1 --- /dev/null +++ b/code/same-fringe.rkt @@ -0,0 +1,193 @@ +#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 + +|# -- 2.11.0