Fixing bugs with sets, including adding new within and without words

basis/validators/validators.factor

@@ -97,7 +97,7 @@ IN: validators
     sum 10 mod 0 = ;
 
 : v-credit-card ( str -- n )
-    "- " diff
+    "- " without
     dup CHAR: 0 CHAR: 9 [a,b] diff empty? [
         13 v-min-length
         16 v-max-length

core/hash-sets/hash-sets.factor

@@ -25,4 +25,4 @@ M: sequence fast-set <hash-set> ;
 M: f fast-set drop H{ } clone hash-set boa ;
 
 M: sequence duplicates
-    HS{ } clone [ [ in? ] [ adjoin ] 2bi ] curry filter ;
+    f fast-set [ [ in? ] [ adjoin ] 2bi ] curry filter ;

core/sets/sets-docs.factor

@@ -3,7 +3,7 @@ quotations sequences vectors ;
 IN: sets
 
 ARTICLE: "sets" "Sets"
-"A set is an unordered list of elements. Words for working with sets are in the " { $vocab-link "sets" } " vocabulary."
+"A set is an unordered list of elements. Words for working with sets are in the " { $vocab-link "sets" } " vocabulary." $nl
 "All sets are instances of a mixin class:"
 { $subsections
     set
@@ -43,6 +43,11 @@ ARTICLE: "set-operations" "Operations on sets"
 { $subsections
     all-unique?
     duplicates
+}
+"Utilities for sets and sequences:"
+{ $subsections
+     within
+     without
 } ;
 
 ARTICLE: "set-implementations" "Set implementations"
@@ -68,11 +73,11 @@ HELP: adjoin
 { $description "Destructively adds " { $snippet "elt" } " to " { $snippet "set" } ". For sequences, this guarantees that this element is not duplicated, and that it is at the end of the sequence." $nl "Each mutable set type is expected to implement a method on this generic word." }
 { $examples
     { $example
-        "USING: namespaces prettyprint sets ;"
+        "USING: prettyprint sets kernel ;"
-        "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
+        "V{ \"beans\" \"salsa\" \"cheese\" } clone"
-        "\"nachos\" \"v\" get adjoin"
+        "\"nachos\" over adjoin"
-        "\"salsa\" \"v\" get adjoin"
+        "\"salsa\" over adjoin"
-        "\"v\" get ."
+        "."
         "V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
     }
 }
@@ -100,7 +105,7 @@ HELP: duplicates
 { $values { "set" set } { "seq" sequence } }
 { $description "Outputs a sequence consisting of elements which occur more than once in " { $snippet "set" } "." }
 { $examples
-    { $example "USING: sets prettyprint ;" "{ 1 2 3 1 2 1 } duplicates ." "{ 2 1 2 1 }" }
+    { $example "USING: sets prettyprint ;" "{ 1 2 3 1 2 1 } duplicates ." "{ 1 2 1 }" }
 } ;
 
 HELP: all-unique?
@@ -165,3 +170,11 @@ HELP: set-like
 { $examples
     { $example "USING: sets prettyprint ;" "{ 1 2 3 } HS{ } set-like ." "HS{ 1 2 3 }" }
 } ;
+
+HELP: within
+{ $values { "seq" sequence } { "set" set } { "subseq" sequence } }
+{ $description "Returns the subsequence of the given sequence consisting of members of the set. This may contain duplicates, if the sequence has duplicates." } ;
+
+HELP: without
+{ $values { "seq" sequence } { "set" set } { "subseq" sequence } }
+{ $description "Returns the subsequence of the given sequence consisting of things that are not members of the set. This may contain duplicates, if the sequence has duplicates." } ;

core/sets/sets-tests.factor

@@ -5,9 +5,19 @@ IN: sets.tests
 
 [ { } ] [ { } { } intersect  ] unit-test
 [ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
+[ { 2 3 } ] [ { 1 2 2 3 } { 2 3 3 4 } intersect ] unit-test
 
 [ { } ] [ { } { } diff ] unit-test
 [ { 1 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
+[ { 1 } ] [ { 1 1 2 3 } { 2 3 4 4 } diff ] unit-test
+
+[ { } ] [ { } { } within  ] unit-test
+[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } within ] unit-test
+[ { 2 2 3 } ] [ { 1 2 2 3 } { 2 3 3 4 } within ] unit-test
+
+[ { } ] [ { } { } without ] unit-test
+[ { 1 } ] [ { 1 2 3 } { 2 3 4 } without ] unit-test
+[ { 1 1 } ] [ { 1 1 2 3 3 } { 2 3 4 4 } without ] unit-test
 
 [ { } ] [ { } { } union ] unit-test
 [ { 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test

core/sets/sets.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs hashtables kernel vectors
 math sequences ;
+FROM: assocs => change-at ;
 IN: sets
 
 ! Set protocol
@@ -11,7 +12,7 @@ GENERIC: in? ( elt set -- ? )
 GENERIC: delete ( elt set -- )
 GENERIC: set-like ( set exemplar -- set' )
 GENERIC: fast-set ( set -- set' )
-GENERIC: members ( set -- sequence )
+GENERIC: members ( set -- seq )
 GENERIC: union ( set1 set2 -- set )
 GENERIC: intersect ( set1 set2 -- set )
 GENERIC: intersects? ( set1 set2 -- ? )
@@ -95,7 +96,9 @@ M: sequence all-unique?
     dup pruned sequence= ;
 
 : combine ( sets -- set )
-    f [ union ] reduce ;
+    [ f ]
+    [ [ [ members ] map concat ] [ first ] bi set-like ]
+    if-empty ;
 
 : gather ( seq quot -- newseq )
     map concat members ; inline
@@ -103,6 +106,12 @@ M: sequence all-unique?
 : adjoin-at ( value key assoc -- )
     [ [ f fast-set ] unless* [ adjoin ] keep ] change-at ;
 
+: within ( seq set -- subseq )
+    fast-set [ in? ] curry filter ;
+
+: without ( seq set -- subseq )
+    fast-set [ in? not ] curry filter ;
+
 ! Temporarily for compatibility
 
 : unique ( seq -- assoc )

extra/project-euler/035/035.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.combinatorics math.parser math.primes
-    project-euler.common sequences sets ;
+    project-euler.common sequences ;
 IN: project-euler.035
 
 ! http://projecteuler.net/index.php?section=problems&id=35
@@ -28,7 +28,7 @@ IN: project-euler.035
 
 : possible? ( seq -- ? )
     dup length 1 > [
-        dup { 0 2 4 5 6 8 } diff =
+        [ even? ] any? not
     ] [
         drop t
     ] if ;