Flatten Revisited

flatten_revisited.sml

datatype 'a Tree = 
    Leaf 
  | Branch of {value : 'a, left : 'a Tree, right : 'a Tree}


fun flatten t = case t of
  Leaf => []
| Branch {value, left, right} => let
  val l = flatten left
  val r = flatten right
in
  l @ (value :: r)
end


fun flatten_ t = loop t (fn x => x)
and loop t return = case t of
  Leaf                        => return []
| Branch {value, left, right} => loop left (fn l => 
                                   loop right (fn r => 
                                     return (l @ (value :: r))
                                   )
                                 )



fun flatten t = loop t done
and done x = x
and loop t return = case t of
  Leaf                                    => return []
| Branch {value, left, right}             => loop   left  (do_right (right, value, return))
and do_right (right, value, return) left  =  loop   right (combine  (left, value, return) )
and combine  (left,  value, return) right =  return (left @ (value :: right))



datatype 'a cont = DONE 
                 | DO_RIGHT of {right : 'a Tree, value : 'a, return : 'a cont}
                 | COMBINE  of {left  : 'a list, value : 'a, return : 'a cont}

fun flatten t = loop t DONE
and loop t return = case t of
  Leaf                                            => apply return []
| Branch {value, left, right}                     => loop  left (DO_RIGHT {right=right, value=value, return=return})
and apply  DONE                                x  =  x
  | apply (DO_RIGHT {right, value, return}) left  =  loop   right (COMBINE {left=left, value=value, return=return} )
  | apply (COMBINE  {left,  value, return}) right =  apply return (left @ (value :: right))




datatype 'a cont = DONE 
                 | DO_RIGHT of {right : 'a Tree, value : 'a, return : 'a cont}
                 | COMBINE  of {left  : 'a list, value : 'a, return : 'a cont}


datatype 'a state = LOOP     of {t : 'a Tree, callback : 'a cont}
                  | APPLY    of {env : 'a cont, arg : 'a list }
                  | COMPLETE of 'a list


fun init t = LOOP {t=t, callback=DONE}
fun poll (LOOP  {t, callback}) = (case t
                                   of Leaf                        => APPLY { env = callback, arg = [] }
                                    | Branch {value, left, right} => LOOP  { t=left, callback=DO_RIGHT {right=right, value=value, return=callback}}
                                 )
  | poll (APPLY {env, arg})   = (case env
                                  of DONE                            =>  COMPLETE arg
                                   | DO_RIGHT {right, value, return} =>  LOOP     {t = right, callback = COMBINE {left=arg, value=value, return=return} }
                                   | COMBINE  {left,  value, return} =>  APPLY    {env = return, arg = left @ (value :: arg)}
                                 )
  | poll (c as COMPLETE _)    = c

fun flatten t = let val s = init t
                    fun run (COMPLETE c) = c
                      | run otherwise    = run (poll otherwise)
                 in
                   run s
                 end