From ffd03ec9223189dcfa2240ebff505d9ba6cd07dd Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Fri, 8 Mar 2013 07:57:45 -0800
Subject: [PATCH] sets: adding union! and intersection.

---
 core/sets/sets-docs.factor  | 10 ++++++++++
 core/sets/sets-tests.factor |  9 +++++++++
 core/sets/sets.factor       |  6 ++++++
 3 files changed, 25 insertions(+)

diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor
index 8f77552e77..2ec63b9fb8 100644
--- a/core/sets/sets-docs.factor
+++ b/core/sets/sets-docs.factor
@@ -25,6 +25,7 @@ ARTICLE: "set-operations" "Operations on sets"
     adjoin
     delete
     clear-set
+    union!
 }
 "To test if a set is the empty set:"
 { $subsections null? }
@@ -148,6 +149,10 @@ HELP: intersect
     { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" }
 } ;
 
+HELP: intersection
+{ $values { "sets" sequence } { "set/f" "a " { $link set } " or " { $link f } } }
+{ $description "Outputs the intersection of all the sets of the sequence " { $snippet "sets" } ", or " { $link f } " if " { $snippet "sets" } " is empty." } ;
+
 HELP: union
 { $values { "set1" set } { "set2" set } { "set" set } }
 { $description "Outputs a set consisting of elements present in either " { $snippet "set1" } " or " { $snippet "set2" } " which does not contain duplicate values."
@@ -158,6 +163,11 @@ HELP: union
 
 { diff intersect union } related-words
 
+HELP: union!
+{ $values { "set1" set } { "set2" set } }
+{ $description "Adds all members from " { $snippet "set2" } " to " { $snippet "set1" } "." }
+{ $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 166e4ebd2f..1c1a93fe4d 100644
--- a/core/sets/sets-tests.factor
+++ b/core/sets/sets-tests.factor
@@ -126,3 +126,12 @@ M: null-set members drop f ;
 
 [ HS{ } ] [ HS{ } [ clear-set ] keep ] unit-test
 [ HS{ } ] [ HS{ 1 2 3 } [ clear-set ] keep ] unit-test
+
+[ HS{ } ] [ HS{ } HS{ } union! ] unit-test
+[ HS{ 1 } ] [ HS{ 1 } HS{ } union! ] unit-test
+[ HS{ 1 } ] [ HS{ } HS{ 1 } union! ] unit-test
+[ HS{ 1 2 3 } ] [ HS{ 1 } HS{ 1 2 3 } union! ] unit-test
+
+[ f ] [ { } intersection ] unit-test
+[ HS{ } ] [ { HS{ } } intersection ] unit-test
+[ HS{ 1 } ] [ { HS{ 1 2 3 } HS{ 1 } } intersection ] unit-test
diff --git a/core/sets/sets.factor b/core/sets/sets.factor
index b289f06734..7ba14c08ba 100644
--- a/core/sets/sets.factor
+++ b/core/sets/sets.factor
@@ -138,6 +138,9 @@ M: sequence clear-set
     [ [ [ ?members ] map concat ] [ first ] bi set-like ]
     if-empty ;
 
+: intersection ( sets -- set/f )
+    [ f ] [ [ ] [ intersect ] map-reduce ] if-empty ;
+
 : gather ( ... seq quot: ( ... elt -- ... elt' ) -- ... newseq )
     map concat members ; inline
 
@@ -153,6 +156,9 @@ M: sequence clear-set
 : ?adjoin ( elt set -- ? )
     2dup in? [ 2drop f ] [ adjoin t ] if ; inline
 
+: union! ( set1 set2 -- set1 )
+    ?members over [ adjoin ] curry each ;
+
 ! Temporarily for compatibility
 
 : unique ( seq -- assoc )