core/sets/sets.factor

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