diff --git a/basis/bit-sets/bit-sets-tests.factor b/basis/bit-sets/bit-sets-tests.factor index 6a1366a1ea..c4260915ac 100644 --- a/basis/bit-sets/bit-sets-tests.factor +++ b/basis/bit-sets/bit-sets-tests.factor @@ -1,17 +1,60 @@ -USING: bit-sets tools.test bit-arrays ; +USING: bit-sets tools.test new-sets kernel bit-arrays ; IN: bit-sets.tests -[ ?{ t f t f t f } ] [ - ?{ t f f f t f } - ?{ f f t f t f } bit-set-union +[ 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 -[ ?{ f f f f t f } ] [ - ?{ t f f f t f } - ?{ f f t f t f } bit-set-intersect +[ 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 f t f f f } ] [ - ?{ t t t f f f } - ?{ f t f f t t } bit-set-diff +[ 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 V{ 1 2 3 } ] [ + { 1 2 } 5 set-like + [ bit-set? ] keep + 3 over adjoin + members +] 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 diff --git a/basis/bit-sets/bit-sets.factor b/basis/bit-sets/bit-sets.factor index 34b7f13dc2..d6c9a48bed 100644 --- a/basis/bit-sets/bit-sets.factor +++ b/basis/bit-sets/bit-sets.factor @@ -1,8 +1,33 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences byte-arrays bit-arrays math hints ; +USING: kernel accessors sequences byte-arrays bit-arrays math hints new-sets ; IN: bit-sets +TUPLE: bit-set { table bit-array read-only } ; + +: ( capacity -- bit-set ) + 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. > ] bi@ ; inline + +: bit-set-op ( set1 set2 quot: ( a b -- c ) -- bit-set ) + [ (bit-set-op) ] dip bit-set-map bit-set boa ; inline + PRIVATE> -: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ; +M: bit-set union + [ bitor ] bit-set-op ; -HINTS: bit-set-union bit-array bit-array ; +M: bit-set intersect + [ bitand ] bit-set-op ; -: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ; +M: bit-set diff + [ bitnot bitand ] bit-set-op ; -HINTS: bit-set-intersect bit-array bit-array ; +M: bit-set subset? + [ intersect ] keep = ; -: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ; +M: bit-set members + [ table>> length iota ] keep [ in? ] curry filter ; -HINTS: bit-set-diff bit-array bit-array ; - -: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ; \ No newline at end of file +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 + [ [ adjoin ] curry each ] keep + ] if ; diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor index 4b459e90fb..ae3a20e800 100644 --- a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor @@ -3,6 +3,7 @@ USING: accessors arrays assocs bit-arrays bit-sets fry hashtables hints kernel locals math namespaces sequences sets compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ; +QUALIFIED: new-sets IN: compiler.cfg.ssa.construction.tdmsc ! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for @@ -15,7 +16,7 @@ IN: compiler.cfg.ssa.construction.tdmsc SYMBOLS: visited merge-sets levels again? ; : init-merge-sets ( cfg -- ) - post-order dup length '[ _ ] H{ } map>assoc merge-sets set ; + post-order dup length '[ _ ] H{ } map>assoc merge-sets set ; : compute-levels ( cfg -- ) 0 over entry>> associate [ @@ -29,15 +30,12 @@ SYMBOLS: visited merge-sets levels again? ; : level ( bb -- n ) levels get at ; inline -: set-bit ( bit-array n -- ) - [ t ] 2dip swap set-nth ; - : update-merge-set ( tmp to -- ) [ merge-sets get ] dip '[ _ - [ merge-sets get at bit-set-union ] - [ dupd number>> set-bit ] + [ merge-sets get at new-sets:union ] + [ number>> over new-sets:adjoin ] bi ] change-at ; @@ -54,7 +52,7 @@ SYMBOLS: visited merge-sets levels again? ; : visited? ( pair -- ? ) visited get key? ; : consistent? ( snode lnode -- ? ) - [ merge-sets get at ] bi@ swap bit-set-subset? ; + [ merge-sets get at ] bi@ new-sets:subset? ; : (process-edge) ( from to -- ) f walk [ @@ -82,14 +80,9 @@ SYMBOLS: visited merge-sets levels again? ; loop ; : (merge-set) ( bbs -- flags rpo ) - merge-sets get '[ _ at ] [ bit-set-union ] map-reduce + merge-sets get '[ _ at ] [ new-sets:union ] map-reduce cfg get reverse-post-order ; inline -: filter-by ( flags seq -- seq' ) - [ drop ] selector [ 2each ] dip ; - -HINTS: filter-by { bit-array object } ; - PRIVATE> : compute-merge-sets ( cfg -- ) @@ -101,10 +94,8 @@ PRIVATE> [ compute-merge-set-loop ] tri ; -: merge-set-each ( bbs quot: ( bb -- ) -- ) - [ (merge-set) ] dip '[ - swap _ [ drop ] if - ] 2each ; inline - : merge-set ( bbs -- bbs' ) - (merge-set) filter-by ; + (merge-set) [ new-sets:members ] dip nths ; + +: merge-set-each ( bbs quot: ( bb -- ) -- ) + [ merge-set ] dip each ; inline diff --git a/basis/new-sets/new-sets-tests.factor b/basis/new-sets/new-sets-tests.factor new file mode 100644 index 0000000000..a03ab9f18e --- /dev/null +++ b/basis/new-sets/new-sets-tests.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2010 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: new-sets tools.test kernel sorting prettyprint bit-arrays arrays ; +IN: new-sets.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 diff --git a/basis/new-sets/new-sets.factor b/basis/new-sets/new-sets.factor new file mode 100644 index 0000000000..770368ae3b --- /dev/null +++ b/basis/new-sets/new-sets.factor @@ -0,0 +1,88 @@ +! Copyright (C) 2010 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs hashtables kernel +math sequences parser prettyprint.custom ; +QUALIFIED: sets +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 +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 ; + + + +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 } ; + +: ( 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 ] unless ; +M: hash-set clone + table>> clone hash-set boa ; + +SYNTAX: HS{ + \ } [ ] 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 ;