COS 441 - Examples of coroutines in ML

datatype tree = T of tree * tree | L of int

datatype ('v,'answer) Arg = YIELD of 'v * ('v,'answer) Stream  |  DONE
withtype ('v,'answer) Stream = (('v,'answer) Arg -> 'answer) -> 'answer
     and ('v,'answer) Consumer = ('v,'answer) Arg -> 'answer

fun walk(T(a,b),f, k) = walk(a,f, fn f'=>walk(b,f',k))
  | walk(L x, f, k) = f(YIELD(x, k))

fun terminatedWalk(t) = fn f => walk(t,f, fn f' => f' DONE)

fun print'em(YIELD(i, k)) = (print(Int.toString i); print " "; k print'em)
  | print'em DONE = ()

fun samefringe(t1, t2) = 
  let fun loop(k1, k2) =
        k1(fn x1 => k2(fn x2 =>
          case (x1,x2) 
           of (YIELD(i,k1'), YIELD(j,k2')) =>
                      if i=j then loop(k1',k2') else false
            | (DONE, DONE) => true
            | _ => false))
   in loop(terminatedWalk t1, terminatedWalk t2)
  end

val t1 = T(T(T(L 1, L 2),L 3),T(L 4, L 5))

val t2 = T(L 1, T(L 2, T(T(L 3, L 4), L 5)))

val t3 = T(L 1, T(L 2, T(T(L 3, L 5), L 4)));

val t1t2 = samefringe(t1,t2);

val t1t3 = samefringe(t1,t3);

structure C = SMLofNJ.Cont
type 'a cont = 'a C.cont
val callcc: ('a cont -> 'a) -> 'a = C.callcc
val throw : 'a cont -> ('a -> 'b) = C.throw

exception Error
exception Terminated

type 'a generator = unit->'a

fun badcont() = callcc(fn k => 
                 (callcc(fn k' => throw k k'); raise Error))

fun mkGen (walker : ('a -> unit) -> unit) : 'a generator = 
  let val yieldref : 'a cont ref = ref (badcont())
      val nextref : unit cont ref = ref (badcont())

      fun yield i = 
	    callcc(fn k =>
                   (nextref := k;  throw (!yieldref) i))

      fun next() =
            callcc(fn k => 
                  (yieldref := k;  throw (!nextref) ()))
 
      val first = callcc(fn k =>
                    (callcc(fn k' => throw k k');
                     walker yield;
                     raise Terminated))

    in  nextref := first;
       next
   end

fun genPrint(ig : int option generator) =
 let fun loop() = 
        case ig() of SOME i => (print(Int.toString i); print " "; loop())
                   | NONE => ()
  in loop()
 end

datatype tree = T of tree * tree | L of int

fun treeGen(t : tree) : int option generator =
 mkGen(fn yield : (int option -> unit) =>
    let fun walk(T(a,b)) = (walk(a); walk(b))
          | walk(L x) = yield (SOME x)
     in walk t; yield NONE
    end)

val t1 = T(T(T(L 1, L 2),L 3),T(L 4, L 5))

val t2 = T(L 1, T(L 2, T(T(L 3, L 4), L 5)))

val t3 = T(L 1, T(L 2, T(T(L 3, L 5), L 4)));

val _ = genPrint(treeGen t1);

fun samefringe(t1, t2) = 
  let val g1 = treeGen t1  and  g2 = treeGen t2
      fun loop() =
          case (g1(), g2())
           of (SOME i, SOME j) => if i=j then loop() else false
            | (NONE, NONE) => true
            | _ => false
   in loop()
  end

val t1 = T(T(T(L 1, L 2),L 3),T(L 4, L 5))

val t2 = T(L 1, T(L 2, T(T(L 3, L 4), L 5)))

val t3 = T(L 1, T(L 2, T(T(L 3, L 5), L 4)));

val t1t2 = samefringe(t1,t2);

val t1t3 = samefringe(t1,t3);