sets: adding intersect!.

diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor
index 2ebf4d03001878a481f1d7486dfe49f7bce95f8b..43d1933d26b0783cf3075cf9ef1d944fe9c0219d 100644 (file)
--- a/core/sets/sets-docs.factor
+++ b/core/sets/sets-docs.factor
@@ -27,6 +27,7 @@ ARTICLE: "set-operations" "Operations on sets"
     clear-set
     union!
     diff!
+    intersect!
 }
 "To test if a set is the empty set:"
 { $subsections null? }
@@ -172,6 +173,11 @@ HELP: diff!
 { $description "Removes all members from " { $snippet "set1" } " contained in " { $snippet "set2" } "." }
 { $side-effects "set1" } ;
 
+HELP: intersect!
+{ $values { "set1" set } { "set2" set } }
+{ $description "Removes all members from " { $snippet "set1" } " not contained in " { $snippet "set2" } "." }
+{ $side-effects "set1" } ;
+
 HELP: intersects?
 { $values { "set1" set } { "set2" set } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "set1" } " and " { $snippet "set2" } " have any elements in common." }

diff --git a/core/sets/sets-tests.factor b/core/sets/sets-tests.factor
index 3874402f6ad451947eb8bdb10e80952d931616d3..33cc173cb2ba048cbb218a3a6a5415bfb80a9fa2 100644 (file)
--- a/core/sets/sets-tests.factor
+++ b/core/sets/sets-tests.factor
@@ -140,3 +140,8 @@ M: null-set members drop f ;
 [ HS{ 1 } ] [ HS{ 1 2 3 } HS{ 2 3 } diff! ] unit-test
 [ HS{ 1 } ] [ HS{ 1 } HS{ 2 3 4 } diff! ] unit-test
 [ HS{ 1 2 3 } ] [ HS{ 1 2 3 } HS{ 4 } diff! ] unit-test
+
+[ HS{ } ] [ HS{ } HS{ } intersect! ] unit-test
+[ HS{ 2 3 } ] [ HS{ 1 2 3 } HS{ 2 3 } intersect! ] unit-test
+[ HS{ } ] [ HS{ 1 } HS{ 2 3 4 } intersect! ] unit-test
+[ HS{ } ] [ HS{ 1 2 3 } HS{ 4 } intersect! ] unit-test

diff --git a/core/sets/sets.factor b/core/sets/sets.factor
index cca623995579a8cea95f71ed446df4eb29d39ca9..fe3282ec18e73f37dd1e3c065620f501d2f11b4b 100644 (file)
--- a/core/sets/sets.factor
+++ b/core/sets/sets.factor
@@ -168,6 +168,10 @@ M: sequence clear-set
     dupd sequence/tester [ dup ] prepose pick
     [ delete ] curry [ [ drop ] if ] curry compose each ;
 
+: intersect! ( set1 set2 -- set1 )
+    dupd sequence/tester [ dup ] prepose [ not ] compose pick
+    [ delete ] curry [ [ drop ] if ] curry compose each ;
+
 ! Temporarily for compatibility
 
 : unique ( seq -- assoc )