core/hashtables/hashtables.factor

   1 ! Copyright (C) 2005, 2011 John Benediktsson, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs kernel kernel.private math
   4 math.private sequences sequences.private slots.private vectors ;
   5 IN: hashtables
   6
   7 TUPLE: hashtable
   8     { count array-capacity }
   9     { deleted array-capacity }
  10     { array array } ;
  11
  12 <PRIVATE
  13
  14 : wrap ( i array -- n )
  15     length>> 1 fixnum-fast fixnum-bitand ; inline
  16
  17 : hash@ ( key array -- i )
  18     [ hashcode >fixnum dup fixnum+fast ] dip wrap ; inline
  19
  20 : probe ( array i probe# -- array i probe# )
  21     2 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     3 * 1 + 2/ next-power-of-2 2 * +empty+ <array> ; inline
  40
  41 : init-hash ( hash -- )
  42     0 >>count 0 >>deleted drop ; inline
  43
  44 : reset-hash ( n hash -- )
  45     swap <hash-array> >>array init-hash ; inline
  46
  47 : hash-count+ ( hash -- )
  48     [ 1 fixnum+fast ] change-count drop ; inline
  49
  50 : hash-deleted+ ( hash -- )
  51     [ 1 fixnum+fast ] change-deleted drop ; inline
  52
  53 : hash-deleted- ( hash -- )
  54     [ 1 fixnum-fast ] change-deleted drop ; inline
  55
  56 ! i = first-empty-or-found
  57 ! j = first-deleted
  58 ! empty? = if true, key was not found
  59 !
  60 ! if empty? is f:
  61 ! - we want to store into i
  62 !
  63 ! if empty? is t:
  64 ! - we want to store into j if j is not f
  65 ! - otherwise we want to store into i
  66 ! - ... and increment count
  67
  68 : (new-key@) ( key array i probe# j -- array i j empty? )
  69     [ 2dup swap array-nth ] 2dip pick tombstone?
  70     [
  71         rot +empty+ eq?
  72         [ nip [ drop ] 3dip t ]
  73         [ pick or [ probe ] dip (new-key@) ]
  74         if
  75     ] [
  76         [ pickd = ] 2dip rot
  77         [ nip [ drop ] 3dip f ]
  78         [ [ probe ] dip (new-key@) ]
  79         if
  80     ] if ; inline recursive
  81
  82 : new-key@ ( key hash -- array n )
  83     [ array>> 2dup hash@ 0 f (new-key@) ] keep swap
  84     [ over [ hash-deleted- ] [ hash-count+ ] if swap or ] [ 2drop ] if ; inline
  85
  86 : set-nth-pair ( value key array n -- )
  87     2 fixnum+fast [ set-slot ] 2keep
  88     1 fixnum+fast set-slot ; inline
  89
  90 : (set-at) ( value key hash -- )
  91     dupd new-key@ set-nth-pair ; inline
  92
  93 : (rehash) ( alist hash -- )
  94     [ swapd (set-at) ] curry assoc-each ; inline
  95
  96 : hash-large? ( hash -- ? )
  97     [ count>> 1 fixnum+fast 3 fixnum*fast ]
  98     [ array>> length>> ] bi fixnum>= ; inline
  99
 100 : each-pair ( ... array quot: ( ... key value -- ... ) -- ... )
 101     [
 102         [ length 2/ ] keep [
 103             [ 1 fixnum-shift-fast ] dip [ array-nth ] 2keep
 104             pick tombstone? [ 3drop ]
 105         ] curry
 106     ] dip [ [ 1 fixnum+fast ] dip array-nth ] prepose
 107     [ if ] curry compose each-integer ; inline
 108
 109 : grow-hash ( hash -- )
 110     { hashtable } declare [
 111         [ array>> ]
 112         [ assoc-size 1 + ]
 113         [ reset-hash ] tri
 114     ] keep [ swapd (set-at) ] curry each-pair ;
 115
 116 : ?grow-hash ( hash -- )
 117     dup hash-large? [ grow-hash ] [ drop ] if ; inline
 118
 119 PRIVATE>
 120
 121 : <hashtable> ( n -- hash )
 122     integer>fixnum-strict
 123     [ 0 0 ] dip <hash-array> hashtable boa ; inline
 124
 125 M: hashtable at*
 126     key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
 127
 128 M: hashtable clear-assoc
 129     [ init-hash ] [ array>> [ drop +empty+ ] map! drop ] bi ;
 130
 131 M: hashtable delete-at
 132     [ nip ] [ key@ ] 2bi [
 133         [ +tombstone+ dup ] 2dip set-nth-pair
 134         hash-deleted+
 135     ] [
 136         3drop
 137     ] if ;
 138
 139 M: hashtable assoc-size
 140     [ count>> ] [ deleted>> ] bi - ; inline
 141
 142 : rehash ( hash -- )
 143     [ >alist ] [ clear-assoc ] [ (rehash) ] tri ;
 144
 145 M: hashtable set-at
 146     dup ?grow-hash (set-at) ;
 147
 148 : associate ( value key -- hash )
 149     [ 1 0 ] 2dip 1 <hash-array>
 150     [ 2dup hash@ set-nth-pair ] keep
 151     hashtable boa ; inline
 152
 153 <PRIVATE
 154
 155 : collect-pairs ( hash quot: ( key value -- elt ) -- seq )
 156     [ [ array>> 0 swap ] [ assoc-size f <array> ] bi ] dip swap [
 157         [ overd set-nth-unsafe 1 + ] curry compose each-pair
 158     ] keep nip ; inline
 159
 160 PRIVATE>
 161
 162 M: hashtable >alist [ 2array ] collect-pairs ;
 163
 164 M: hashtable keys [ drop ] collect-pairs ;
 165
 166 M: hashtable values [ nip ] collect-pairs ;
 167
 168 M: hashtable unzip
 169     [ assoc-size dup [ <vector> ] bi@ ] [ array>> ] bi
 170     [ [ suffix! ] bi-curry@ bi* ] each-pair [ { } like ] bi@ ;
 171
 172 M: hashtable clone
 173     (clone) [ clone ] change-array ; inline
 174
 175 M: hashtable equal?
 176     over hashtable? [ assoc= ] [ 2drop f ] if ;
 177
 178 M: hashtable hashcode*
 179     [
 180         dup assoc-size 1 eq?
 181         [ assoc-hashcode ] [ nip assoc-size ] if
 182     ] recursive-hashcode ;
 183
 184 ! Default method
 185 M: assoc new-assoc drop <hashtable> ; inline
 186
 187 M: f new-assoc drop <hashtable> ; inline
 188
 189 : >hashtable ( assoc -- hashtable )
 190     [ >alist ] [ assoc-size <hashtable> ] bi [ (rehash) ] keep ;
 191
 192 M: hashtable assoc-like
 193     drop dup hashtable? [ >hashtable ] unless ; inline
 194
 195 : ?set-at ( value key assoc/f -- assoc )
 196     [ [ set-at ] keep ] [ associate ] if* ;
 197
 198 ! borrowed from boost::hash_combine, but the
 199 ! magic number is 2^29/phi instead of 2^32/phi
 200 ! due to max fixnum value on 32-bit machines
 201 : hash-combine ( hash1 hash2 -- newhash )
 202     [ 0x13c6ef37 + ] dip [ 6 shift ] [ -2 shift ] bi + + ; inline
 203
 204 ERROR: malformed-hashtable-pair seq pair ;
 205
 206 : check-hashtable ( seq -- seq )
 207     dup [ dup length 2 = [ drop ] [ malformed-hashtable-pair ] if ] each ;
 208
 209 : parse-hashtable ( seq -- hashtable )
 210     check-hashtable H{ } assoc-clone-like ;
 211
 212 INSTANCE: hashtable assoc