From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 23 Aug 2022 13:21:25 +0000 (-0400)
Subject: sequences.extras: Add 2map-filter and variants where the second sequence
X-Git-Tag: 0.99~598
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=ce8720367564a71a1c8dae53fa0cdb97c2d31081

sequences.extras: Add 2map-filter and variants where the second sequence
is not known before the word is called
---

diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index 5d044a1781..a294ae4c94 100644
--- a/extra/sequences/extras/extras-tests.factor
+++ b/extra/sequences/extras/extras-tests.factor
@@ -1,5 +1,6 @@
-USING: accessors arrays ascii io io.streams.string kernel make
-math prettyprint sequences sequences.extras strings tools.test ;
+USING: accessors arrays ascii grouping io io.streams.string
+kernel make math prettyprint ranges sequences sequences.extras
+strings tools.test ;
 
 { V{ { 0 104 } { 2 108 } { 3 108 } } } [ "hello" [ even? ] find-all ] unit-test
 
@@ -352,3 +353,22 @@ math prettyprint sequences sequences.extras strings tools.test ;
 { { -995 11 26 61 } } [
     1000 V{ 5 16 42 103 } [ - ] { } map-prior-identity-as
 ] unit-test
+
+{ V{ 1 4 9 } } [
+    { 1 2 3 } { 1 2 3 }
+    [ 2dup 2array all-eq? [ * ] [ 2drop f ] if ]
+    V{ } 2nested-filter-as
+] unit-test
+
+{ V{ 1 8 27 } } [
+    { 1 2 3 } { 1 2 3 } { 1 2 3 }
+    [ 3dup 3array all-eq? [ * * ] [ 3drop f ] if ]
+    V{ } 3nested-filter-as
+] unit-test
+
+{ V{ 0 2 0 3 6 4 12 0 5 10 15 20 } } [
+    6 [1..b)
+    [ [0..b) ]
+    [ 2dup [ odd? ] bi@ or [ * ] [ 2drop f ] if  ]
+    2nested-filter*
+] unit-test
diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index 83320228b9..b6a3bb2c83 100644
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -75,6 +75,9 @@ IN: sequences.extras
 : push-if* ( ..a elt quot: ( ..a elt -- ..b obj/f ) accum -- ..b )
     [ call ] dip [ push ] [ drop ] if* ; inline
 
+: push? ( elt/f accum -- )
+    over [ push ] [ 2drop ] if ; inline
+
 <PRIVATE
 
 : (index-selector-as) ( quot length exampler -- selector accum )
@@ -784,11 +787,57 @@ M: step-slice length
 
 INSTANCE: step-slice virtual-sequence
 
+: 2nested-each* ( seq1 seq-quot: ( n -- seq ) quot: ( a b -- ) -- )
+    '[
+        _ keep swap _ with each
+    ] each ; inline
+
+: 2nested-filter-as* ( seq1 seq-quot quot exemplar -- seq )
+    [ 2over [ length ] bi@ * ] dip
+    [
+        new-resizable
+        [ [ push? ] curry compose 2nested-each* ] keep
+    ] keep like ; inline
+
+: 2nested-filter* ( seq1 seq-quot quot -- seq )
+    pick 2nested-filter-as* ; inline
+
+: 2nested-map-as* ( seq1 seq-quot quot exemplar -- seq )
+    [ 2over [ length ] bi@ * ] dip
+    [
+        new-resizable
+        [ [ push ] curry compose 2nested-each* ] keep
+    ] keep like ; inline
+
+: 2nested-map* ( seq1 seq-quot quot -- seq )
+    pick 2nested-map-as* ; inline
+
+
 : 2nested-each ( seq1 seq2 quot -- )
     swapd '[
         swap _ with each
     ] with each ; inline
 
+: 2nested-filter-as ( seq1 seq2 quot exemplar -- seq )
+    [ 2over [ length ] bi@ * ] dip
+    [
+        new-resizable
+        [ [ push? ] curry compose 2nested-each ] keep
+    ] keep like ; inline
+
+: 2nested-filter ( seq1 seq2 quot -- seq )
+    pick 2nested-filter-as ; inline
+
+: 2nested-map-as ( seq1 seq2 quot exemplar -- seq )
+    [ 2over [ length ] bi@ * ] dip
+    [
+        new-resizable
+        [ [ push ] curry compose 2nested-each ] keep
+    ] keep like ; inline
+
+: 2nested-map ( seq1 seq2 quot -- seq )
+    pick 2nested-map-as ; inline
+
 : 3nested-each ( seq1 seq2 seq3 quot -- )
     [ spin ] dip '[
         -rot [
@@ -796,20 +845,26 @@ INSTANCE: step-slice virtual-sequence
         ] with with each
     ] with with each ; inline
 
-: 2nested-map ( seq1 seq2 quot -- seq )
-    2over [ length ] bi@ * reach
+: 3nested-filter-as ( seq1 seq2 seq3 quot exemplar -- seq )
+    [ 3 nover [ length ] tri@ * * ] dip
     [
         new-resizable
-        [ [ push ] curry compose 2nested-each ] keep
+        [ [ push? ] curry compose 3nested-each ] keep
     ] keep like ; inline
 
-: 3nested-map ( seq1 seq2 seq3 quot -- seq )
-    3 nover [ length ] tri@ * * 5 npick
+: 3nested-filter ( seq1 seq2 seq3 quot -- seq )
+    reach 3nested-filter-as ; inline
+
+: 3nested-map-as ( seq1 seq2 seq3 quot exemplar -- seq )
+    [ 3 nover [ length ] tri@ * * ] dip
     [
         new-resizable
         [ [ push ] curry compose 3nested-each ] keep
     ] keep like ; inline
 
+: 3nested-map ( seq1 seq2 seq3 quot -- seq )
+    reach 3nested-map-as ; inline
+
 : prev ( n seq -- obj ) [ 1 - ] dip nth ; inline
 : ?prev ( n seq -- obj/f ) [ 1 - ] dip ?nth ; inline
 : ??prev ( n seq -- obj/f ? ) [ 1 - ] dip ??nth ; inline