assocs: adding assoc-reject, assoc-reject-as, assoc-reject!.

diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index 779248f856515598fa819a2be7a212c94f8b2986..b7bd5713b1abd99224d309781e8ea433e1567355 100644 (file)
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -151,6 +151,8 @@ $nl
     assoc-map
     assoc-filter
     assoc-filter-as
+    assoc-reject
+    assoc-reject-as
     assoc-partition
     assoc-any?
     assoc-all?
@@ -169,6 +171,7 @@ $nl
 "Destructive combinators:"
 { $subsections
     assoc-filter!
+    assoc-reject!
     cache
     2cache
 } ;
@@ -300,6 +303,21 @@ HELP: assoc-filter!
 
 { assoc-filter assoc-filter-as assoc-filter! } related-words
 
+HELP: assoc-reject
+{ $values { "assoc" assoc } { "quot" { $quotation ( ... key value -- ... ? ) } } { "subassoc" "a new assoc" } }
+{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields false." } ;
+
+HELP: assoc-reject-as
+{ $values { "assoc" assoc } { "quot" { $quotation ( ... key value -- ... ? ) } } { "exemplar" assoc } { "subassoc" "a new assoc" } }
+{ $description "Outputs an assoc of the same type as " { $snippet "exemplar" } " consisting of all entries for which the predicate quotation yields false." } ;
+
+HELP: assoc-reject!
+{ $values { "assoc" assoc } { "quot" { $quotation ( ... key value -- ... ? ) } } }
+{ $description "Removes all entries for which the predicate quotation yields false." }
+{ $side-effects "assoc" } ;
+
+{ assoc-reject assoc-reject-as assoc-reject! } related-words
+
 HELP: assoc-partition
 { $values
     { "assoc" assoc } { "quot" quotation }

diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index 86890058d750644669245bd6c91391da3bba2737..4dd3614cd24640c6796788c00e80f7ea8fec648e 100644 (file)
--- a/core/assocs/assocs-tests.factor
+++ b/core/assocs/assocs-tests.factor
@@ -50,6 +50,16 @@ IN: assocs.tests
     [ drop 3 >= ] assoc-filter! drop
 ] unit-test
 
+[ H{ { 1 2 } { 2 3 } } ] [
+    H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
+    [ drop 3 >= ] assoc-reject
+] unit-test
+
+[ H{ { 1 2 } { 2 3 } } ] [
+    H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } } clone
+    [ drop 3 >= ] assoc-reject!
+] unit-test
+
 [ 21 ] [
     0 H{
         { 1 2 }

diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 786bd64f02e5d2f52ac46690d8f3c4d3551aac7d..ef61ab0bbb67587c4b88ce927993a09b3e1e0da0 100644 (file)
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -74,12 +74,21 @@ PRIVATE>
 : assoc-filter ( ... assoc quot: ( ... key value -- ... ? ) -- ... subassoc )
     over assoc-filter-as ; inline
 
+: assoc-reject-as ( ... assoc quot: ( ... key value -- ... ? ) exemplar -- ... subassoc )
+    [ [ not ] compose ] [ assoc-filter-as ] bi* ; inline
+
+: assoc-reject ( ... assoc quot: ( ... key value -- ... ? ) -- ... subassoc )
+    over assoc-reject-as ; inline
+
 : assoc-filter! ( ... assoc quot: ( ... key value -- ... ? ) -- ... assoc )
     [
         over [ [ [ drop ] 2bi ] dip [ delete-at ] 2curry unless ] 2curry
         assoc-each
     ] [ drop ] 2bi ; inline
 
+: assoc-reject! ( ... assoc quot: ( ... key value -- ... ? ) -- ... assoc )
+    [ not ] compose assoc-filter! ; inline
+
 : sift-keys ( assoc -- assoc' )
     [ drop ] assoc-filter ; inline