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 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 -- sequence )
  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 -- sequence )
  22 GENERIC: all-unique? ( set -- ? )
  23
  24 ! Defaults for some methods.
  25 ! Override them for efficiency
  26
  27 M: set union
  28     [ [ members ] bi@ append ] keep set-like ;
  29
  30 <PRIVATE
  31
  32 : tester ( set -- quot )
  33     fast-set [ in? ] curry ; inline
  34
  35 : sequence/tester ( set1 set2 -- set1' quot )
  36     [ members ] [ tester ] bi* ; inline
  37
  38 PRIVATE>
  39
  40 M: set intersect
  41     [ sequence/tester filter ] keep set-like ;
  42
  43 M: set diff
  44     [ sequence/tester [ not ] compose filter ] keep set-like ;
  45
  46 M: set intersects?
  47     sequence/tester any? ;
  48
  49 M: set subset?
  50     sequence/tester all? ;
  51
  52 M: set set=
  53     2dup subset? [ swap subset? ] [ 2drop f ] if ;
  54
  55 M: set fast-set ;
  56
  57 M: set duplicates drop f ;
  58
  59 M: set all-unique? drop t ;
  60
  61 <PRIVATE
  62
  63 : (pruned) ( elt hash vec -- )
  64     3dup drop in? [ 3drop ] [
  65         [ drop adjoin ] [ nip push ] 3bi
  66     ] if ; inline
  67
  68 : pruned ( seq -- newseq )
  69     [ f fast-set ] [ length <vector> ] bi
  70     [ [ (pruned) ] 2curry each ] keep ;
  71
  72 PRIVATE>
  73
  74 ! Sequences are sets
  75 INSTANCE: sequence set
  76
  77 M: sequence in?
  78     member? ; inline
  79
  80 M: sequence adjoin
  81     [ delete ] [ push ] 2bi ;
  82
  83 M: sequence delete
  84     remove! drop ; inline
  85
  86 M: sequence set-like
  87     [ members ] dip like ;
  88
  89 M: sequence members
  90     [ pruned ] keep like ;
  91
  92 M: sequence all-unique?
  93     dup pruned sequence= ;
  94
  95 : combine ( sets -- set )
  96     f [ union ] reduce ;
  97
  98 : gather ( seq quot -- newseq )
  99     map concat members ; inline
 100
 101 : adjoin-at ( value key assoc -- )
 102     [ [ f fast-set ] unless* [ adjoin ] keep ] change-at ;
 103
 104 ! Temporarily for compatibility
 105
 106 ALIAS: prune members
 107 : unique ( seq -- assoc )
 108     [ dup ] H{ } map>assoc ;
 109 : conjoin ( elt assoc -- )
 110     dupd set-at ;
 111 : conjoin-at ( value key assoc -- )
 112     [ dupd ?set-at ] change-at ;