From c21bce02af6c4b8b61e05108814059ac25d13eca Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 25 Aug 2022 21:22:27 -0400
Subject: [PATCH] sequences.extras: add a version of filter-map and 2filter-map
 that take one quot

and a version that take two quots.
---
 extra/sequences/extras/extras-tests.factor | 17 +++++
 extra/sequences/extras/extras.factor       | 73 +++++++++++++++++++---
 2 files changed, 80 insertions(+), 10 deletions(-)

diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor
index 18beca57b3..b64ddfcbdd 100644
--- a/extra/sequences/extras/extras-tests.factor
+++ b/extra/sequences/extras/extras-tests.factor
@@ -124,8 +124,25 @@ strings tools.test ;
 ] unit-test
 
 { V{ 0 4 16 36 64 } } [ 10 <iota> [ even? ] [ sq ] filter-map ] unit-test
+{ V{ 0 4 16 36 64 } } [ 10 <iota> [ even? ] [ sq ] filter-map ] unit-test
+{ V{ 2 6 10 14 18 } } [ 10 <iota> [ odd? ] [ 2 * ] V{ } filter-map-as ] unit-test
 { { 2 6 10 14 18 } } [ 10 <iota> [ odd? ] [ 2 * ] { } filter-map-as ] unit-test
 
+{ V{ 1 9 25 49 81 } } [ 10 <iota> [ even? ] [ sq ] reject-map ] unit-test
+{ V{ 1 9 25 49 81 } } [ 10 <iota> [ even? ] [ sq ] reject-map ] unit-test
+{ V{ 0 4 8 12 16 }  } [ 10 <iota> [ odd? ] [ 2 * ] V{ } reject-map-as ] unit-test
+{ { 0 4 8 12 16 }   } [ 10 <iota> [ odd? ] [ 2 * ] { } reject-map-as ] unit-test
+
+{ V{ 0 4 16 36 64 } } [ 10 <iota> [ dup even? [ sq t ] [ f ] if ] filter-map* ] unit-test
+{ V{ 0 4 16 36 64 } } [ 10 <iota> [ sq dup even? ] filter-map* ] unit-test
+{ V{ 2 6 10 14 18 } } [ 10 <iota> [ dup odd? [ 2 * t ] [ f ] if ] V{ } filter-map-as* ] unit-test
+{ { 2 6 10 14 18 } } [ 10 <iota> [ dup odd? [ 2 * t ] [ f ] if ] { } filter-map-as* ] unit-test
+
+{ V{ 1 9 25 49 81 } } [ 10 <iota> [ dup even? [ t ] [ sq f ] if ] reject-map* ] unit-test
+{ V{ 1 9 25 49 81 } } [ 10 <iota> [ sq dup even? ] reject-map* ] unit-test
+{ V{ 0 4 8 12 16 }  } [ 10 <iota> [ dup odd? [ t ] [ 2 * f ] if ] V{ } reject-map-as* ] unit-test
+{ { 0 4 8 12 16 }   } [ 10 <iota> [ dup odd? [ t ] [ 2 * f ] if ] { } reject-map-as* ] unit-test
+
 { 8 } [ 3 <iota> dup [ 1 + * ] 2map-sum ] unit-test
 { 4 } [ "hello" "jello" [ = ] 2count ] unit-test
 
diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index 151c190d84..74b22a8c79 100644
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -322,27 +322,80 @@ PRIVATE>
 
 <PRIVATE
 
-: push-map-if ( ..a elt filter-quot: ( ..a elt -- ..b ? ) map-quot: ( ..a elt -- ..b newelt ) accum -- ..b )
+: push-map-when* ( ..a elt quot: ( ..a elt -- ..b obj ? ) accum -- ..b )
+    [ call ] dip swap [ push ] [ 2drop ] if ; inline
+
+: filter-mapper-for* ( quot length exemplar -- filter-mapper accum )
+    new-resizable [ [ push-map-when* ] 2curry ] keep ; inline
+
+: 1push-map-when ( ..a filter-quot: ( ..a -- ..b ? ) map-quot: ( ..a -- ..b obj ) accum -- ..b )
     [ keep over ] 2dip [ when ] dip rot [ push ] [ 2drop ] if ; inline
 
-: (filter-mapper-for) ( filter-quot map-quot length exempler -- filter-mapper accum )
-    new-resizable [ [ push-map-if ] 3curry ] keep ; inline
+: 1filter-mapper-for ( filter-quot map-quot length exemplar -- filter-mapper accum )
+    new-resizable [ [ 1push-map-when ] 3curry ] keep ; inline
 
