From 29afe48d326623b929e68b5f61a9420529d5758f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 5 Nov 2007 11:10:26 -0600
Subject: [PATCH] Update heaps to store key/value pairs instead of objects
comparable by <=> Update docs Add heap-length
---
core/heaps/heaps-docs.factor | 38 +++++++++++++++++++++++------------
core/heaps/heaps-tests.factor | 25 +++++++++++++----------
core/heaps/heaps.factor | 16 ++++++++-------
3 files changed, 48 insertions(+), 31 deletions(-)
diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor
index 3ed2813123..edaa32a6a6 100644
--- a/core/heaps/heaps-docs.factor
+++ b/core/heaps/heaps-docs.factor
@@ -4,7 +4,7 @@ IN: heaps
ARTICLE: "heaps" "Heaps"
"A heap is an implementation of a " { $emphasis "priority queue" } ", which is a structure that maintains a sorted set of elements. The key property is that insertion of an arbitrary element and removal of the first element (determined by order) is performed in O(log n) time."
$nl
-"Heap elements are compared using the " { $link <=> } " generic word."
+"Heap elements are key/value pairs and are compared using the " { $link <=> } " generic word on the first element of the pair."
$nl
"There are two classes of heaps. Min-heaps sort their elements so that the minimum element is first:"
{ $subsection min-heap }
@@ -18,6 +18,7 @@ $nl
$nl
"Queries:"
{ $subsection heap-empty? }
+{ $subsection heap-length }
{ $subsection heap-peek }
"Insertion:"
{ $subsection heap-push }
@@ -31,33 +32,44 @@ ABOUT: "heaps"
HELP: <min-heap>
{ $values { "min-heap" min-heap } }
{ $description "Create a new " { $link min-heap } "." }
-;
+{ $see-also <max-heap> } ;
HELP: <max-heap>
{ $values { "max-heap" max-heap } }
{ $description "Create a new " { $link max-heap } "." }
-;
+{ $see-also <min-heap> } ;
HELP: heap-push
-{ $values { "obj" "an object" } { "heap" "a heap" } }
-{ $description "Push an object onto a heap." } ;
+{ $values { "pair" "a key/value pair" } { "heap" "a heap" } }
+{ $description "Push an pair onto a heap. The first element of the pair must be comparable to the rest of the heap by the " { $link <=> } " word." }
+{ $see-also heap-push-all heap-pop } ;
HELP: heap-push-all
-{ $values { "seq" "a sequence" } { "heap" "a heap" } }
-{ $description "Push a sequence onto a heap." } ;
+{ $values { "seq" "a sequence of pairs" } { "heap" "a heap" } }
+{ $description "Push a sequence of pairs onto a heap." }
+{ $see-also heap-push heap-pop } ;
HELP: heap-peek
-{ $values { "heap" "a heap" } { "obj" "an object" } }
-{ $description "Returns the first element in the heap and leaves it in the heap." } ;
+{ $values { "heap" "a heap" } { "pair" "a key/value pair" } }
+{ $description "Returns the first element in the heap and leaves it in the heap." }
+{ $see-also heap-pop heap-pop* } ;
HELP: heap-pop*
{ $values { "heap" "a heap" } }
-{ $description "Removes the first element from the heap." } ;
+{ $description "Removes the first element from the heap." }
+{ $see-also heap-pop heap-push heap-peek } ;
HELP: heap-pop
-{ $values { "heap" "a heap" } { "obj" "an object" } }
-{ $description "Returns the first element in the heap and removes it from the heap." } ;
+{ $values { "heap" "a heap" } { "pair" "an key/value pair" } }
+{ $description "Returns the first element in the heap and removes it from the heap." }
+{ $see-also heap-pop* heap-push heap-peek } ;
HELP: heap-empty?
{ $values { "heap" "a heap" } { "?" "a boolean" } }
-{ $description "Tests if a " { $link heap } " has no nodes." } ;
+{ $description "Tests if a " { $link heap } " has no nodes." }
+{ $see-also heap-length heap-peek } ;
+
+HELP: heap-length
+{ $values { "heap" "a heap" } { "n" "an integer" } }
+{ $description "Returns the number of key/value pairs in the heap." }
+{ $see-also heap-empty? } ;
diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor
index befbbc90fc..d326480cb8 100644
--- a/core/heaps/heaps-tests.factor
+++ b/core/heaps/heaps-tests.factor
@@ -8,25 +8,28 @@ IN: temporary
[ <max-heap> heap-pop ] unit-test-fails
[ t ] [ <min-heap> heap-empty? ] unit-test
-[ f ] [ <min-heap> 1 over heap-push heap-empty? ] unit-test
+[ f ] [ <min-heap> { 1 t } over heap-push heap-empty? ] unit-test
[ t ] [ <max-heap> heap-empty? ] unit-test
-[ f ] [ <max-heap> 1 over heap-push heap-empty? ] unit-test
+[ f ] [ <max-heap> { 1 t } over heap-push heap-empty? ] unit-test
! Binary Min Heap
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
-{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test
-{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test
+{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test
+{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test
-[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ]
-[ <min-heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over heap-push-all ] unit-test
+[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ]
+[ <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test
-[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [
- <min-heap> { 3 5 4 6 5 7 6 8 } over heap-push-all
+[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [
+ <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all
3 [ dup heap-pop* ] times
] unit-test
-[ 2 ] [ <min-heap> 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push heap-pop ] unit-test
+[ { 2 t } ] [ <min-heap> { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push heap-pop ] unit-test
-[ 1 ] [ <min-heap> 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push 1 over heap-push heap-pop ] unit-test
+[ { 1 t } ] [ <min-heap> { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push { 1 t } over heap-push heap-pop ] unit-test
-[ 400 ] [ <max-heap> 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push 1 over heap-push heap-pop ] unit-test
+[ { 400 t } ] [ <max-heap> { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push { 1 t } over heap-push heap-pop ] unit-test
+
+[ 0 ] [ <max-heap> heap-length ] unit-test
+[ 1 ] [ <max-heap> { 1 t } over heap-push heap-length ] unit-test
diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor
index 74ca9e4b34..c92134c25d 100644
--- a/core/heaps/heaps.factor
+++ b/core/heaps/heaps.factor
@@ -6,7 +6,7 @@ IN: heaps
<PRIVATE
TUPLE: heap data ;
-: <heap> ( class -- obj )
+: <heap> ( class -- heap )
>r V{ } clone heap construct-boa r>
construct-delegate ; inline
PRIVATE>
@@ -29,9 +29,10 @@ TUPLE: max-heap ;
: swap-up ( n vec -- ) >r dup up r> exchange ; inline
: last-index ( vec -- n ) length 1- ; inline
-GENERIC: heap-compare ( obj1 obj2 heap -- ? )
-M: min-heap heap-compare drop <=> 0 > ;
-M: max-heap heap-compare drop <=> 0 < ;
+GENERIC: heap-compare ( pair1 pair2 heap -- ? )
+: (heap-compare) drop [ first ] 2apply <=> 0 ; inline
+M: min-heap heap-compare (heap-compare) > ;
+M: max-heap heap-compare (heap-compare) < ;
: heap-bounds-check? ( m heap -- ? )
heap-data length >= ; inline
@@ -84,12 +85,12 @@ DEFER: down-heap
PRIVATE>
-: heap-push ( obj heap -- )
+: heap-push ( pair heap -- )
tuck heap-data push [ heap-data ] keep up-heap ;
: heap-push-all ( seq heap -- ) [ heap-push ] curry each ;
-: heap-peek ( heap -- obj ) heap-data first ;
+: heap-peek ( heap -- pair ) heap-data first ;
: heap-pop* ( heap -- )
dup heap-data length 1 > [
@@ -100,5 +101,6 @@ PRIVATE>
heap-data pop*
] if ;
-: heap-pop ( heap -- obj ) [ heap-data first ] keep heap-pop* ;
+: heap-pop ( heap -- pair ) [ heap-data first ] keep heap-pop* ;
: heap-empty? ( heap -- ? ) heap-data empty? ;
+: heap-length ( heap -- n ) heap-data length ;