sequences.extras: add another heap slurping combinator

Fix tests..

diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index 8c3335060cec48543cbe436e789c04b08203eb07..38455fb4489782d679d08520f7d954b786d95b2c 100644 (file)
--- a/extra/sequences/extras/extras-tests.factor
+++ b/extra/sequences/extras/extras-tests.factor
@@ -287,10 +287,10 @@ tools.test vectors vocabs ;
 { { 1 3 } } [ 1 5 2 10 <iota> <step-slice> >array ] unit-test
 { { 1 3 5 } } [ 1 6 2 10 <iota> <step-slice> >array ] unit-test
 
-{ { 2 3 5 } } [
-    [ swap [ * ] [ 100 + ] if* ] map-with-previous
+{ { 102 306 1530 } } [
+    { 2 3 5 } [ swap [ * ] [ 100 + ] if* ] map-with-previous
 ] unit-test
 
 { { } } [
-    [ nip ] map-with-previous
+    { } [ nip ] map-with-previous
 ] unit-test

diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index 9cd86797b8d0f5f882db920b5963ee074dd41e33..ae0de0ae73607fb56fd0747b53a9820b41ccfd8f 100644 (file)
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -491,6 +491,33 @@ PRIVATE>
 : zero-loop>array ( quot: ( ..a n -- ..a obj ) -- seq )
     { } zero-loop>sequence ; inline
 
+: iterate-heap-while ( heap quot1: ( value key -- slurp? ) quot2: ( value key -- obj/f ) -- obj/f loop? )
+    pick heap-empty?
+    [ 3drop f f ]
+    [
+        [ [ heap-peek ] 2dip drop 2keep ]
+        [
+            nip ! ( pop? value key heap quot2 )
+            5roll [
+                swap heap-pop* call( value key -- obj/f ) t
+            ] [
+                4drop f f
+            ] if
+        ] 3bi
+    ] if ; inline
+
+: slurp-heap-while-map ( heap quot1: ( value key -- slurp? ) quot2: ( value key -- obj/f ) -- seq )
+    '[ _ _ _ iterate-heap-while ] loop>array* ; inline
+
+: heap>pairs ( heap -- pairs )
+    [ 2drop t ] [ swap 2array ] slurp-heap-while-map ;
+
+: map-zip-swap ( quot: ( x -- y ) -- alist )
+    '[ _ keep ] map>alist ; inline
+
+: ?heap-pop-value>array ( heap -- array )
+    dup heap-empty? [ drop { } ] [ heap-pop drop 1array ] if ;
+
 <PRIVATE
 
 : (reverse) ( seq -- newseq )