-: filter-mapper-for ( filter-quot map-quot exemplar -- filter-mapper accum )
-    [ length ] keep (filter-mapper-for) ; inline
+: 2push-map-when ( ..a filter-quot: ( ..a -- ..b ? ) map-quot: ( ..a -- ..b obj ) accum -- ..b )
+    [ 2keep rot ] 2dip '[ [ @ _ push ] [ 2drop ] if ] call ; inline
 
-: filter-mapper ( filter-quot map-quot -- filter-mapper accum )
-    V{ } filter-mapper-for ; inline
+: 2filter-mapper-for ( filter-quot map-quot length exemplar -- filter-mapper accum )
+    new-resizable [ [ 2push-map-when ] 3curry ] keep ; inline
 
 PRIVATE>
 
-: filter-map-as ( ... seq filter-quot: ( ... elt -- ... ? ) map-quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
+: filter-map-as* ( ... seq quot: ( ..a elt -- ..b obj ? ) exemplar -- ... newseq )
+    pick length over
+    [ filter-mapper-for* [ each ] dip ] 2curry dip like ; inline
+
+: filter-map* ( ... seq quot: ( ... elt -- ... newelt ? ) -- ... newseq )
+    over filter-map-as* ; inline
+
+: reject-map-as* ( ... seq quot: ( ... elt -- ... newelt ? ) exemplar -- ... newseq )
+    [ [ not ] compose ] dip filter-map-as* ; inline
+
+: reject-map* ( ... seq quot: ( ... elt -- ... newelt ? ) -- ... newseq )
+    over reject-map-as* ; inline
+
+: 2filter-map-as* ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... obj ? ) exemplar -- ... newseq )
     reach length over
-    [ (filter-mapper-for) [ each ] dip ] 2curry dip like ; inline
+    [ filter-mapper-for* [ 2each ] dip ] 2curry dip like ; inline
+
+: 2filter-map* ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... newseq )
+    pick 2filter-map-as* ; inline
+
+: 2reject-map-as* ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... obj ? ) exemplar -- ... newseq )
+    [ [ not ] compose ] dip 2filter-map-as* ; inline
+
+: 2reject-map* ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... obj ? ) -- ... newseq )
+    pick 2reject-map-as* ; inline
+
 
-: filter-map ( ... seq filter-quot: ( ... elt -- ... ? ) map-quot: ( ... elt -- ... newelt ) -- ... newseq )
+: filter-map-as ( ... seq filter-quot: ( ..a elt -- ..b ? ) map-quot: ( obj -- obj' ) exemplar -- ... newseq )
+    reach length over
+    [ 1filter-mapper-for [ each ] dip ] 2curry dip like ; inline
+
+: filter-map ( ... seq filter-quot: ( ... elt -- ... ? ) map-quot: ( obj -- obj' ) -- ... newseq )
     pick filter-map-as ; inline
 
+: reject-map-as ( ... seq filter-quot: ( ... elt -- ... ? ) map-quot: ( obj -- obj' ) exemplar -- ... newseq )
+    [ [ not ] compose ] 2dip filter-map-as ; inline
+
+: reject-map ( ... seq filter-quot: ( ... elt -- ... ? ) map-quot: ( obj -- obj' ) -- ... newseq )
+    pick reject-map-as ; inline
+
+: 2filter-map-as ( ... seq1 seq2 filter-quot: ( ... elt1 elt2 -- ... ? ) map-quot: ( elt1 elt2 -- obj ) exemplar -- ... newseq )
+    5 npick length over
+    [ 2filter-mapper-for [ 2each ] dip ] 2curry dip like ; inline
+
+: 2filter-map ( ... seq1 seq2 filter-quot: ( ... elt1 elt2 -- ... ? ) map-quot: ( elt1 elt2 -- obj ) -- ... newseq )
+    reach 2filter-map-as ; inline
+
+: 2reject-map-as ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) map-quot: ( elt1 elt2 -- obj ) exemplar -- ... newseq )
+    [ [ not ] compose ] 2dip 2filter-map-as ; inline
+
+: 2reject-map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) map-quot: ( elt1 elt2 -- obj ) -- ... newseq )
+    pick 2reject-map-as ; inline
+
+
 : 2filter-as ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) exemplar -- ... newseq )
     [
         pick [ length ] keep
-- 
2.34.1