From e31ed3eda4785af12b45eabcbfdd0de9cb79527d Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 22 Oct 2009 17:28:01 -0500
Subject: [PATCH] add filter-as to sequences

---
 core/sequences/sequences-docs.factor |  5 +++++
 core/sequences/sequences.factor      | 10 ++++++++--
 2 files changed, 13 insertions(+), 2 deletions(-)

diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 9fd48796d6..2156557fff 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -426,6 +426,10 @@ HELP: filter
 { $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "subseq" "a new sequence" } }
 { $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ;
 
+HELP: filter-as
+{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "exemplar" sequence } { "subseq" "a new sequence" } }
+{ $description "Applies the quotation to each element in turn, and outputs a new sequence of the same type as " { $snippet "exemplar" } " containing the elements of the original sequence for which the quotation output a true value." } ;
+
 HELP: filter-here
 { $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } }
 { $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
@@ -1512,6 +1516,7 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
 "Filtering:"
 { $subsections
     filter
+    filter-as
     partition
 }
 "Testing if a sequence contains elements satisfying a predicate:"
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index b46645d433..93709122c7 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -483,11 +483,17 @@ PRIVATE>
 : push-if ( elt quot accum -- )
     [ keep ] dip rot [ push ] [ 2drop ] if ; inline
 
+: pusher-for ( quot exemplar -- quot accum )
+    [ length ] keep new-resizable [ [ push-if ] 2curry ] keep ; inline
+
 : pusher ( quot -- quot accum )
-    V{ } clone [ [ push-if ] 2curry ] keep ; inline
+    V{ } pusher-for ; inline
+
+: filter-as ( seq quot exemplar -- subseq )
+    dup [ pusher-for [ each ] dip ] curry dip like ; inline
 
 : filter ( seq quot -- subseq )
-    over [ pusher [ each ] dip ] dip like ; inline
+    over filter-as ; inline
 
 : push-either ( elt quot accum1 accum2 -- )
     [ keep swap ] 2dip ? push ; inline