core/hash-sets/hash-sets.factor

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