From 05df3b3fd0a9344168d3cd95d44983af8c35cf24 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 16 Feb 2010 15:15:12 -0600 Subject: [PATCH] Finishing moving new-sets to basis --- extra/bags/bags-tests.factor | 127 ------------------------------- extra/bags/bags.factor | 143 ----------------------------------- 2 files changed, 270 deletions(-) delete mode 100644 extra/bags/bags-tests.factor delete mode 100644 extra/bags/bags.factor diff --git a/extra/bags/bags-tests.factor b/extra/bags/bags-tests.factor deleted file mode 100644 index 13b5894ce1..0000000000 --- a/extra/bags/bags-tests.factor +++ /dev/null @@ -1,127 +0,0 @@ -! 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 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 diff --git a/extra/bags/bags.factor b/extra/bags/bags.factor deleted file mode 100644 index 78ffd8f781..0000000000 --- a/extra/bags/bags.factor +++ /dev/null @@ -1,143 +0,0 @@ -! 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 ; - - - -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 ; - -! Bit sets are 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. -: (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 - [ [ adjoin ] curry each ] keep - ] if ;