core/collections/hashtables.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: hashtables-internals
   4 USING: arrays hashtables kernel kernel-internals math
   5 math-internals sequences sequences-internals vectors ;
   6
   7 TUPLE: tombstone ;
   8
   9 : ((empty)) T{ tombstone f } ; inline
  10 : ((tombstone)) T{ tombstone t } ; inline
  11
  12 : hash@ ( key array -- i )
  13     >r hashcode r> array-capacity 2 /i rem 2 * >fixnum ; inline
  14
  15 : probe ( array i -- array i )
  16     2 fixnum+fast over array-capacity fixnum-mod ; inline
  17
  18 : (key@) ( key keys i -- n )
  19     #! cond form expanded by hand for better interpreter speed
  20     3dup swap array-nth dup ((tombstone)) eq? [
  21         2drop probe (key@)
  22     ] [
  23         dup ((empty)) eq? [
  24             2drop 3drop -1
  25         ] [
  26             = [ 2nip ] [ probe (key@) ] if
  27         ] if
  28     ] if ; inline
  29
  30 : key@ ( key hash -- i )
  31     hash-array 2dup hash@ (key@) ; inline
  32
  33 : if-key ( key hash true false -- )
  34     >r >r [ key@ ] 2keep pick -1 > r> r> if ; inline
  35
  36 : <hash-array> ( n -- array )
  37     >fixnum 1+ 4 * ((empty)) <array> ; inline
  38
  39 : init-hash ( hash -- )
  40     0 over set-hash-count 0 swap set-hash-deleted ;
  41
  42 : reset-hash ( n hash -- )
  43     swap <hash-array> over set-hash-array init-hash ;
  44
  45 : (new-key@) ( key keys i -- n )
  46     #! cond form expanded by hand for better interpreter speed
  47     3dup swap array-nth dup ((empty)) eq? [
  48         2drop 2nip
  49     ] [
  50         = [
  51             2nip
  52         ] [
  53             probe (new-key@)
  54         ] if
  55     ] if ; inline
  56
  57 : new-key@ ( key hash -- i )
  58     hash-array 2dup hash@ (new-key@) ; inline
  59
  60 : nth-pair ( n seq -- key value )
  61     [ array-nth ] 2keep >r 1+ r> array-nth ; inline
  62
  63 : set-nth-pair ( value key n seq -- )
  64     [ set-array-nth ] 2keep >r 1+ r> set-array-nth ; inline
  65
  66 : hash-count+ ( hash -- )
  67     dup hash-count 1+ swap set-hash-count ; inline
  68
  69 : hash-deleted+ ( hash -- )
  70     dup hash-deleted 1+ swap set-hash-deleted ; inline
  71
  72 : change-size ( hash old -- )
  73     ((empty)) eq? [ hash-count+ ] [ drop ] if ; inline
  74
  75 : (set-hash) ( value key hash -- )
  76     2dup new-key@ swap
  77     [ hash-array 2dup array-nth ] keep
  78     swap change-size set-nth-pair ; inline
  79
  80 : (each-pair) ( quot array i -- )
  81     over array-capacity over eq? [
  82         3drop
  83     ] [
  84         [
  85             swap nth-pair over tombstone?
  86             [ 3drop ] [ rot call ] if
  87         ] 3keep 2 fixnum+fast (each-pair)
  88     ] if ; inline
  89
  90 : each-pair ( array quot -- )
  91     swap 0 (each-pair) ; inline
  92
  93 : (all-pairs?) ( quot array i -- ? )
  94     over array-capacity over eq? [
  95         3drop t
  96     ] [
  97         3dup >r >r >r swap nth-pair over tombstone? [
  98             3drop r> r> r> 2 fixnum+fast (all-pairs?)
  99         ] [
 100             rot call [
 101                 r> r> r> 2 fixnum+fast (all-pairs?)
 102             ] [
 103                 r> r> r> 3drop f
 104             ] if
 105         ] if
 106     ] if ; inline
 107
 108 : all-pairs? ( array quot -- ? )
 109     swap 0 (all-pairs?) ; inline
 110
 111 : (hash-keys/values) ( hash quot -- accum array )
 112     >r
 113     hash-array [ length 2 /i <vector> ] keep
 114     r> each-pair { } like ; inline
 115
 116 IN: hashtables
 117
 118 : <hashtable> ( n -- hash )
 119     (hashtable) [ reset-hash ] keep ;
 120
 121 : hash* ( key hash -- value ? )
 122     [
 123         nip >r 1 fixnum+fast r> hash-array array-nth t
 124     ] [
 125         3drop f f
 126     ] if-key ;
 127
 128 : hash-member? ( key hash -- ? )
 129     [ 3drop t ] [ 3drop f ] if-key ;
 130
 131 : ?hash* ( key hash/f -- value/f ? )
 132     dup [ hash* ] [ 2drop f f ] if ;
 133
 134 : hash ( key hash -- value ) hash* drop ; inline
 135
 136 : ?hash ( key hash/f -- value )
 137     dup [ hash ] [ 2drop f ] if ;
 138
 139 : clear-hash ( hash -- )
 140     dup init-hash hash-array [ drop ((empty)) ] inject ;
 141
 142 : remove-hash ( key hash -- )
 143     [
 144         nip
 145         dup hash-deleted+
 146         hash-array >r >r ((tombstone)) dup r> r> set-nth-pair
 147     ] [
 148         3drop
 149     ] if-key ;
 150
 151 : remove-hash* ( key hash -- old )
 152     [ hash ] 2keep remove-hash ;
 153
 154 : ?remove-hash ( key hash -- )
 155     [ remove-hash ] [ drop ] if* ;
 156
 157 : hash-size ( hash -- n )
 158     dup hash-count swap hash-deleted - ; inline
 159
 160 : hash-empty? ( hash -- ? ) hash-size zero? ;
 161
 162 : grow-hash ( hash -- )
 163     [ dup hash-array swap hash-size 1+ ] keep
 164     [ reset-hash ] keep swap [ swap pick (set-hash) ] each-pair
 165     drop ;
 166
 167 : ?grow-hash ( hash -- )
 168     dup hash-count 1 fixnum+fast 3 fixnum*
 169     over hash-array array-capacity >
 170     [ grow-hash ] [ drop ] if ; inline
 171
 172 : set-hash ( value key hash -- )
 173     dup ?grow-hash (set-hash) ;
 174
 175 : hash+ ( n key hash -- )
 176     [ hash [ 0 ] unless* + ] 2keep set-hash ;
 177
 178 : associate ( value key -- hash )
 179     2 <hashtable> [ set-hash ] keep ;
 180
 181 : hash-keys ( hash -- seq )
 182     [ drop over push ] (hash-keys/values) ;
 183
 184 : hash-values ( hash -- seq )
 185     [ nip over push ] (hash-keys/values) ;
 186
 187 : hash>alist ( hash -- alist )
 188     dup hash-keys swap hash-values 2array flip ;
 189
 190 : alist>hash ( alist -- hash )
 191     [ length <hashtable> ] keep
 192     [ first2 swap pick (set-hash) ] each ;
 193
 194 : hash-each ( hash quot -- )
 195     >r hash-array r> each-pair ; inline
 196
 197 : hash-each-with ( obj hash quot -- )
 198     swap [ 2swap [ >r -rot r> call ] 2keep ] hash-each 2drop ;
 199     inline
 200
 201 : hash-all? ( hash quot -- ? )
 202     >r hash-array r> all-pairs? ; inline
 203
 204 : hash-all-with? ( obj hash quot -- )
 205     swap
 206     [ 2swap [ >r -rot r> call ] 2keep rot ] hash-all? 2nip ;
 207     inline
 208
 209 : subhash? ( hash1 hash2 -- ? )
 210     swap [
 211         >r swap hash* [ r> = ] [ r> 2drop f ] if
 212     ] hash-all-with? ;
 213
 214 : hash-subset ( hash quot -- subhash )
 215     over hash-size <hashtable> rot [
 216         2swap [
 217             >r pick pick >r >r call [
 218                 r> r> swap r> set-hash
 219             ] [
 220                 r> r> r> 3drop
 221             ] if
 222         ] 2keep
 223     ] hash-each nip ; inline
 224
 225 : hash-subset-with ( obj hash quot -- subhash )
 226     swap
 227     [ 2swap [ >r -rot r> call ] 2keep rot ] hash-subset 2nip ;
 228     inline
 229
 230 M: hashtable clone
 231     (clone) dup hash-array clone over set-hash-array ;
 232
 233 : hashtable= ( hash hash -- ? )
 234     2dup subhash? >r swap subhash? r> and ;
 235
 236 M: hashtable equal?
 237     {
 238         { [ over hashtable? not ] [ 2drop f ] }
 239         { [ 2dup [ hash-size ] 2apply number= not ] [ 2drop f ] }
 240         { [ t ] [ hashtable= ] }
 241     } cond ;
 242
 243 : hashtable-hashcode ( hashtable -- n )
 244     0 swap [
 245         hashcode >r hashcode -1 shift r> bitxor bitxor
 246     ] hash-each ;
 247
 248 M: hashtable hashcode
 249     dup hash-size 1 number=
 250     [ hashtable-hashcode ] [ hash-size ] if ;
 251
 252 : ?hash ( key hash/f -- value/f )
 253     dup [ hash ] [ 2drop f ] if ;
 254
 255 : ?hash* ( key hash/f -- value/f ? )
 256     dup [ hash* ] [ 2drop f f ] if ;
 257
 258 IN: hashtables-internals
 259
 260 : (hash-stack) ( key i seq -- value )
 261     over 0 < [
 262         3drop f
 263     ] [
 264         3dup nth-unsafe dup [
 265             hash* [
 266                 >r 3drop r>
 267             ] [
 268                 drop >r 1- r> (hash-stack)
 269             ] if
 270         ] [
 271             2drop >r 1- r> (hash-stack)
 272         ] if
 273     ] if ;
 274
 275 IN: hashtables
 276
 277 : hash-stack ( key seq -- value )
 278     dup length 1- swap (hash-stack) ;
 279
 280 : hash-intersect ( hash1 hash2 -- intersection )
 281     [ drop swap hash ] hash-subset-with ;
 282
 283 : hash-diff ( hash1 hash2 -- difference )
 284     [ drop swap hash not ] hash-subset-with ;
 285
 286 : hash-update ( hash1 hash2 -- )
 287     [ swap rot set-hash ] hash-each-with ;
 288
 289 : hash-union ( hash1 hash2 -- union )
 290     >r clone dup r> hash-update ;
 291
 292 : remove-all ( hash seq -- subseq )
 293     [ swap hash-member? not ] subset-with ;
 294
 295 : cache ( key hash quot -- value )
 296     pick pick hash [
 297         >r 3drop r>
 298     ] [
 299         pick rot >r >r call dup r> r> set-hash
 300     ] if* ; inline
 301
 302 : map>hash ( seq quot -- hash )
 303     over length <hashtable> rot
 304     [ -rot [ >r call swap r> set-hash ] 2keep ] each nip ;
 305     inline