/core/sets/sets.factor

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