1 ! Copyright (C) 2010 Daniel Ehrenberg
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: assocs hashtables kernel math sequences vectors ;
9 GENERIC: adjoin ( elt set -- )
10 GENERIC: ?adjoin ( elt set -- ? )
11 GENERIC: in? ( elt set -- ? )
12 GENERIC: delete ( elt set -- )
13 GENERIC: ?delete ( elt set -- ? )
14 GENERIC: set-like ( set exemplar -- set' )
15 GENERIC: fast-set ( set -- set' )
16 GENERIC: members ( set -- seq )
17 GENERIC: union ( set1 set2 -- set )
18 GENERIC: intersect ( set1 set2 -- set )
19 GENERIC: intersects? ( set1 set2 -- ? )
20 GENERIC: diff ( set1 set2 -- set )
21 GENERIC: subset? ( set1 set2 -- ? )
22 GENERIC: set= ( set1 set2 -- ? )
23 GENERIC: duplicates ( set -- seq )
24 GENERIC: all-unique? ( set -- ? )
25 GENERIC: null? ( set -- ? )
26 GENERIC: cardinality ( set -- n )
27 GENERIC: clear-set ( set -- )
31 M: f cardinality drop 0 ;
35 M: f clear-set drop ; inline
37 ! Defaults for some methods.
38 ! Override them for efficiency
40 M: set ?adjoin 2dup in? [ 2drop f ] [ adjoin t ] if ;
42 M: set ?delete 2dup in? [ delete t ] [ 2drop f ] if ;
44 M: set null? cardinality 0 = ; inline
46 M: set cardinality members length ;
48 M: set clear-set [ members ] keep [ delete ] curry each ;
50 M: set set-like drop ; inline
54 : ?members ( set -- seq )
55 dup sequence? [ members ] unless ; inline
57 : (union) ( set1 set2 -- seq )
58 [ ?members ] bi@ append ; inline
62 M: set union [ (union) ] keep set-like ;
66 : tester ( set -- quot )
67 fast-set [ in? ] curry ; inline
69 : sequence/tester ( set1 set2 -- set1' quot )
70 [ members ] [ tester ] bi* ; inline
72 : small/large ( set1 set2 -- set1' set2' )
73 2dup [ cardinality ] bi@ > [ swap ] when ; inline
75 : (intersect) ( set1 set2 -- seq )
76 small/large sequence/tester filter ; inline
78 : (diff) ( set1 set2 -- seq )
79 sequence/tester reject ; inline
83 M: set intersect [ (intersect) ] keep set-like ;
85 M: set diff [ (diff) ] keep set-like ;
88 small/large sequence/tester any? ;
92 : (subset?) ( set1 set2 -- ? )
93 sequence/tester all? ; inline
98 2dup [ cardinality ] bi@ > [ 2drop f ] [ (subset?) ] if ;
101 2dup [ cardinality ] bi@ = [ (subset?) ] [ 2drop f ] if ;
105 M: set duplicates drop f ;
107 M: set all-unique? drop t ;
110 INSTANCE: sequence set
116 [ delete ] [ push ] 2bi ;
119 remove! drop ; inline
122 [ members ] dip like ;
125 f fast-set [ ?adjoin ] curry filter ;
130 M: sequence cardinality
131 fast-set cardinality ;
133 M: sequence clear-set
136 : combine ( sets -- set/f )
138 [ [ [ ?members ] map concat ] [ first ] bi set-like ]
141 : refine ( sets -- set/f )
142 [ f ] [ [ ] [ intersect ] map-reduce ] if-empty ;
144 : gather ( ... seq quot: ( ... elt -- ... elts ) -- ... newseq )
145 map concat members ; inline
147 : adjoin-at ( value key assoc -- )
148 [ [ f fast-set ] unless* [ adjoin ] keep ] change-at ;
150 : within ( seq set -- subseq )
153 : without ( seq set -- subseq )
156 : adjoin-all ( seq set -- )
157 [ adjoin ] curry each ;
159 : union! ( set1 set2 -- set1 )
160 ?members over adjoin-all ;
162 : diff! ( set1 set2 -- set1 )
163 dupd sequence/tester pick
164 '[ dup @ [ _ delete ] [ drop ] if ] each ;
166 : intersect! ( set1 set2 -- set1 )
167 dupd sequence/tester pick
168 '[ dup @ [ drop ] [ _ delete ] if ] each ;