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