-
Notifications
You must be signed in to change notification settings - Fork 14
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Renamed pqueue-imperative* to ipqueue*
- Loading branch information
1 parent
b5148f7
commit 7e58f90
Showing
9 changed files
with
174 additions
and
175 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
326 changes: 163 additions & 163 deletions
326
pqueue-imperative-pairing.sml → ipqueue-pairing.sml
100755 → 100644
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,163 +1,163 @@ | ||
| (* Author: Rowan Davies <[email protected]> | ||
| This is an pairing heap implementation of imperative priority queues, supporting decreaseKey. | ||
| All operations are constant time aside from deleteMin which is amortized O(log n) time | ||
| unless decreaseKey is called much more often than deleteMin. | ||
| Hence it suitable for use in a number of algorithms that depend on an efficient decreaseKey. | ||
| If the decreaseKey operation isn't needed one of the non-imperative implementations may be | ||
| faster and preferable. | ||
| In practice this data structure tends to be faster than alternatives like Fibonacci heaps | ||
| in basically every situation where decreaseKey is required. | ||
| *) | ||
|
|
||
|
|
||
| functor PairingIPQueue (Key : ORDERED) | ||
| :> IPQUEUE where type Key.t=Key.t = | ||
| struct | ||
| structure Key = Key | ||
| type key = Key.t | ||
|
|
||
|
|
||
| (* type 'a nref = int * 'a ref | ||
| val dbgrefcount = ref 0 | ||
| fun nref x = (dbgrefcount := !dbgrefcount+1; (!dbgrefcount, ref x)) | ||
| infix 3 :== | ||
| fun (_,r):==v = r:=v | ||
| fun !! (_, r) = !r *) | ||
|
|
||
| (* nref below is the same as ref, but the above alternative has been handy for debugging. *) | ||
| (* (This could be a functor arg, but maybe with a performance hit if it's not inlined.) *) | ||
|
|
||
| type 'a nref = 'a ref | ||
| infix 3 :== | ||
| val nref = ref | ||
| val op:== = op:= | ||
| val !! = ! | ||
|
|
||
|
|
||
| (* Invariant: "prev" holds the parent for the firstChild, and the predecessor otherwise. *) | ||
| datatype 'a pqnode = EmptQ | ||
| | Node of {key: key ref, value: 'a, prev: 'a ipqueue, | ||
| firstChild: 'a ipqueue, succ: 'a ipqueue} | ||
| withtype 'a ipqueue = 'a pqnode nref | ||
|
|
||
| type 'a t = 'a ipqueue | ||
|
|
||
| type 'a insertedRef = 'a ipqueue | ||
|
|
||
| infix 4 == (* Test for two references to the same non-empty node. For speed, just compare key refs. *) | ||
| fun r1 == r2 = case (!!r1, !!r2) of (Node {key=k1, ...}, Node {key=k2, ...}) => k1=k2 | ||
| | _ => false | ||
| exception Empty | ||
| fun empty() = nref EmptQ | ||
|
|
||
| fun isEmptyNode EmptQ = true | ||
| | isEmptyNode _ = false | ||
|
|
||
| fun isEmpty pq = isEmptyNode (!!pq) | ||
|
|
||
| fun singleton(k,v) = nref (Node {key=ref k, value=v, prev=empty(), firstChild=empty(), succ=empty() }) | ||
|
|
||
| (* The following is optimized for constant factors, complicating the invariants a little. *) | ||
| (* This is particularly true for meld0, which is optmized for the particular calls later on. *) | ||
|
|
||
| fun setPrev q newp = case !!q of | ||
| EmptQ => () | ||
| | Node{prev=pref, ...} => pref:==newp | ||
|
|
||
| fun mkSucc n succ snew = ( succ := !!snew ; setPrev snew n ) | ||
| fun insFCh n succ fc2 = ( mkSucc n succ fc2 ; fc2 :== n ) | ||
|
|
||
| (* O(1): meld q1 q1 returns either q1 or q2, with the other melded into it. *) | ||
| (* For non-empty nodes, (!q1).succ or (!q2).prev are treated as empty and are overwritten. *) | ||
| (* (!result).prev will be the original (!q1).prev *) | ||
| (* (!result).succ will be the original (!q2).succ *) | ||
| (* But (!(!result).prev).succ/firstChild aren't modified - the calling code should do this. *) | ||
| fun meld q1 q2 = case (!!q1, !!q2) of | ||
| (_, EmptQ) => q1 | ||
| | (EmptQ, _) => q2 | ||
| | (n1 as Node {key=k1, prev=p1, firstChild=fc1, succ=s1, ...}, | ||
| n2 as Node {key=k2, prev=p2, firstChild=fc2, succ=s2, ...} ) => | ||
| case Key.compare(!k1, !k2) of | ||
| LESS => ( mkSucc n1 s1 s2 ; (* Put s2 as successor of n1 *) | ||
| p2 :== n1; (* Make n2 have n1 as parent. *) | ||
| insFCh n2 s2 fc1 ; (* Insert n2 at the front of fc1 *) | ||
| q1 ) | ||
| | _ => ( p2 :== !!p1; (* Put n2 at the top *) | ||
| p1 :== n2; (* Make n1 have n2 as parent. *) | ||
| insFCh n1 s1 fc2 ; (* Insert n1 at the front of fc2 *) | ||
| q2 ) | ||
|
|
||
|
|
||
| (* O(1): inserts kv into q. q should be a root node. Returns a ref for decreaseKey. *) | ||
| fun insertRef q kv = | ||
| let val q1 = singleton kv | ||
| val () = (q :== !!(meld q1 q)) | ||
| in q1 (* q1 can be passed to decreaseKey *) | ||
| end | ||
|
|
||
| (* O(1): inserts kv into q. q should be a root node. *) | ||
| fun insert q kv = ( insertRef q kv; () ) | ||
|
|
||
| (* O(1) *) | ||
| fun findMin q = case !!q of EmptQ => raise Empty | ||
| | (Node {key=k, value=v, ...}) => (!k, v) | ||
|
|
||
| (* This is "2-pass" linking, which is the most standard for pairing heaps. *) | ||
| (* If q1 has two successors q2 and q3, detatch and meld them, recursively for q3. *) | ||
| fun mergePairs q1 = case !!q1 of | ||
| EmptQ => q1 | ||
| | Node {succ=q2, ...} => case !!q2 of | ||
| EmptQ => q1 | ||
| | Node {succ=q3, ...} => | ||
| let val (q2',q3') = (nref (!!q2), nref (!!q3)) in | ||
| q2 :== EmptQ; q3 :== EmptQ; (* detach succ in q1 and q2 *) | ||
| meld (meld q1 q2') (mergePairs q3') (* result.prev = (!q1).prev *) | ||
| end (* (!q2').succ is EmptQ, hence so is (meld q1 q2').succ *) | ||
|
|
||
| (* O(log n) amortized *) | ||
| fun deleteMin q = case !!q of | ||
| EmptQ => raise Empty | ||
| | Node {key=k, value=v, firstChild=fc, ...} => ( q :== !!(mergePairs fc); (!k, v) ) | ||
|
|
||
|
|
||
| (* O(1), but affects the amortized bound for deleteMin, for which it must be counted as *) | ||
| (* O(2^sqrt(log log n)) amortized but this grows very slowly - it is <3 for n<10^300. *) | ||
| fun decreaseKey root insRef newk = case !!insRef of | ||
| EmptQ => raise Fail " ImpPairingPQueue: called decreaseKey on a deleted node." | ||
| | Node {key=k1, value=v1, prev=p1, firstChild=fc1, succ=q2} => | ||
| (k1 := newk; (* modify key, if necessary detach node, then meld with root *) | ||
|
|
||
| if insRef == root then () else | ||
| case !!p1 of | ||
| EmptQ => raise Fail "ImpPairingPQueue: impossible - non-root node has no parent" | ||
| | Node {key=p1k, firstChild=p1fc, succ=p1s, ...} => | ||
| case Key.compare(newk, !!p1k) of | ||
| LESS => ( setPrev q2 (!!p1); | ||
| (if p1fc == insRef (* If insRef is a first child *) | ||
| then p1fc :== (!!q2) (* update the parent *) | ||
| else p1s :== (!!q2) ) ; (* else update the predecessor. *) | ||
| q2:==EmptQ; | ||
| root :== !!(meld root insRef) (* Always overwrites insRef.prev *) | ||
| ) | ||
| | _ => () (* No need to restructure if the new key isn't less than the parent. *) | ||
| ) | ||
|
|
||
|
|
||
| (* keys is mostly for debugging, hence this code doesn't modify the pqueue structure. *) | ||
| fun keys0 q = case !!q of | ||
| EmptQ => [] | ||
| | Node {key=k, value=v, prev, firstChild, succ} => (!k) :: keys0 firstChild @ keys0 succ | ||
|
|
||
| fun keys pq = Mergesort.sort Key.compare (keys0 pq) | ||
|
|
||
| fun meldInto q1 q2 = | ||
| let val qnew = meld q1 q2 in | ||
| ( if q1 = qnew then () else | ||
| q1 := !!qnew ) ; | ||
| q2 := EmptQ | ||
| end | ||
|
|
||
| end | ||
| (* Author: Rowan Davies <[email protected]> | ||
| This is an pairing heap implementation of imperative priority queues, supporting decreaseKey. | ||
| All operations are constant time aside from deleteMin which is amortized O(log n) time | ||
| unless decreaseKey is called much more often than deleteMin. | ||
| Hence it suitable for use in a number of algorithms that depend on an efficient decreaseKey. | ||
| If the decreaseKey operation isn't needed one of the non-imperative implementations may be | ||
| faster and preferable. | ||
| In practice this data structure tends to be faster than alternatives like Fibonacci heaps | ||
| in basically every situation where decreaseKey is required. | ||
| *) | ||
|
|
||
|
|
||
| functor PairingIPQueue (Key : ORDERED) | ||
| :> IPQUEUE where type Key.t=Key.t = | ||
| struct | ||
| structure Key = Key | ||
| type key = Key.t | ||
|
|
||
|
|
||
| (* type 'a nref = int * 'a ref | ||
| val dbgrefcount = ref 0 | ||
| fun nref x = (dbgrefcount := !dbgrefcount+1; (!dbgrefcount, ref x)) | ||
| infix 3 :== | ||
| fun (_,r):==v = r:=v | ||
| fun !! (_, r) = !r *) | ||
|
|
||
| (* nref below is the same as ref, but the above alternative has been handy for debugging. *) | ||
| (* (This could be a functor arg, but maybe with a performance hit if it's not inlined.) *) | ||
|
|
||
| type 'a nref = 'a ref | ||
| infix 3 :== | ||
| val nref = ref | ||
| val op:== = op:= | ||
| val !! = ! | ||
|
|
||
|
|
||
| (* Invariant: "prev" holds the parent for the firstChild, and the predecessor otherwise. *) | ||
| datatype 'a pqnode = EmptQ | ||
| | Node of {key: key ref, value: 'a, prev: 'a ipqueue, | ||
| firstChild: 'a ipqueue, succ: 'a ipqueue} | ||
| withtype 'a ipqueue = 'a pqnode nref | ||
|
|
||
| type 'a t = 'a ipqueue | ||
|
|
||
| type 'a insertedRef = 'a ipqueue | ||
|
|
||
| infix 4 == (* Test for two references to the same non-empty node. For speed, just compare key refs. *) | ||
| fun r1 == r2 = case (!!r1, !!r2) of (Node {key=k1, ...}, Node {key=k2, ...}) => k1=k2 | ||
| | _ => false | ||
| exception Empty | ||
| fun empty() = nref EmptQ | ||
|
|
||
| fun isEmptyNode EmptQ = true | ||
| | isEmptyNode _ = false | ||
|
|
||
| fun isEmpty pq = isEmptyNode (!!pq) | ||
|
|
||
| fun singleton(k,v) = nref (Node {key=ref k, value=v, prev=empty(), firstChild=empty(), succ=empty() }) | ||
|
|
||
| (* The following is optimized for constant factors, complicating the invariants a little. *) | ||
| (* This is particularly true for meld0, which is optmized for the particular calls later on. *) | ||
|
|
||
| fun setPrev q newp = case !!q of | ||
| EmptQ => () | ||
| | Node{prev=pref, ...} => pref:==newp | ||
|
|
||
| fun mkSucc n succ snew = ( succ := !!snew ; setPrev snew n ) | ||
| fun insFCh n succ fc2 = ( mkSucc n succ fc2 ; fc2 :== n ) | ||
|
|
||
| (* O(1): meld q1 q1 returns either q1 or q2, with the other melded into it. *) | ||
| (* For non-empty nodes, (!q1).succ or (!q2).prev are treated as empty and are overwritten. *) | ||
| (* (!result).prev will be the original (!q1).prev *) | ||
| (* (!result).succ will be the original (!q2).succ *) | ||
| (* But (!(!result).prev).succ/firstChild aren't modified - the calling code should do this. *) | ||
| fun meld q1 q2 = case (!!q1, !!q2) of | ||
| (_, EmptQ) => q1 | ||
| | (EmptQ, _) => q2 | ||
| | (n1 as Node {key=k1, prev=p1, firstChild=fc1, succ=s1, ...}, | ||
| n2 as Node {key=k2, prev=p2, firstChild=fc2, succ=s2, ...} ) => | ||
| case Key.compare(!k1, !k2) of | ||
| LESS => ( mkSucc n1 s1 s2 ; (* Put s2 as successor of n1 *) | ||
| p2 :== n1; (* Make n2 have n1 as parent. *) | ||
| insFCh n2 s2 fc1 ; (* Insert n2 at the front of fc1 *) | ||
| q1 ) | ||
| | _ => ( p2 :== !!p1; (* Put n2 at the top *) | ||
| p1 :== n2; (* Make n1 have n2 as parent. *) | ||
| insFCh n1 s1 fc2 ; (* Insert n1 at the front of fc2 *) | ||
| q2 ) | ||
|
|
||
|
|
||
| (* O(1): inserts kv into q. q should be a root node. Returns a ref for decreaseKey. *) | ||
| fun insertRef q kv = | ||
| let val q1 = singleton kv | ||
| val () = (q :== !!(meld q1 q)) | ||
| in q1 (* q1 can be passed to decreaseKey *) | ||
| end | ||
|
|
||
| (* O(1): inserts kv into q. q should be a root node. *) | ||
| fun insert q kv = ( insertRef q kv; () ) | ||
|
|
||
| (* O(1) *) | ||
| fun findMin q = case !!q of EmptQ => raise Empty | ||
| | (Node {key=k, value=v, ...}) => (!k, v) | ||
|
|
||
| (* This is "2-pass" linking, which is the most standard for pairing heaps. *) | ||
| (* If q1 has two successors q2 and q3, detatch and meld them, recursively for q3. *) | ||
| fun mergePairs q1 = case !!q1 of | ||
| EmptQ => q1 | ||
| | Node {succ=q2, ...} => case !!q2 of | ||
| EmptQ => q1 | ||
| | Node {succ=q3, ...} => | ||
| let val (q2',q3') = (nref (!!q2), nref (!!q3)) in | ||
| q2 :== EmptQ; q3 :== EmptQ; (* detach succ in q1 and q2 *) | ||
| meld (meld q1 q2') (mergePairs q3') (* result.prev = (!q1).prev *) | ||
| end (* (!q2').succ is EmptQ, hence so is (meld q1 q2').succ *) | ||
|
|
||
| (* O(log n) amortized *) | ||
| fun deleteMin q = case !!q of | ||
| EmptQ => raise Empty | ||
| | Node {key=k, value=v, firstChild=fc, ...} => ( q :== !!(mergePairs fc); (!k, v) ) | ||
|
|
||
|
|
||
| (* O(1), but affects the amortized bound for deleteMin, for which it must be counted as *) | ||
| (* O(2^sqrt(log log n)) amortized but this grows very slowly - it is <3 for n<10^300. *) | ||
| fun decreaseKey root insRef newk = case !!insRef of | ||
| EmptQ => raise Fail " ImpPairingPQueue: called decreaseKey on a deleted node." | ||
| | Node {key=k1, value=v1, prev=p1, firstChild=fc1, succ=q2} => | ||
| (k1 := newk; (* modify key, if necessary detach node, then meld with root *) | ||
|
|
||
| if insRef == root then () else | ||
| case !!p1 of | ||
| EmptQ => raise Fail "ImpPairingPQueue: impossible - non-root node has no parent" | ||
| | Node {key=p1k, firstChild=p1fc, succ=p1s, ...} => | ||
| case Key.compare(newk, !!p1k) of | ||
| LESS => ( setPrev q2 (!!p1); | ||
| (if p1fc == insRef (* If insRef is a first child *) | ||
| then p1fc :== (!!q2) (* update the parent *) | ||
| else p1s :== (!!q2) ) ; (* else update the predecessor. *) | ||
| q2:==EmptQ; | ||
| root :== !!(meld root insRef) (* Always overwrites insRef.prev *) | ||
| ) | ||
| | _ => () (* No need to restructure if the new key isn't less than the parent. *) | ||
| ) | ||
|
|
||
|
|
||
| (* keys is mostly for debugging, hence this code doesn't modify the pqueue structure. *) | ||
| fun keys0 q = case !!q of | ||
| EmptQ => [] | ||
| | Node {key=k, value=v, prev, firstChild, succ} => (!k) :: keys0 firstChild @ keys0 succ | ||
|
|
||
| fun keys pq = Mergesort.sort Key.compare (keys0 pq) | ||
|
|
||
| fun meldInto q1 q2 = | ||
| let val qnew = meld q1 q2 in | ||
| ( if q1 = qnew then () else | ||
| q1 := !!qnew ) ; | ||
| q2 := EmptQ | ||
| end | ||
|
|
||
| end |
0
pqueue-imperative.sig → ipqueue.sig
100755 → 100644
File renamed without changes.
File renamed without changes.
File renamed without changes.
File renamed without changes.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.