(* Chris Okasaki
   School of Computer Science
   Carnegie Mellon University
   Pittsburgh, PA 15213
   cokasaki@cs.cmu.edu *)

functor SkewBinomialQueue (E:ORDERED) : PRIORITY_QUEUE =
struct
    structure Elem = E

    type Rank = int
    datatype Tree = Node of Elem.T * Rank * Tree list
    type T = Tree list

    (* auxiliary functions *)
    fun root (Node (x,r,c)) = x
    fun rank (Node (x,r,c)) = r
    fun link (t1 as Node (x1,r1,c1), t2 as Node (x2,r2,c2)) =  (* r1 = r2 *)
          if Elem.leq (x1,x2) then Node (x1,r1+1,t2 :: c1) 
                              else Node (x2,r2+1,t1 :: c2)
    fun skewLink (t0 as Node (x0,r0,_), t1 as Node (x1,r1,c1), 
                                        t2 as Node (x2,r2,c2)) =
          (* r0 = 0 andalso r1 = r2 *)
          if Elem.leq (x1,x0) andalso Elem.leq (x1,x2) then 
	      Node (x1,r1+1,t0 :: t2 :: c1)
          else if Elem.leq (x2,x0) andalso Elem.leq (x2,x1) then 
	      Node (x2,r2+1,t0 :: t1 :: c2)
          else
	      Node (x0,r1+1,[t1,t2])
    fun ins (t,[]) = [t]
      | ins (t,t' :: ts) = (* rank t <= rank t' *)
          if rank t < rank t' then t :: t' :: ts
          else ins (link (t,t'), ts)

    fun uniqify [] = []
      | uniqify (t :: ts) = ins (t, ts)  (* eliminate initial duplicate *)
    fun meldUniq ([], ts) = ts
      | meldUniq (ts, []) = ts
      | meldUniq (t1 :: ts1,t2 :: ts2) =
          if      rank t1 < rank t2 then t1 :: meldUniq (ts1, t2 :: ts2)
          else if rank t2 < rank t1 then t2 :: meldUniq (t1 :: ts1, ts2)
          else ins (link (t1,t2), meldUniq (ts1,ts2))

    val empty = []
    fun isEmpty ts = null ts

    fun insert (x, ts as t1 :: t2 :: rest) =
          if rank t1 = rank t2 then skewLink (Node (x,0,[]),t1,t2) :: rest
          else Node (x,0,[]) :: ts
      | insert (x, ts) = Node (x,0,[]) :: ts
    fun meld (ts, ts') = meldUniq (uniqify ts,uniqify ts')

    exception EMPTY

    fun findMin [] = raise EMPTY
      | findMin [t] = root t
      | findMin (t :: ts) =
          let val x = root t
              val y = findMin ts
          in
              if Elem.leq (x,y) then x else y
          end
    fun deleteMin [] = raise EMPTY
      | deleteMin ts =
          let fun getMin [t] = (t, [])
                | getMin (t :: ts) =
                    let val (t', ts') = getMin ts
                    in
			if Elem.leq (root t,root t') then (t, ts)
			                             else (t', t :: ts')
                    end
              fun split (ts,xs,[]) = (ts,xs)
		| split (ts,xs,t :: c) =
                    if rank t = 0 then split (ts,root t :: xs,c) 
		                  else split (t::ts,xs,c)
	      val (Node (x,r,c), ts) = getMin ts
              val (ts',xs') = split ([],[],c)
	  in
	      fold insert xs' (meld (ts,ts'))
	  end
end