core/hash-sets/hash-sets.factor

   1 ! Copyright (C) 2010 Daniel Ehrenberg
   2 ! Copyright (C) 2005, 2011 John Benediktsson, Slava Pestov.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: accessors arrays growable.private hashtables.private
   5 kernel kernel.private math math.private sequences
   6 sequences.private sets sets.private slots.private vectors ;
   7 IN: hash-sets
   8
   9 TUPLE: hash-set
  10     { count array-capacity }
  11     { deleted array-capacity }
  12     { array array } ;
  13
  14 <PRIVATE
  15
  16 : hash@ ( key array -- i )
  17     [ hashcode >fixnum ] dip wrap ; inline
  18
  19 : probe ( array i probe# -- array i probe# )
  20     1 fixnum+fast [ fixnum+fast over wrap ] keep ; inline
  21
  22 : no-key ( key array -- array n ? ) nip f f ; inline
  23
  24 : (key@) ( key array i probe# -- array n ? )
  25     [ 3dup swap array-nth ] dip over +empty+ eq?
  26     [ 4drop no-key ] [
  27         [ = ] dip swap
  28         [ drop rot drop t ]
  29         [ probe (key@) ]
  30         if
  31     ] if ; inline recursive
  32
  33 : key@ ( key hash -- array n ? )
  34     array>> dup length>> 0 eq?
  35     [ no-key ] [ 2dup hash@ 0 (key@) ] if ; inline
  36
  37 : <hash-array> ( n -- array )
  38     3 * 1 + 2/ next-power-of-2 +empty+ <array> ; inline
  39
  40 : reset-hash ( n hash -- )
  41     swap <hash-array> >>array init-hash ; inline
  42
  43 : (new-key@) ( array key i probe# j -- array i j empty? )
  44     [ 2dup swap array-nth ] 2dip pick tombstone?
  45     [
  46         rot +empty+ eq?
  47         [ nip [ drop ] 3dip t ]
  48         [ pick or [ probe ] dip (new-key@) ]
  49         if
  50     ] [
  51         [ pickd = ] 2dip rot
  52         [ nip [ drop ] 3dip f ]
  53         [ [ probe ] dip (new-key@) ]
  54         if
  55     ] if ; inline recursive
  56
  57 : new-key@ ( key hash -- array n ? )
  58     [ array>> 2dup hash@ 0 f (new-key@) ] keep swap
  59     [ over [ hash-deleted- ] [ hash-count+ ] if swap or t ] [ 2drop f ] if ; inline
  60
  61 : set-nth-item ( key array n -- )
  62     2 fixnum+fast set-slot ; inline
  63
  64 : (adjoin) ( key hash -- ? )
  65     dupd new-key@ [ set-nth-item ] dip ; inline
  66
  67 : (delete) ( key hash -- ? )
  68     [ nip ] [ key@ ] 2bi [
  69         [ +tombstone+ ] 2dip set-nth-item
  70         hash-deleted+ t
  71     ] [
  72         3drop f
  73     ] if ; inline
  74
  75 : (rehash) ( seq hash -- )
  76     '[ _ (adjoin) drop ] each ; inline
  77
  78 : hash-large? ( hash -- ? )
  79     [ count>> 1 fixnum+fast 3 fixnum*fast ]
  80     [ array>> length>> 1 fixnum-shift-fast ] bi fixnum>= ; inline
  81
  82 : each-member ( ... array quot: ( ... elt -- ... ) -- ... )
  83     '[ dup tombstone? [ drop ] _ if ] each ; inline
  84
  85 : grow-hash ( hash -- )
  86     { hash-set } declare [
  87         [ array>> ]
  88         [ cardinality 1 + ]
  89         [ reset-hash ] tri
  90     ] keep [ (adjoin) drop ] curry each-member ;
  91
  92 : ?grow-hash ( hash -- )
  93     dup hash-large? [ grow-hash ] [ drop ] if ; inline
  94
  95 PRIVATE>
  96
  97 : <hash-set> ( capacity -- hash-set )
  98     integer>fixnum-strict
  99     [ 0 0 ] dip <hash-array> hash-set boa ; inline
 100
 101 M: hash-set in?
 102      key@ 2nip ;
 103
 104 M: hash-set clear-set
 105     [ init-hash ] [ array>> [ drop +empty+ ] map! drop ] bi ;
 106
 107 M: hash-set delete
 108     (delete) drop ;
 109
 110 M: hash-set ?delete
 111     (delete) ;
 112
 113 M: hash-set cardinality
 114     [ count>> ] [ deleted>> ] bi - ; inline
 115
 116 : rehash ( hash-set -- )
 117     [ members ] [ clear-set ] [ (rehash) ] tri ;
 118
 119 M: hash-set adjoin
 120     dup ?grow-hash (adjoin) drop ;
 121
 122 M: hash-set ?adjoin
 123     dup ?grow-hash (adjoin) ;
 124
 125 M: hash-set members
 126     [ array>> 0 swap ] [ cardinality f <array> ] bi [
 127         [ overd set-nth-unsafe 1 + ] curry each-member
 128     ] keep nip ;
 129
 130 M: hash-set clone
 131     (clone) [ clone ] change-array ; inline
 132
 133 M: hash-set equal?
 134     over hash-set? [ set= ] [ 2drop f ] if ;
 135
 136 : >hash-set ( members -- hash-set )
 137     dup length <hash-set> [ (rehash) ] keep ; inline
 138
 139 M: hash-set set-like
 140     drop dup hash-set? [ ?members >hash-set ] unless ; inline
 141
 142 INSTANCE: hash-set set
 143
 144 ! Overrides for performance
 145
 146 <PRIVATE
 147
 148 : and-tombstones ( quot: ( elt -- ? ) -- quot: ( elt -- ? ) )
 149     '[ dup tombstone? [ drop t ] _ if ] ; inline
 150
 151 : not-tombstones ( quot: ( elt -- ? ) -- quot: ( elt -- ? ) )
 152     '[ dup tombstone? [ drop f ] _ if ] ; inline
 153
 154 : array/tester ( hash-set1 hash-set2 -- array quot )
 155     [ array>> ] dip '[ _ in? ] ; inline
 156
 157 : filter-members ( hash-set array quot: ( elt -- ? ) -- accum )
 158     rot cardinality <vector> [
 159         '[ dup @ [ _ push-unsafe ] [ drop ] if ] each
 160     ] keep ; inline
 161
 162 PRIVATE>
 163
 164 M: hash-set intersect
 165     over hash-set? [
 166         small/large dupd array/tester not-tombstones
 167         filter-members >hash-set
 168     ] [ (intersect) >hash-set ] if ;
 169
 170 M: hash-set intersects?
 171     over hash-set? [
 172         small/large array/tester not-tombstones any?
 173     ] [ small/large sequence/tester any? ] if ;
 174
 175 M: hash-set union
 176     over hash-set? [
 177         small/large [ array>> ] [ clone ] bi*
 178         [ [ adjoin ] curry each-member ] keep
 179     ] [ (union) >hash-set ] if ;
 180
 181 M: hash-set diff
 182     over hash-set? [
 183         dupd array/tester [ not ] compose not-tombstones
 184         filter-members >hash-set
 185     ] [ (diff) >hash-set ] if ;
 186
 187 M: hash-set subset?
 188     over hash-set? [
 189         2dup [ cardinality ] bi@ > [ 2drop f ] [
 190             array/tester and-tombstones all?
 191         ] if
 192     ] [ call-next-method ] if ;
 193
 194 M: hash-set set=
 195     over hash-set? [
 196         2dup [ cardinality ] bi@ eq? [
 197             array/tester and-tombstones all?
 198         ] [ 2drop f ] if
 199     ] [ call-next-method ] if ;
 200
 201 M: hash-set hashcode*
 202     [
 203         dup cardinality 1 eq?
 204         [ members hashcode* ] [ nip cardinality ] if
 205     ] recursive-hashcode ;
 206
 207 ! Default methods
 208
 209 M: f fast-set drop 0 <hash-set> ;
 210
 211 M: sequence fast-set >hash-set ;
 212
 213 M: sequence duplicates
 214     dup length <hash-set> '[ _ ?adjoin ] reject ;
 215
 216 M: sequence all-unique?
 217     dup length <hash-set> '[ _ ?adjoin ] all? ;