(* Source code from                               *)
(*   Chris Okasaki                                *)
(*   "Functional Data Structures"                 *)
(*   Second International Summer School on        *)
(*     Advanced Functional Programming Techniques *)
(*   August, 1996                                 *)

signature CATENABLE =
sig
  type 'a Cat                              (* catenable lists *)

  exception EMPTY

  val empty   : 'a Cat
  val isEmpty : 'a Cat -> bool

  val unit    : 'a -> 'a Cat               (* create a singleton list *)
  val ++      : 'a Cat * 'a Cat -> 'a Cat  (* infix append *)

  val head    : 'a Cat -> 'a      (* raises EMPTY if list is empty *)
  val tail    : 'a Cat -> 'a Cat  (* raises EMPTY if list is empty *)
end


structure Cat0 : CATENABLE =
struct
  datatype 'a Cat = Empty | Unit of 'a | App of 'a Cat * 'a Cat

  exception EMPTY

  val empty = Empty
  fun isEmpty Empty = true | isEmpty _ = false

  fun unit x = Unit x
  fun Empty ++ s = s
    | s ++ Empty = s
    | s ++ t = App (s, t)

  fun head Empty = raise EMPTY
    | head (Unit x) = x
    | head (App (s, t)) = head s
  fun tail Empty = raise EMPTY
    | tail (Unit x) = Empty
    | tail (App (Unit x, s)) = s
    | tail (App (App (s, t), u)) = tail (App (s, App (t, u)))
end


functor Cat1 (structure Q : QUEUE) : CATENABLE =
struct
  datatype 'a Cat = Empty | Cat of 'a * 'a Cat susp Q.Queue

  exception EMPTY

  val empty = Empty
  fun isEmpty Empty = true | isEmpty _ = false

  fun link (Cat (x, q), d) = Cat (x, Q.snoc (q, d))
  fun linkAll q =
        if Q.size q = 1 then force (Q.head q)
        else link (force (Q.head q), delay (fn () => linkAll (Q.tail q)))

  fun unit x = Cat (x, Q.empty)
  fun Empty ++ s = s
    | s ++ Empty = s
    | s ++ t = link (s, delay (fn () => t))

  fun head Empty = raise EMPTY
    | head (Cat (x, q)) = x
  fun tail Empty = raise EMPTY
    | tail (Cat (x, q)) = if Q.isEmpty q then Empty else linkAll q
end


functor TestC (C : CATENABLE) : sig val ok : bool end =
struct
  open C

  fun cons (x, s) = unit x ++ s
  fun snoc (x, s) = s ++ unit x

  val make1 = foldr cons empty
  val make2 = foldl cons empty

  fun make3 xs =
        let fun mk [] = empty
              | mk [s] = s
              | mk ss = mk (pairup ss)
            and pairup (s1 :: s2 :: ss) = (s1 ++ s2) :: pairup ss
              | pairup ss = ss
        in mk (map unit xs) end

  fun list q = if isEmpty q then [] else head q :: list (tail q)

  val xs = [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]

  exception BUG

  val ok = if list (make1 xs) = xs andalso 
              list (make2 xs) = rev xs andalso
              list (make3 xs) = xs
           then true
           else raise BUG
end