core/sets/sets.factor

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