Making propagation and tuple.parser refer to new-sets; adding some missing features from sets into new-sets

basis/compiler/tree/propagation/propagation-tests.factor

@@ -8,7 +8,7 @@ layouts compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker slots.private words
 hashtables classes assocs locals specialized-arrays system
 sorting math.libm math.floats.private math.integers.private
-math.intervals quotations effects alien alien.data sets ;
+math.intervals quotations effects alien alien.data new-sets ;
 FROM: math => float ;
 SPECIALIZED-ARRAY: double
 SPECIALIZED-ARRAY: void*

basis/compiler/tree/propagation/transforms/transforms.factor

@@ -3,12 +3,13 @@
 USING: alien.c-types kernel sequences words fry generic accessors
 classes.tuple classes classes.algebra definitions
 stack-checker.dependencies quotations classes.tuple.private math
-math.partial-dispatch math.private math.intervals sets.private
+math.partial-dispatch math.private math.intervals new-sets.private
 math.floats.private math.integers.private layouts math.order
 vectors hashtables combinators effects generalizations assocs
-sets combinators.short-circuit sequences.private locals growable
+new-sets combinators.short-circuit sequences.private locals growable
 stack-checker namespaces compiler.tree.propagation.info ;
 FROM: math => float ;
+FROM: new-sets => set ;
 IN: compiler.tree.propagation.transforms
 
 \ equal? [
@@ -207,7 +208,7 @@ ERROR: bad-partial-eval quot word ;
         [ drop f ] swap
         [ literalize [ t ] ] { } map>assoc linear-case-quot
     ] [
-        unique [ key? ] curry
+        tester
     ] if ;
 
 \ member? [
@@ -272,14 +273,14 @@ CONSTANT: lookup-table-at-max 256
 \ at* [ at-quot ] 1 define-partial-eval
 
 : diff-quot ( seq -- quot: ( seq' -- seq'' ) )
-    tester '[ [ @ not ] filter ] ;
+    tester '[ [ [ @ not ] filter ] keep set-like ] ;
 
-\ diff [ diff-quot ] 1 define-partial-eval
+M\ set diff [ diff-quot ] 1 define-partial-eval
 
 : intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
-    tester '[ _ filter ] ;
+    tester '[ [ _ filter ] keep set-like ] ;
 
-\ intersect [ intersect-quot ] 1 define-partial-eval
+M\ set intersect [ intersect-quot ] 1 define-partial-eval
 
 : fixnum-bits ( -- n )
     cell-bits tag-bits get - ;

core/classes/tuple/parser/parser.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sets namespaces make sequences parser
+USING: accessors kernel new-sets namespaces make sequences parser
 lexer combinators words classes.parser classes.tuple arrays
 slots math assocs parser.notes classes classes.algebra ;
 IN: classes.tuple.parser

core/hash-sets/hash-sets.factor

@@ -22,3 +22,6 @@ M: hash-set clone
     table>> clone hash-set boa ;
 
 M: sequence fast-set <hash-set> ;
+
+M: sequence duplicates
+    HS{ } clone [ [ in? ] [ adjoin ] 2bi ] curry filter ;

core/new-sets/new-sets-tests.factor

@@ -40,3 +40,12 @@ IN: new-sets.tests
 [ HS{ 1 2 3 } ] [ { 1 2 3 } fast-set ] unit-test
 
 [ { 1 2 3 } ] [ { { 1 } { 2 } { 1 3 } } combine ] unit-test
+
+[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
+[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
+
+[ { 1 2 3 } ] [ { 1 2 2 3 3 } { } set-like ] unit-test
+[ { 3 2 1 } ] [ { 3 3 2 2 1 } { } set-like ] unit-test
+
+[ { 1 2 1 } ] [ { 1 2 3 2 1 2 1 } duplicates ] unit-test
+[ f ] [ HS{ 1 2 3 1 2 1 } duplicates ] unit-test

core/new-sets/new-sets.factor

@@ -1,11 +1,8 @@
 ! Copyright (C) 2010 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs hashtables kernel
+USING: accessors assocs hashtables kernel vectors
 math sequences ;
-FROM: sets => prune ;
 IN: new-sets
-! The vocab is called new-sets for now, but only until it gets into core
-! All the code here is in the style that could be put in core
 
 ! Set protocol
 MIXIN: set
@@ -21,6 +18,8 @@ GENERIC: intersects? ( set1 set2 -- ? )
 GENERIC: diff ( set1 set2 -- set )
 GENERIC: subset? ( set1 set2 -- ? )
 GENERIC: set= ( set1 set2 -- ? )
+GENERIC: duplicates ( set -- sequence )
+GENERIC: all-unique? ( set -- ? )
 
 ! Defaults for some methods.
 ! Override them for efficiency
@@ -30,8 +29,11 @@ M: set union
 
 <PRIVATE
 
+: tester ( set -- quot )
+    fast-set [ in? ] curry ; inline
+
 : sequence/tester ( set1 set2 -- set1' quot )
-    [ members ] [ fast-set [ in? ] curry ] bi* ; inline
+    [ members ] [ tester ] bi* ; inline
 
 PRIVATE>
 
@@ -52,15 +54,45 @@ M: set set=
 
 M: set fast-set ;
 
+M: set duplicates drop f ;
+
+M: set all-unique? drop t ;
+
+<PRIVATE
+
+: (prune) ( elt hash vec -- )
+    3dup drop key? [ 3drop ] [
+        [ drop dupd set-at ] [ nip push ] 3bi
+    ] if ; inline
+
+: prune ( seq -- newseq )
+    [ ] [ length <hashtable> ] [ length <vector> ] tri
+    [ [ (prune) ] 2curry each ] keep ;
+
+PRIVATE>
+
 ! Sequences are sets
 INSTANCE: sequence set
-M: sequence in? member? ; inline
-M: sequence adjoin [ delete ] [ push ] 2bi ;
-M: sequence delete remove! drop ; inline
-M: sequence set-like
-    [ dup sequence? [ prune ] [ members ] if ] dip like ;
-M: sequence members fast-set members ;
 
+M: sequence in?
+    member? ; inline
+
+M: sequence adjoin
+    [ delete ] [ push ] 2bi ;
+
+M: sequence delete
+    remove! drop ; inline
+
+M: sequence set-like
+    [ members ] dip like ;
+
+M: sequence members
+    [ prune ] keep like ;
+
+M: sequence all-unique?
+    dup prune sequence= ;
+
+! Some sequence methods are defined using hash-sets
 USE: vocabs.loader
 "hash-sets" require