root/trunk/Library/Heap.fss

(*******************************************************************************
    Copyright 2009 Sun Microsystems, Inc.,
    4150 Network Circle, Santa Clara, California 95054, U.S.A.
    All rights reserved.

    U.S. Government Rights - Commercial software.
    Government users are subject to the Sun Microsystems, Inc. standard
    license agreement and applicable provisions of the FAR and its supplements.

    Use is subject to license terms.

    This distribution may include materials developed by third parties.

    Sun, Sun Microsystems, the Sun logo and Java are trademarks or registered
    trademarks of Sun Microsystems, Inc. in the U.S. and other countries.
 ******************************************************************************)

component Heap
export Heap

(************************************************************
 * Mergeable, pure priority queues (heaps).                 *)

(** At the moment we're baking off several potential priority queue
  implementations, based on part on some advice from "Purely
  Functional Data Structures" by Okasaki.

  * Pairing Heaps, the current default:
    O(1) merge
    O(lg n) amortized extractMinimum, with O(n) worst case.  The worst
    case is proportional to the number of deferred merge operations
    performed with the min; if you merge n entries tree-fashion rather
    than 1 at a time you should obtain O(lg n) worst case performance
    as well.  The heap(gen) function will follow the merge structure
    of the underlying generator; for a well-written generator this
    will be sufficient to give good performance.

  * Lazy-esque pairing heaps (supposedly slower but actually easier in
  some ways to implement than pairing heaps, and avoiding a potential
  stack overflow in the latter).  These don't seem to be quite as
  whizzy in this setting as ordinary Pairing Heaps.
    O(lg n) merge
    O(lg n) worst-case extractMinimum

  * Splay heaps (noted as "fastest in practice", borne out by other
    experiments).  Problem: O(n) merge operation, vs O(lg n) for
    everything else.  If we build heaps by performing reductions over
    a generator, with each iteration generating a few elements, this
    will be a problem.  This is not yet implemented.

   Minimum complete implementation of Heap[\K,V\]:
     empty
     singleton
     isEmpty
     extractMinimum
     merge(Heap[\K,V\])
 **)
