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

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

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

    (* auxiliary functions *)
    fun root (Node (x,r,cf)) = x
    fun rank (Node (x,r,cf)) = r
    fun link (t1 as Node (x1,r1,cf1), t2 as Node (x2,r2,cf2)) =  (* r1 = r2 *)
          if Elem.leq (x1,x2) then Node (x1,r1+1,t2 :: cf1) 
                              else Node (x2,r2+1,t1 :: cf2)
    fun skewLink (t0 as Node (x0,r0,cf0), t1 as Node (x1,r1,cf1), 
                                          t2 as Node (x2,r2,cf2)) =
          (* r0 = 0 andalso r1 = r2 *)
          if Elem.leq (x1,x0) andalso Elem.leq (x1,x2) then 
	      Node (x1,r1+1,t0 :: t2 :: cf1)
          else if Elem.leq (x2,x0) andalso Elem.leq (x2,x1) then 
	      Node (x2,r2+1,t0 :: t1 :: cf2)
          else
	      Node (x0,r1+1,t1 :: t2 :: cf0)
    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))

    fun skewInsert (t, ts as t1 :: t2 :: rest) =  (* rank t = 0 *)
          if rank t1 = rank t2 then skewLink (t,t1,t2) :: rest
          else t :: ts
      | skewInsert (t, ts) = t :: ts
    fun skewMeld (ts, ts') = meldUniq (uniqify ts,uniqify ts')

    val empty = Empty
    fun isEmpty Empty = true
      | isEmpty (NonEmpty _) = false

    fun insert (x, Empty) = NonEmpty (Node (x,0,[]))
      | insert (x, NonEmpty (t as Node (y,_,f))) =
	  if Elem.leq (x,y) then NonEmpty (Node (x,0,[t]))
	  else NonEmpty (Node (y,0,skewInsert (Node (x,0,[]), f)))
    fun meld (Empty, q) = q
      | meld (q, Empty) = q
      | meld (NonEmpty (t1 as Node (x1,_,f1)),
	      NonEmpty (t2 as Node (x2,_,f2))) =
          if Elem.leq (x1,x2) then NonEmpty (Node (x1,0,skewInsert (t2,f1)))
                              else NonEmpty (Node (x2,0,skewInsert (t1,f2)))

    exception EMPTY

    fun findMin Empty = raise EMPTY
      | findMin (NonEmpty t) = root t
    fun deleteMin Empty = raise EMPTY
      | deleteMin (NonEmpty (Node (x,_,[]))) = Empty
      | deleteMin (NonEmpty (Node (x,_,f))) =
          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 (0,zs,ts,f) = (zs,ts,f)
		| split (1,zs,ts,[t]) = (zs,t::ts,[])
		| split (1,zs,ts,t1 :: t2 :: f) = (* rank t1 = 0 *)
		    if rank t2 = 0 then (t1::zs,t2::ts,f)
                    else (zs,t1::ts,t2::f)
		| split (r,zs,ts,t1 :: t2 :: cf) = 
		    let val r1 = rank t1  (* r1=r-1 orelse r1 = 0 *)
                    in
			 if r1 = rank t2 then (zs,t1 :: t2 :: ts,cf)
			 else if r1 = 0 then (* rank t2 = r-1 *)
			     split (r-1,t1 :: zs,t2 :: ts,cf)
			 else
                             split (r-1,zs,t1 :: ts,t2 :: cf)
		    end
	      val (Node (x,r,cf), ts2) = getMin f
              val (zs,ts1,f) = split (r,[],[],cf)
	      val f' = skewMeld (skewMeld (ts1,ts2), f)
	  in
	      NonEmpty (Node (x,0,foldr skewInsert f' zs))
	  end
end