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

signature ORDERED =
sig
  type T                   (* type of ordered elements *)
  val leq : T * T -> bool  (* total ordering relation *)
end


signature HEAP =
sig
  structure Elem : ORDERED

  type Heap

  exception EMPTY

  val empty   : Heap
  val isEmpty : Heap -> bool

  val unit      : Elem.T -> Heap  (* create a singleton heap *)
  val merge     : Heap * Heap -> Heap

  val findMin   : Heap -> Elem.T  (* raises EMPTY if heap is empty *)
  val deleteMin : Heap -> Heap    (* raises EMPTY if heap is empty *)
end


functor Leftist (structure E : ORDERED) : HEAP =
struct
  structure Elem = E

  datatype Heap = Empty | Node of int * Elem.T * Heap * Heap

  exception EMPTY

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

  fun node (x, a, Empty) = Node (1, x, a, Empty)
    | node (x, Empty, b) = Node (1, x, b, Empty)
    | node (x, a as Node (ra,_,_,_), b as Node (rb,_,_,_)) =
        if ra <= rb then Node (ra+1, x, b, a) else Node (rb+1, x, a, b)

  fun unit x = Node (1, x, Empty, Empty)
  fun merge (a, Empty) = a
    | merge (Empty, b) = b
    | merge (a as Node (_, x, a1, a2), b as Node (_, y, b1, b2)) =
        if Elem.leq (x, y) then node (x, a1, merge (a2, b))
                           else node (y, b1, merge (a, b2))

  fun findMin Empty = raise EMPTY
    | findMin (Node (r, x, a, b)) = x
  fun deleteMin Empty = raise EMPTY
    | deleteMin (Node (r, x, a, b)) = merge (a, b)
end


functor Pairing0 (structure E : ORDERED) : HEAP =
struct
  structure Elem = E

  datatype Heap = Empty | Node of Elem.T * Heap list

  exception EMPTY

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

  fun unit x = Node (x, [])
  fun merge (a, Empty) = a
    | merge (Empty, b) = b
    | merge (a as Node (x, cs), b as Node (y, ds)) =
        if Elem.leq (x, y) then Node (x, b :: cs) else Node (y, a :: ds)

  fun mergeAll [] = Empty
    | mergeAll [a] = a
    | mergeAll (a :: b :: rest) = merge (merge (a, b), mergeAll rest)

  fun findMin Empty = raise EMPTY
    | findMin (Node (x, cs)) = x
  fun deleteMin Empty = raise EMPTY
    | deleteMin (Node (x, cs)) = mergeAll cs
end


functor Pairing1 (structure E : ORDERED) : HEAP =
struct
  structure Elem = E

  datatype Heap = Empty | Node of Elem.T * Heap * Heap susp

  exception EMPTY

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

  fun unit x = Node (x, Empty, delay (fn () => Empty))
  fun merge (a, Empty) = a
    | merge (Empty, b) = b
    | merge (a as Node (x,_,_), b as Node (y,_,_)) =
        if Elem.leq (x, y) then link (a, b) else link (b, a)
  and link (Node (x, Empty, m), a) = Node (x, a, m)
    | link (Node (x, b, m), a) =
        Node (x, Empty, delay (fn () => merge (merge (a, b), force m)))

  fun findMin Empty = raise EMPTY
    | findMin (Node (x, a, m)) = x
  fun deleteMin Empty = raise EMPTY
    | deleteMin (Node (x, a, m)) = merge (a, force m)
end


structure IntOrd : ORDERED =
struct
  type T = int
  val leq = Int.<=
end

structure CharOrd : ORDERED =
struct
  type T = char
  val leq = Char.<=
end

functor TestH (functor MakeH (structure E : ORDERED) : sig
                                                         include HEAP
                                                         sharing Elem = E
                                                       end)
              : sig val ok : bool end =
struct
  structure H = MakeH (structure E = CharOrd)
  open H

  fun insert (x, h) = merge (unit x, h)

  val make1 = foldr insert empty
  fun make2 xs =
        let fun mk [] = empty
              | mk [h] = h
              | mk hs = mk (pairup hs)
            and pairup (h1 :: h2 :: hs) = merge (h1, h2) :: pairup hs
              | pairup hs = hs
        in mk (map unit xs) end

  fun list h = if isEmpty h then [] else findMin h :: list (deleteMin h)

  fun quicksort (xs : char list) =
        let fun qsort ([], rest) = rest
              | qsort ([x], rest) = x :: rest
              | qsort (x :: xs, rest) = 
                  let fun partition ([], lo, hi) =
                            qsort (lo, x :: qsort (hi, rest))
                        | partition (y :: ys, lo, hi) =
                            if y <= x then partition (ys, y::lo, hi)
                                      else partition (ys, lo, y::hi)
                  in partition (xs, [], []) end
	in qsort (xs, []) end

  val xs = explode "the quick brown fox jumped over the lazy dog"

  val sorted_xs = quicksort xs

  exception BUG

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