forked from factor/factor
/
sets.factor
142 lines (100 loc) · 2.98 KB
/
sets.factor
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
! Copyright (C) 2010 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel math sequences vectors ;
FROM: assocs => change-at ;
IN: sets
! 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 -- seq )
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 -- ? )
GENERIC: duplicates ( set -- seq )
GENERIC: all-unique? ( set -- ? )
GENERIC: null? ( set -- ? )
GENERIC: cardinality ( set -- n )
M: f cardinality drop 0 ;
! Defaults for some methods.
! Override them for efficiency
M: set null? members null? ; inline
M: set cardinality members length ;
M: set set-like drop ; inline
M: set union
[ [ members ] bi@ append ] keep set-like ;
<PRIVATE
: tester ( set -- quot )
fast-set [ in? ] curry ; inline
: sequence/tester ( set1 set2 -- set1' quot )
[ members ] [ tester ] bi* ; inline
: small/large ( set1 set2 -- set1' set2' )
2dup [ cardinality ] bi@ > [ swap ] when ;
PRIVATE>
M: set intersect
[ small/large sequence/tester filter ] keep set-like ;
M: set diff
[ sequence/tester [ not ] compose filter ] keep set-like ;
M: set intersects?
small/large sequence/tester any? ;
<PRIVATE
: (subset?) ( set1 set2 -- ? )
sequence/tester all? ; inline
PRIVATE>
M: set subset?
2dup [ cardinality ] bi@ > [ 2drop f ] [ (subset?) ] if ;
M: set set=
2dup [ cardinality ] bi@ eq? [ (subset?) ] [ 2drop f ] if ;
M: set fast-set ;
M: set duplicates drop f ;
M: set all-unique? drop t ;
<PRIVATE
: (pruned) ( elt hash vec -- )
3dup drop in? [ 3drop ] [
[ drop adjoin ] [ nip push ] 3bi
] if ; inline
: pruned ( seq -- newseq )
[ f fast-set ] [ length <vector> ] bi
[ [ (pruned) ] 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
[ members ] dip like ;
M: sequence members
[ pruned ] keep like ;
M: sequence null?
empty? ; inline
M: sequence cardinality
pruned length ;
: combine ( sets -- set/f )
[ f ]
[ [ [ members ] map concat ] [ first ] bi set-like ]
if-empty ;
: gather ( ... seq quot: ( ... elt -- ... elt' ) -- ... newseq )
map concat members ; inline
: adjoin-at ( value key assoc -- )
[ [ f fast-set ] unless* [ adjoin ] keep ] change-at ;
: within ( seq set -- subseq )
tester filter ;
: without ( seq set -- subseq )
tester [ not ] compose filter ;
! Temporarily for compatibility
: unique ( seq -- assoc )
[ dup ] H{ } map>assoc ;
: conjoin ( elt assoc -- )
dupd set-at ;
: conjoin-at ( value key assoc -- )
[ dupd ?set-at ] change-at ;