core/sets/sets.factor

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