queues

signature QUEUE =
sig
  type 'a queue

  val empty : 'a queue
  val cons : 'a * 'a queue -> 'a queue
  val snoc : 'a queue * 'a -> 'a queue
  val uncons : 'a queue -> ('a * 'a queue Lazy.lazy) option
end

structure BatchedQueue :> QUEUE =
struct
  type 'a queue = 'a list * 'a list

  val empty = (nil, nil)

  fun check (nil, xs) = (rev xs, nil)
    | check xs = xs

  fun cons (x, (xs, ys)) = (x :: xs, ys)
  fun snoc ((xs, ys), y) = check (xs, y :: ys)

  fun uncons (nil, _) = NONE
    | uncons (x :: xs, ys) = SOME (x, Lazy.delay check (xs, ys))
end

structure RealTimeQueue :> QUEUE =
struct
  structure L = Lazy
  structure S = Stream

  type 'a queue = 'a S.front * 'a list * 'a S.front

  val empty = (S.Nil, nil, S.Nil)

  fun rotate (xs, nil, zs) = S.concat (xs, zs)
    | rotate (S.Nil, ys, zs) = S.reverse (ys, zs)
    | rotate (S.Cons (x, xs), y :: ys, zs) =
      let
        val xs = L.force xs
        val zs = S.Cons (y, L.pure zs)
      in
        S.Cons (x, L.delay rotate (xs, ys, zs))
      end

  fun exec (xs, ys, S.Cons (_, zs)) = (xs, ys, L.force zs)
    | exec xs = let val xs = rotate xs in (xs, nil, xs) end

  fun cons (x, (xs, ys, zs)) = (S.Cons (x, L.pure xs), ys, zs)
  fun snoc ((xs, ys, zs), y) = exec (xs, y :: ys, zs)

  fun uncons (S.Nil, _, _) = NONE
    | uncons (S.Cons (x, xs), ys, zs) =
      SOME (x, L.map (fn xs => exec (xs, ys, zs)) xs)
end

signature CATENABLE =
sig
  type 'a cat

  val empty : 'a cat
  val pure : 'a -> 'a cat
  val concat : 'a cat * 'a cat -> 'a cat
  val uncons : 'a cat -> ('a * 'a cat Lazy.lazy) option
end

functor Catenable (Q : QUEUE) :> CATENABLE =
struct
  structure L = Lazy

  datatype 'a cons = ::: of 'a * 'a cons L.lazy Q.queue

  infixr 5 :::

  fun link (x ::: xs, ys) = x ::: Q.snoc (xs, ys)

  fun linkAll (xs, ys) =
    let
      val xs = L.force xs
      val ys = L.force ys
    in
      case Q.uncons ys of
          NONE => xs
        | SOME ys => link (xs, L.delay linkAll ys)
    end

  type 'a cat = 'a cons option

  val empty = NONE
  fun pure x = SOME (x ::: Q.empty)

  fun concat (xs, NONE) = xs
    | concat (NONE, ys) = ys
    | concat (SOME xs, SOME ys) = SOME (link (xs, L.pure ys))

  fun uncons NONE = NONE
    | uncons (SOME (x ::: xs)) =
      SOME (x, L.delay (Option.map linkAll o Q.uncons) xs)
end

functor CatQueue (C : CATENABLE) : QUEUE =
struct
  type 'a queue = 'a C.cat

  val empty = C.empty
  fun cons (x, xs) = C.concat (C.pure x, xs)
  fun snoc (xs, x) = C.concat (xs, C.pure x)
  fun uncons xs = C.uncons xs
end