From 7e58f90cc854788de66c623f7da9f7d4940eef21 Mon Sep 17 00:00:00 2001 From: Rowan Davies Date: Thu, 29 Aug 2013 19:17:47 +0800 Subject: [PATCH] Renamed pqueue-imperative* to ipqueue* --- cmlib.cm | 5 +- cmlib.mlb | 6 +- ...erative-pairing.sml => ipqueue-pairing.sml | 326 +++++++++--------- pqueue-imperative.sig => ipqueue.sig | 0 ...imperative-check.sml => ipqueue-check.sml} | 0 ...e-imperative-list.sml => ipqueue-list.sml} | 0 tests/{pq-imp-test.sml => ipqueue-test.sml} | 0 tests/test.cm | 6 +- tests/test.mlb | 6 +- 9 files changed, 174 insertions(+), 175 deletions(-) rename pqueue-imperative-pairing.sml => ipqueue-pairing.sml (97%) mode change 100755 => 100644 rename pqueue-imperative.sig => ipqueue.sig (100%) mode change 100755 => 100644 rename tests/{pqueue-imperative-check.sml => ipqueue-check.sml} (100%) rename tests/{pqueue-imperative-list.sml => ipqueue-list.sml} (100%) rename tests/{pq-imp-test.sml => ipqueue-test.sml} (100%) diff --git a/cmlib.cm b/cmlib.cm index 45e17de..825e000 100755 --- a/cmlib.cm +++ b/cmlib.cm @@ -295,6 +295,8 @@ is hash-table-dataless.sml ideque.sig ideque.sml + ipqueue.sig + ipqueue-pairing.sml iqueue.sig iqueue.sml juliasort.sml @@ -317,9 +319,6 @@ is pos.sig pos.sml pqueue.sig - pqueue-imperative.sig - pqueue-imperative-list.sml - pqueue-imperative-pairing.sml pqueue-lazy-pairing.sml pqueue-leftist.sml pqueue-pairing.sml diff --git a/cmlib.mlb b/cmlib.mlb index 5687b65..45ff477 100755 --- a/cmlib.mlb +++ b/cmlib.mlb @@ -94,7 +94,7 @@ local parsing.sml lex-engine.sig lex-engine.sml - pqueue-imperative.sig + ipqueue.sig sort.sig mergesort.sml juliasort.sml @@ -121,7 +121,7 @@ local sequence-array.sml partition.sml coroutine.sig - pqueue-imperative-pairing.sml + ipqueue-pairing.sml parse-engine.sig parse-engine.sml cont.sig @@ -348,7 +348,6 @@ in functor FortunaFun functor HashTable functor HashTableTable - functor PairingIPQueue functor LazyPairingPQueue functor LeftistPQueue functor LexEngineFun @@ -360,6 +359,7 @@ in functor MultiFileIOFun functor MonomorphizeStreamable functor OFBCipherFun + functor PairingIPQueue functor PairingPQueue functor ParseEngineFun functor ParsingFun diff --git a/pqueue-imperative-pairing.sml b/ipqueue-pairing.sml old mode 100755 new mode 100644 similarity index 97% rename from pqueue-imperative-pairing.sml rename to ipqueue-pairing.sml index 5a7d48f..194f15e --- a/pqueue-imperative-pairing.sml +++ b/ipqueue-pairing.sml @@ -1,163 +1,163 @@ -(* Author: Rowan Davies - - 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 + + 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 diff --git a/pqueue-imperative.sig b/ipqueue.sig old mode 100755 new mode 100644 similarity index 100% rename from pqueue-imperative.sig rename to ipqueue.sig diff --git a/tests/pqueue-imperative-check.sml b/tests/ipqueue-check.sml similarity index 100% rename from tests/pqueue-imperative-check.sml rename to tests/ipqueue-check.sml diff --git a/tests/pqueue-imperative-list.sml b/tests/ipqueue-list.sml similarity index 100% rename from tests/pqueue-imperative-list.sml rename to tests/ipqueue-list.sml diff --git a/tests/pq-imp-test.sml b/tests/ipqueue-test.sml similarity index 100% rename from tests/pq-imp-test.sml rename to tests/ipqueue-test.sml diff --git a/tests/test.cm b/tests/test.cm index fa674df..aeeebe9 100755 --- a/tests/test.cm +++ b/tests/test.cm @@ -9,6 +9,6 @@ Group is quicksort-test.sml sets-dicts-test.sml test-collection.sml - pqueue-imperative-list.sml - pqueue-imperative-check.sml - pq-imp-test.sml + ipqueue-list.sml + ipqueue-check.sml + ipqueue-test.sml diff --git a/tests/test.mlb b/tests/test.mlb index 600082c..461eb49 100755 --- a/tests/test.mlb +++ b/tests/test.mlb @@ -7,7 +7,7 @@ mergesort-test.sml mergesort-qcheck.sml quicksort-test.sml - pqueue-imperative-list.sml - pqueue-imperative-check.sml - pq-imp-test.sml + ipqueue-list.sml + ipqueue-check.sml + ipqueue-test.sml sets-dicts-test.sml