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