Skip to content
This repository
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 186 lines (126 sloc) 4.075 kb
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 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
! 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: ?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 )
GENERIC: clear-set ( set -- )

M: f members drop f ;

M: f cardinality drop 0 ;

M: f delete 2drop ;

M: f clear-set drop ; inline

! Defaults for some methods.
! Override them for efficiency

M: set ?adjoin 2dup in? [ 2drop f ] [ adjoin t ] if ;

M: set null? members null? ; inline

M: set cardinality members length ;

M: set clear-set [ members ] keep [ delete ] curry each ;

M: set set-like drop ; inline

<PRIVATE

: ?members ( set -- seq )
dup sequence? [ members ] unless ; inline

: (union) ( set1 set2 -- seq )
[ ?members ] bi@ append ; inline

PRIVATE>

M: set union [ (union) ] 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 ; inline

: (intersect) ( set1 set2 -- seq )
small/large sequence/tester filter ; inline

: (diff) ( set1 set2 -- seq )
sequence/tester [ not ] compose filter ; inline

PRIVATE>

M: set intersect [ (intersect) ] keep set-like ;

M: set diff [ (diff) ] 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 set accum -- )
2over ?adjoin [ nip push ] [ 3drop ] 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
fast-set cardinality ;

M: sequence clear-set
delete-all ; inline

: combine ( sets -- set/f )
[ f ]
[ [ [ ?members ] map concat ] [ first ] bi set-like ]
if-empty ;

: intersection ( sets -- set/f )
[ f ] [ [ ] [ intersect ] map-reduce ] 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 ;

: adjoin-all ( seq set -- )
[ adjoin ] curry each ;

: union! ( set1 set2 -- set1 )
?members over adjoin-all ;

: diff! ( set1 set2 -- set1 )
dupd sequence/tester [ dup ] prepose pick
[ delete ] curry [ [ drop ] if ] curry compose each ;

: intersect! ( set1 set2 -- set1 )
dupd sequence/tester [ dup ] prepose [ not ] compose pick
[ delete ] curry [ [ drop ] if ] curry compose each ;

! 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 ;
Something went wrong with that request. Please try again.