Update heaps to store key/value pairs instead of objects comparable by <=>

Update docs
Add heap-length

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? } ;

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

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 ;