From 6071ea98f710180d16c68602862ea7f365fa5018 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Tue, 12 May 2015 18:39:19 -0700 Subject: [PATCH] sequences: adding reject/reject-as/reject!. --- core/sequences/sequences-docs.factor | 13 +++++++++++++ core/sequences/sequences-tests.factor | 4 ++++ core/sequences/sequences.factor | 19 ++++++++++++++----- extra/sequences/extras/extras-tests.factor | 3 --- extra/sequences/extras/extras.factor | 9 --------- 5 files changed, 31 insertions(+), 17 deletions(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index c28b7dcaaa..b8f59d7f6e 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -513,6 +513,19 @@ HELP: filter! { $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." } { $side-effects "seq" } ; +HELP: reject +{ $values { "seq" sequence } { "quot" { $quotation ( ... elt -- ... ? ) } } { "subseq" "a new sequence" } } +{ $description "Applies the quotation to each element in turn, and outputs a new sequence removing with the elements of the original sequence for which the quotation output a true value." } ; + +HELP: reject-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" } " remove the elements of the original sequence for which the quotation output a true value." } ; + +HELP: reject! +{ $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 true value." } +{ $side-effects "seq" } ; + HELP: interleave { $values { "seq" sequence } { "between" quotation } { "quot" { $quotation ( ... elt -- ... ) } } } { $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." } diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 5b05b4ef30..c97a5a5c68 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -117,6 +117,8 @@ IN: sequences.tests { t } [ B{ 0 } { 1 } append byte-array? ] unit-test { t } [ B{ 0 } { 1 } prepend byte-array? ] unit-test +{ "0123456789" } [ 58 iota [ 48 < ] "" reject-as ] unit-test + [ [ ] ] [ 1 [ ] remove ] unit-test [ [ ] ] [ 1 [ 1 ] remove ] unit-test [ [ 3 1 1 ] ] [ 2 [ 3 2 1 2 1 ] remove ] unit-test @@ -152,6 +154,8 @@ IN: sequences.tests [ 4 [ CHAR: a ] { } map-integers ] unit-test +{ V{ 1 3 5 7 9 } } [ 10 iota >vector [ even? ] reject! ] unit-test + [ V{ } ] [ "f" V{ } clone remove! ] unit-test [ V{ } ] [ "f" V{ "f" } clone remove! ] unit-test [ V{ } ] [ "f" V{ "f" "f" } clone remove! ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index a17d645013..bb132b8e5b 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -544,6 +544,12 @@ PRIVATE> : filter ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq ) over filter-as ; inline +: reject-as ( ... seq quot: ( ... elt -- ... ? ) exemplar -- ... subseq ) + [ [ not ] compose ] [ filter-as ] bi* ; inline + +: reject ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq ) + over reject-as ; inline + : push-either ( ..a elt quot: ( ..a elt -- ..b ? ) accum1 accum2 -- ..b ) [ keep swap ] 2dip ? push ; inline @@ -630,16 +636,16 @@ PRIVATE> [ eq? ] with any? ; : remove ( elt seq -- newseq ) - [ = not ] with filter ; + [ = ] with reject ; : remove-eq ( elt seq -- newseq ) - [ eq? not ] with filter ; + [ eq? ] with reject ; : sift ( seq -- newseq ) [ ] filter ; : harvest ( seq -- newseq ) - [ empty? not ] filter ; + [ empty? ] reject ; : filter! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq ) swap [ [ 0 0 ] dip (filter!) ] keep ; inline +: reject! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq ) + [ not ] compose filter! ; inline + : remove! ( elt seq -- seq ) - [ = not ] with filter! ; + [ = ] with reject! ; : remove-eq! ( elt seq -- seq ) - [ eq? not ] with filter! ; + [ eq? ] with reject! ; : prefix ( seq elt -- newseq ) over [ over length 1 + ] dip [ diff --git a/extra/sequences/extras/extras-tests.factor b/extra/sequences/extras/extras-tests.factor index 912f55074d..b7c705848b 100644 --- a/extra/sequences/extras/extras-tests.factor +++ b/extra/sequences/extras/extras-tests.factor @@ -170,9 +170,6 @@ IN: sequences.extras.tests { 0 "chicken" } [ { "chicken" "beef" "moose" } [ length ] supremum-by* ] unit-test { 2 "moose" } [ { "chicken" "beef" "moose" } [ first ] supremum-by* ] unit-test -{ "0123456789" } [ 58 iota [ 48 < ] "" reject-as ] unit-test -{ V{ 1 3 5 7 9 } } [ 10 iota >vector [ even? ] reject! ] unit-test - { 3/10 } [ 10 iota [ 3 < ] count* ] unit-test { { 0 } } [ "ABA" "ABABA" start-all ] unit-test diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor index abb54dd0ca..f3a7d10fb6 100644 --- a/extra/sequences/extras/extras.factor +++ b/extra/sequences/extras/extras.factor @@ -507,15 +507,6 @@ PRIVATE> : infimum-by* ( ... seq quot: ( ... elt -- ... x ) -- ... i elt ) [ before? ] select-by* ; inline -: reject-as ( ... seq quot: ( ... elt -- ... ? ) exemplar -- ... subseq ) - [ [ not ] compose ] [ filter-as ] bi* ; inline - -: reject ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq ) - over reject-as ; inline - -: reject! ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq ) - [ not ] compose filter! ; inline - : change-last ( seq quot -- ) [ drop length 1 - ] [ change-nth ] 2bi ; inline -- 2.34.1