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: { $values { "min-heap" min-heap } } { $description "Create a new " { $link min-heap } "." } -; +{ $see-also } ; HELP: { $values { "max-heap" max-heap } } { $description "Create a new " { $link max-heap } "." } -; +{ $see-also } ; 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 [ heap-pop ] unit-test-fails [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over heap-push heap-empty? ] unit-test +[ f ] [ { 1 t } over heap-push heap-empty? ] unit-test [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over heap-push heap-empty? ] unit-test +[ f ] [ { 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 } } } ] -[ { 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 } } } } ] +[ { { 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 } } } ] [ - { 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 } } } } ] [ + { { 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 ] [ 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 } ] [ { 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 ] [ 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 } ] [ { 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 ] [ 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 } ] [ { 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 ] [ heap-length ] unit-test +[ 1 ] [ { 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 ( class -- obj ) +: ( 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 ;