+++ /dev/null
-! Copyright (C) 2010 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: bags tools.test kernel sorting prettyprint bit-arrays arrays ;
-IN: bags.tests
-
-[ { } ] [ { } { } intersect ] unit-test
-[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
-
-[ { } ] [ { } { } diff ] unit-test
-[ { 1 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
-
-[ { } ] [ { } { } union ] unit-test
-[ { 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
-
-[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test
-
-[ f ] [ { 4 2 } { 1 3 } intersects? ] unit-test
-
-[ f ] [ { } { 1 } intersects? ] unit-test
-
-[ f ] [ { 1 } { } intersects? ] unit-test
-
-[ t ] [ 4 { 2 4 5 } in? ] unit-test
-[ f ] [ 1 { 2 4 5 } in? ] unit-test
-
-[ V{ 1 2 3 } ] [ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
-[ V{ 1 2 } ] [ 2 V{ 1 2 } clone [ adjoin ] keep ] unit-test
-[ V{ 1 2 } ] [ 3 V{ 1 2 } clone [ delete ] keep ] unit-test
-[ V{ 2 } ] [ 1 V{ 1 2 } clone [ delete ] keep ] unit-test
-
-[ t ] [ { 1 2 3 } { 2 1 3 } set= ] unit-test
-[ f ] [ { 2 3 } { 1 2 3 } set= ] unit-test
-[ f ] [ { 1 2 3 } { 2 3 } set= ] unit-test
-
-[ { 1 } ] [ { 1 } members ] unit-test
-
-[ { 1 2 3 } ] [ { 1 1 1 2 2 3 3 3 3 3 } dup set-like natural-sort ] unit-test
-[ { 1 2 3 } ] [ HS{ 1 2 3 } { } set-like natural-sort ] unit-test
-
-[ HS{ 1 2 3 } ] [ { 1 2 3 } fast-set ] unit-test
-
-[ { 1 2 3 } ] [ HS{ 1 2 3 } members natural-sort ] unit-test
-
-[ "HS{ 1 2 3 4 }" ] [ HS{ 1 2 3 4 } unparse ] unit-test
-
-[ t ] [ 1 HS{ 0 1 2 } in? ] unit-test
-[ f ] [ 3 HS{ 0 1 2 } in? ] unit-test
-[ HS{ 1 2 3 } ] [ 3 HS{ 1 2 } clone [ adjoin ] keep ] unit-test
-[ HS{ 1 2 } ] [ 2 HS{ 1 2 } clone [ adjoin ] keep ] unit-test
-[ HS{ 1 2 3 } ] [ 4 HS{ 1 2 3 } clone [ delete ] keep ] unit-test
-[ HS{ 1 2 } ] [ 3 HS{ 1 2 3 } clone [ delete ] keep ] unit-test
-[ HS{ 1 2 } ] [ HS{ 1 2 } fast-set ] unit-test
-[ { 1 2 } ] [ HS{ 1 2 } members natural-sort ] unit-test
-
-[ HS{ 1 2 3 4 } ] [ HS{ 1 2 3 } HS{ 2 3 4 } union ] unit-test
-[ HS{ 2 3 } ] [ HS{ 1 2 3 } HS{ 2 3 4 } intersect ] unit-test
-[ t ] [ HS{ 1 2 3 } HS{ 2 3 4 } intersects? ] unit-test
-[ f ] [ HS{ 1 } HS{ 2 3 4 } intersects? ] unit-test
-[ f ] [ HS{ 1 } HS{ 2 3 4 } subset? ] unit-test
-[ f ] [ HS{ 1 2 3 } HS{ 2 3 4 } subset? ] unit-test
-[ t ] [ HS{ 2 3 } HS{ 2 3 4 } subset? ] unit-test
-[ t ] [ HS{ } HS{ 2 3 4 } subset? ] unit-test
-[ HS{ 1 } ] [ HS{ 1 2 3 } HS{ 2 3 4 } diff ] unit-test
-[ t ] [ HS{ 1 2 3 } HS{ 2 1 3 } set= ] unit-test
-[ t ] [ HS{ 1 2 3 } HS{ 2 1 3 } = ] unit-test
-[ f ] [ HS{ 2 3 } HS{ 2 1 3 } set= ] unit-test
-[ f ] [ HS{ 1 2 3 } HS{ 2 3 } set= ] unit-test
-
-[ HS{ 1 2 } HS{ 1 2 3 } ] [ HS{ 1 2 } clone dup clone [ 3 swap adjoin ] keep ] unit-test
-
-[ T{ bit-set f ?{ t f t f t f } } ] [
- T{ bit-set f ?{ t f f f t f } }
- T{ bit-set f ?{ f f t f t f } } union
-] unit-test
-
-[ T{ bit-set f ?{ f f f f t f } } ] [
- T{ bit-set f ?{ t f f f t f } }
- T{ bit-set f ?{ f f t f t f } } intersect
-] unit-test
-
-[ T{ bit-set f ?{ t f t f f f } } ] [
- T{ bit-set f ?{ t t t f f f } }
- T{ bit-set f ?{ f t f f t t } } diff
-] unit-test
-
-[ f ] [
- T{ bit-set f ?{ t t t f f f } }
- T{ bit-set f ?{ f t f f t t } } subset?
-] unit-test
-
-[ t ] [
- T{ bit-set f ?{ t t t f f f } }
- T{ bit-set f ?{ f t f f f f } } subset?
-] unit-test
-
-[ t ] [
- { 0 1 2 }
- T{ bit-set f ?{ f t f f f f } } subset?
-] unit-test
-
-[ f ] [
- T{ bit-set f ?{ f t f f f f } }
- T{ bit-set f ?{ t t t f f f } } subset?
-] unit-test
-
-[ f ] [
- { 1 }
- T{ bit-set f ?{ t t t f f f } } subset?
-] unit-test
-
-[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } members ] unit-test
-
-[ t { 1 2 3 } ] [
- { 1 2 } 5 <bit-set> set-like
- [ bit-set? ] keep
- 3 over adjoin
- members >array natural-sort
-] unit-test
-
-[ V{ 0 1 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap adjoin ] keep members ] unit-test
-[ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap adjoin ] keep members ] must-fail
-[ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap adjoin ] keep members ] must-fail
-
-[ V{ 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 0 swap delete ] keep members ] unit-test
-[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap delete ] keep members ] unit-test
-[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap delete ] keep members ] unit-test
-[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap delete ] keep members ] unit-test
+++ /dev/null
-! Copyright (C) 2010 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs bit-arrays bit-sets hashtables kernel
-math sequences parser prettyprint.custom ;
-QUALIFIED: sets
-IN: bags
-! The vocab is called bags 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
-GENERIC: adjoin ( elt set -- )
-GENERIC: in? ( elt set -- ? )
-GENERIC: delete ( elt set -- )
-GENERIC: set-like ( set exemplar -- set' )
-GENERIC: fast-set ( set -- set' )
-GENERIC: members ( set -- sequence )
-GENERIC: union ( set1 set2 -- set )
-GENERIC: intersect ( set1 set2 -- set )
-GENERIC: intersects? ( set1 set2 -- ? )
-GENERIC: diff ( set1 set2 -- set )
-GENERIC: subset? ( set1 set2 -- ? )
-GENERIC: set= ( set1 set2 -- ? )
-
-! Defaults for some methods.
-! Override them for efficiency
-
-M: set union
- [ [ members ] bi@ append ] keep set-like ;
-
-<PRIVATE
-
-: sequence/tester ( set1 set2 -- set1' quot )
- [ members ] [ fast-set [ in? ] curry ] bi* ; inline
-
-PRIVATE>
-
-M: set intersect
- [ sequence/tester filter ] keep set-like ;
-
-M: set diff
- [ sequence/tester [ not ] compose filter ] keep set-like ;
-
-M: set intersects?
- sequence/tester any? ;
-
-M: set subset?
- sequence/tester all? ;
-
-M: set set=
- 2dup subset? [ swap subset? ] [ 2drop f ] if ;
-
-M: set fast-set ;
-
-! Hash sets
-! In a better implementation, less memory would be used
-TUPLE: hash-set { table hashtable read-only } ;
-
-: <hash-set> ( members -- hash-set )
- sets:unique hash-set boa ;
-
-INSTANCE: hash-set set
-M: hash-set in? table>> key? ; inline
-M: hash-set adjoin table>> dupd set-at ; inline
-M: hash-set delete table>> delete-at ; inline
-M: hash-set members table>> keys ; inline
-M: hash-set set-like
- drop dup hash-set? [ members <hash-set> ] unless ;
-M: hash-set clone
- table>> clone hash-set boa ;
-
-SYNTAX: HS{
- \ } [ <hash-set> ] parse-literal ;
-
-M: hash-set pprint* pprint-object ;
-M: hash-set pprint-delims drop \ HS{ \ } ;
-M: hash-set >pprint-sequence members ;
-
-! Sequences are sets
-INSTANCE: sequence set
-M: sequence in? member? ; inline
-M: sequence adjoin sets:adjoin ; inline
-M: sequence delete remove! drop ; inline
-M: sequence set-like
- [ dup sequence? [ sets:prune ] [ members ] if ] dip
- like ;
-M: sequence members ;
-M: sequence fast-set <hash-set> ;
-
-! Bit sets are sets
-TUPLE: bit-set { table bit-array read-only } ;
-
-: <bit-set> ( capacity -- bit-set )
- <bit-array> bit-set boa ;
-
-INSTANCE: bit-set set
-
-M: bit-set in?
- over integer? [ table>> ?nth ] [ 2drop f ] if ; inline
-
-M: bit-set adjoin
- ! This is allowed to crash when the elt couldn't go in the set
- [ t ] 2dip table>> set-nth ;
-
-M: bit-set delete
- ! This isn't allowed to crash if the elt wasn't in the set
- over integer? [
- table>> 2dup bounds-check? [
- [ f ] 2dip set-nth
- ] [ 2drop ] if
- ] [ 2drop ] if ;
-
-! If you do binary set operations with a bitset, it's expected
-! that the other thing can also be represented as a bitset
-! of the same length.
-: (bit-set-op) ( set1 set2 -- table1 table2 )
- [ set-like ] keep [ table>> ] bi@ ; inline
-
-: bit-set-op ( set1 set2 quot: ( table1 table2 -- table ) -- bit-set )
- [ (bit-set-op) ] dip call bit-set boa ; inline
-
-M: bit-set union
- [ bit-set-union ] bit-set-op ;
-
-M: bit-set intersect
- [ bit-set-intersect ] bit-set-op ;
-
-M: bit-set diff
- [ bit-set-diff ] bit-set-op ;
-
-M: bit-set subset?
- (bit-set-op) swap bit-set-subset? ;
-
-M: bit-set members
- [ table>> length iota ] keep [ in? ] curry filter ;
-
-M: bit-set set-like
- ! This crashes if there are keys that can't be put in the bit set
- over bit-set? [ 2dup [ table>> ] bi@ length = ] [ f ] if
- [ drop ] [
- [ members ] dip table>> length <bit-set>
- [ [ adjoin ] curry each ] keep
- ] if ;
projects / factor.git / commitdiff