trait Heap[\K,V\] extends Generator[\(K,V)\]
    (** Given an instance of Heap[\K,V\], get the empty Heap[\K,V\] **)
    getter empty(): Heap[\K,V\]
    (** Get the (key,value) pair with minimal associated key **)
    getter minimum(): Maybe[\(K,V)\] =
        if (k,v,_) <- extractMinimum() then
            Just[\(K,V)\](k,v)
        else
            Nothing[\(K,V)\]
        end
    (** Check the invariants on the heap. **)
    check(): Heap[\K,V\]
    (** Given an instance of Heap[\K,V\], generate a singleton Heap[\K,V\] **)
    singleton(k:K, v:V): Heap[\K,V\]
    (** Return a heap that contains the key-value pairings in both of
        the heaps passed in. **)
    merge(h:Heap[\K,V\]): Heap[\K,V\]
    (** Return a heap that contains the additional key-value pairs **)
    insert(k:K, v:V): Heap[\K,V\] = self.merge(self.singleton[\K,V\](k,v))
    (** Extract the (key,value) pair with minimal associated key,
     along with a heap with that key and value pair removed. **)
    extractMinimum(): Maybe[\(K,V,Heap[\K,V\])\]
    (** Delete the minimum (key,value) pair (if any) from the heap,
        and return the resulting heap. *)
    deleteMinimum(): Heap[\K,V\] =
        if (_,_,r) <- extractMinimum() then r else self end
    (** We generate elements by repeated splitting.  This is fairly
        allocation-intensive (O(n) worst case) but gives reasonable
        parallelism. **)
    generate[\R\](r: Reduction[\R\], body: (K,V)->R): R = do
        go(n:ZZ32, h: Heap[\K,V\]): R =
            if h.isEmpty then
                r.empty
            else
                kvs = array[\(K,V)\](n)
                hh : Heap[\K,V\] := h
                i : ZZ32 := 0
                while NOT hh.isEmpty AND i < n do
                    (k,v,hhh) = hh.extractMinimum().get
                    kvs.init(i,(k,v))
                    i += 1
                    hh := hhh
                end
                r.join(kvs[0#i].generate[\R\](r,body),go(n+n, hh))
            end
        go(8,self)
      end
end

object HeapMerge[\K,V\](boiler: Heap[\K,V\])
        extends CommutativeMonoidReduction[\Heap[\K,V\]\]
    getter asString():String = "Heap merge reduction"
    getter empty(): Heap[\K,V\] = boiler.empty
    join(a:Heap[\K,V\], b:Heap[\K,V\]): Heap[\K,V\] = a.merge(b)
end

hm[\K,V\](boiler: Heap[\K,V\]):HeapMerge[\K,V\] = HeapMerge[\K,V\](boiler)

trait Pairing[\K,V\] extends Heap[\K,V\]
        comprises { EmptyP[\K,V\], NodeP[\K,V\] }
    getter empty(): Pairing[\K,V\] = EmptyP[\K,V\]
    getter asDebugString(): String
    singleton(k:K, v:V): Pairing[\K,V\] = do
        e = self.empty
        NodeP[\K,V\](k,v,e,e)
      end
    (* emk merges a node and all its siblings. *)
    emk(e: EmptyP[\K,V\]): Pairing[\K,V\]
    (* ems merges a node with its left sibling, then merges that with
       its remaining siblings. *)
    ems(e: EmptyP[\K,V\], leftSib: NodeP[\K,V\]): NodeP[\K,V\]
end

object EmptyP[\K,V\] extends Pairing[\K,V\]
    getter isEmpty(): Boolean = true
    getter minimum(): Nothing[\(K,V)\] = Nothing[\(K,V)\]
    getter asDebugString(): String = "E"
    check(): EmptyP[\K,V\] = self
    check(pk:K):Boolean = true
    merge(h:Heap[\K,V\]): Heap[\K,V\] = h
    merge(h:Pairing[\K,V\]): Pairing[\K,V\] = h
    insert(k:K, v:V): Pairing[\K,V\] = NodeP[\K,V\](k,v,self,self)
    extractMinimum(): Nothing[\(K,V,Pairing[\K,V\])\] = Nothing[\(K,V,Pairing[\K,V\])\]
    emk(e: EmptyP[\K,V\]): Pairing[\K,V\] = self
    ems(_: EmptyP[\K,V\], leftSib: NodeP[\K,V\]): NodeP[\K,V\] = leftSib
    generate[\R\](r: Reduction[\R\], body: (K,V)->R): R = r.empty
end

object NodeP[\K,V\](k:K, v:V, sibs: Pairing[\K,V\], kids: Pairing[\K,V\])
        extends Pairing[\K,V\]
    getter isEmpty(): Boolean = false
    getter minimum(): Just[\(K,V)\] = Just[\(K,V)\](k,v)
    getter asDebugString():String = "N(" k "," v "," sibs.asDebugString "," kids.asDebugString ")"
    check():Heap[\K,V\] = do
        if NOT sibs.isEmpty then
            println( //"FAIL: Non-empty sibs in:" // self.asDebugString// )
            fail("dying")
        end
        if NOT kids.check(k) then
            println( //"FAIL: heap structure violation in:" // self.asDebugString// )
        end
        self
      end
    check(pk:K):Boolean = pk <= k AND sibs.check(pk) AND kids.check(k)
    merge(other:Heap[\K,V\]): Heap[\K,V\] = merge(pairing[\K,V\](other))
    merge(_:Pairing[\K,V\]): Pairing[\K,V\] =
        fail("Pairing but not NodeP/EmptyP")
    merge(_:EmptyP[\K,V\]): Pairing[\K,V\] = self
    merge(h:NodeP[\K,V\]): Pairing[\K,V\] = merge(self.empty,h)
    merge(e:EmptyP[\K,V\], _:EmptyP[\K,V\]): Pairing[\K,V\] = self
    merge(e:EmptyP[\K,V\], h:NodeP[\K,V\]): Pairing[\K,V\] =
        if h.k <= k then
            NodeP[\K,V\](h.k, h.v, e, NodeP[\K,V\](  k,   v, h.kids,   kids))
        else
            NodeP[\K,V\](  k,   v, e, NodeP[\K,V\](h.k, h.v,   kids, h.kids))
        end
    insert(k':K, v':V): Pairing[\K,V\] =
        if k' <= k then (* ' *)
            NodeP[\K,V\](k',v',self.empty,self)
        else
            e = self.empty
            NodeP[\K,V\](k,v,e,NodeP[\K,V\](k',v',kids,e))
        end
    extractMinimum(): Just[\(K,V,Pairing[\K,V\])\] =
        Just[\(K,V,Pairing[\K,V\])\](k,v,kids.emk(self.empty))
(*
    emk(e: EmptyP[\K,V\]): Pairing[\K,V\] = do
        res : Pairing[\K,V\] = e
        todo : Pairing[\K,V\] := self
        while NOT todo.isEmpty do
            (m,td) = if todo.sibs.isEmpty then
                         (todo,e)
                     else
                         (todo.merge(e,todo.sibs),todo.sibs.sibs)
                     end
            res := m.merge(e,res)
            todo := td
        end
        res
      end
*)
    emk(e: EmptyP[\K,V\]): Pairing[\K,V\] = sibs.ems(e,self)
    ems(e: EmptyP[\K,V\], leftSib: NodeP[\K,V\]): NodeP[\K,V\] =
        merge(e,leftSib).merge(e,sibs.emk(e))
end

emptyPairing[\K,V\](): Pairing[\K,V\] = EmptyP[\K,V\]
singletonPairing[\K,V\](k:K, v:V): Pairing[\K,V\] =
    emptyPairing[\K,V\]().singleton(k,v)

pairing[\K,V\](g:Generator[\(K,V)\]): Pairing[\K,V\] = do
    e = emptyPairing[\K,V\]()
    g.generate[\Heap[\K,V\]\](
        hm[\K,V\](e),
        fn (k:K, v:V): Pairing[\K,V\] => e.singleton(k,v))
  end

(************************************************************
 * Not actually lazy pairing heaps; these are actuallly more
 * eager in that they merge siblings incrementally on insertion.
 *)

trait LazyPairing[\K,V\] extends Heap[\K,V\]
        comprises { EmptyLP[\K,V\], NodeLP[\K,V\] }
    getter empty(): LazyPairing[\K,V\] = EmptyLP[\K,V\]
    getter asDebugString(): String
    singleton(k:K, v:V): LazyPairing[\K,V\] = do
        e = self.empty
        NodeLP[\K,V\](k,v,e,e)
      end
    (** link the min over the max, with the current node pending. **)
    plink(e:EmptyLP[\K,V\],mn:NodeLP[\K,V\],mx:NodeLP[\K,V\]):NodeLP[\K,V\]
end

object EmptyLP[\K,V\] extends LazyPairing[\K,V\]
    getter isEmpty(): Boolean = true
    getter minimum(): Nothing[\(K,V)\] = Nothing[\(K,V)\]
    getter asDebugString(): String = "EL"
    check():Heap[\K,V\] = self
    check(pk:K):Boolean = true
    merge(h:Heap[\K,V\]): Heap[\K,V\] = h
    merge(h:LazyPairing[\K,V\]): LazyPairing[\K,V\] = h
    insert(k:K, v:V): LazyPairing[\K,V\] = NodeLP[\K,V\](k,v,self,self)
    extractMinimum(): Nothing[\(K,V,LazyPairing[\K,V\])\] = Nothing[\(K,V,LazyPairing[\K,V\])\]
    plink(e:EmptyLP[\K,V\],mn:NodeLP[\K,V\],mx:NodeLP[\K,V\]):NodeLP[\K,V\] =
        NodeLP[\K,V\](mn.k,mn.v,mx,mn.kids)
    generate[\R\](r: Reduction[\R\], body: (K,V)->R): R = r.empty
end

object NodeLP[\K,V\](k:K, v:V, pending: LazyPairing[\K,V\], kids: LazyPairing[\K,V\])
        extends LazyPairing[\K,V\]
    getter isEmpty(): Boolean = false
    getter minimum(): Just[\(K,V)\] = Just[\(K,V)\](k,v)
    getter asDebugString():String = "NL(" k "," v "," pending.asDebugString "," kids.asDebugString ")"
    check():Heap[\K,V\] = do
        if NOT kids.check(k) then
            println( //"FAIL: heap structure violation in:" // self.asDebugString// )
        end
        self
      end
    check(pk:K):Boolean = pk <= k AND pending.check(k) AND kids.check(k)
    merge(other:Heap[\K,V\]): Heap[\K,V\] = merge(lazy[\K,V\](other))
    merge(_:LazyPairing[\K,V\]): LazyPairing[\K,V\] =
        fail("LazyPairing but not NodeLP/EmptyLP")
    merge(_:EmptyLP[\K,V\]): LazyPairing[\K,V\] = self
    merge(h:NodeLP[\K,V\]): LazyPairing[\K,V\] = merge(self.empty,h)
    merge(e:EmptyLP[\K,V\], _:EmptyLP[\K,V\]): LazyPairing[\K,V\] = self
    merge(e:EmptyLP[\K,V\], h:NodeLP[\K,V\]): LazyPairing[\K,V\] =
        if h.k <= k then
            h.link(e,self)
        else
            self.link(e,h)
        end
    insert(k':K, v':V): LazyPairing[\K,V\] =
        if k' <= k then (* ' *)
            NodeLP[\K,V\](k',v',self,self.empty)
        else
            e = self.empty
            link(e,NodeLP[\K,V\](k',v',e,e))
        end
    extractMinimum(): Just[\(K,V,LazyPairing[\K,V\])\] =
        Just[\(K,V,LazyPairing[\K,V\])\](k,v,pending.merge(kids))
    link(e:EmptyLP[\K,V\],n:NodeLP[\K,V\]):NodeLP[\K,V\] =
        pending.plink(e,self,n)
    plink(e:EmptyLP[\K,V\],mn:NodeLP[\K,V\],mx:NodeLP[\K,V\]):NodeLP[\K,V\] =
        NodeLP[\K,V\](mn.k,mn.v,e,self.merge(mx).merge(mn.kids))
end

emptyLazy[\K,V\](): LazyPairing[\K,V\] = EmptyLP[\K,V\]
singletonLazy[\K,V\](k:K, v:V): LazyPairing[\K,V\] =
    emptyLazy[\K,V\]().singleton(k,v)

lazy[\K,V\](g:Generator[\(K,V)\]): Heap[\K,V\] = do
    e : Heap[\K,V\] = emptyLazy[\K,V\]()
    g.generate[\Heap[\K,V\]\](
        hm[\K,V\](e),
        fn (k:K, v:V): LazyPairing[\K,V\] => e.singleton(k,v))
  end

(************************************************************
 * And the winner is...
 * Non-lazy pairing heaps!
 ************************************************************)

emptyHeap[\K,V\](): Pairing[\K,V\] = emptyPairing[\K,V\]()
singletonHeap[\K,V\](k:K, v:V): Pairing[\K,V\] = singletonPairing[\K,V\](k,v)
heap[\K,V\](g:Generator[\(K,V)\]): Pairing[\K,V\] = pairing[\K,V\](g)

end