add slurp-heap-when, document heap-slurp-*

basis/heaps/heaps-docs.factor

@@ -1,5 +1,5 @@
 USING: heaps.private help.markup help.syntax kernel math assocs
-math.order ;
+math.order quotations ;
 IN: heaps
 
 ARTICLE: "heaps" "Heaps"
@@ -28,7 +28,11 @@ $nl
 "Removal:"
 { $subsection heap-pop* }
 { $subsection heap-pop }
-{ $subsection heap-delete } ;
+{ $subsection heap-delete }
+$nl
+"Processing heaps:"
+{ $subsection slurp-heap }
+{ $subsection slurp-heap-when } ;
 
 ABOUT: "heaps"
 
@@ -82,3 +86,13 @@ HELP: heap-delete
 { $description "Remove the specified entry from the heap." }
 { $errors "Throws an error if the entry is from another heap or if it has already been deleted." }
 { $side-effects "heap" } ;
+
+HELP: slurp-heap
+{ $values
+     { "heap" "a heap" } { "quot" quotation } }
+{ $description "Removes values from a heap and processes them with the quotation until the heap is empty." } ;
+
+HELP: slurp-heap-when
+{ $values
+     { "heap" "a heap" } { "quot1" quotation } { "quot2" quotation } }
+{ $description "Removes values from a heap that match the predicate quotation " { $snippet "quot1" } " and processes them with " { $snippet "quot2" } " until the predicate quotation no longer matches." } ;

basis/heaps/heaps.factor

@@ -195,3 +195,9 @@ M: heap heap-pop ( heap -- value key )
     over heap-empty? [ 2drop ] [
         [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
     ] if ; inline recursive
+
+: slurp-heap-when ( heap quot1 quot2: ( value key -- ) -- )
+    pick heap-empty? [ 3drop ] [
+        [ [ heap-pop dup ] 2dip slip [ t ] compose [ 2drop f ] if ]
+        [ roll [ slurp-heap-when ] [ 3drop ] if ] 3bi
+    ] if ; inline recursive