core/hashtables/hashtables.factor

   1 ! Copyright (C) 2005, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel kernel.private slots.private math assocs
   4        math.private sequences sequences.private vectors ;
   5 IN: hashtables
   6
   7 <PRIVATE
   8
   9 : wrap ( i array -- n )
  10     array-capacity 1 fixnum-fast fixnum-bitand ; inline
  11
  12 : hash@ ( key array -- i )
  13     >r hashcode >fixnum dup fixnum+fast r> wrap ; inline
  14
  15 : probe ( array i -- array i )
  16     2 fixnum+fast over wrap ; inline
  17
  18 : (key@) ( key keys i -- array n ? )
  19     3dup swap array-nth
  20     dup ((empty)) eq?
  21     [ 3drop nip f f ] [
  22         = [ rot drop t ] [ probe (key@) ] if
  23     ] if ; inline
  24
  25 : key@ ( key hash -- array n ? )
  26     hash-array 2dup hash@ (key@) ; inline
  27
  28 : <hash-array> ( n -- array )
  29     1+ next-power-of-2 4 * ((empty)) <array> ; inline
  30
  31 : init-hash ( hash -- )
  32     0 over set-hash-count 0 swap set-hash-deleted ;
  33
  34 : reset-hash ( n hash -- )
  35     swap <hash-array> over set-hash-array init-hash ;
  36
  37 : (new-key@) ( key keys i -- keys n empty? )
  38     3dup swap array-nth dup ((empty)) eq? [
  39         2drop rot drop t
  40     ] [
  41         = [
  42             rot drop f
  43         ] [
  44             probe (new-key@)
  45         ] if
  46     ] if ; inline
  47
  48 : new-key@ ( key hash -- array n empty? )
  49     hash-array 2dup hash@ (new-key@) ; inline
  50
  51 : nth-pair ( n seq -- key value )
  52     swap 2 fixnum+fast 2dup slot -rot 1 fixnum+fast slot ;
  53     inline
  54
  55 : set-nth-pair ( value key seq n -- )
  56     2 fixnum+fast [ set-slot ] 2keep
  57     1 fixnum+fast set-slot ; inline
  58
  59 : hash-count+ ( hash -- )
  60     dup hash-count 1+ swap set-hash-count ; inline
  61
  62 : hash-deleted+ ( hash -- )
  63     dup hash-deleted 1+ swap set-hash-deleted ; inline
  64
  65 : (set-hash) ( value key hash -- new? )
  66     2dup new-key@
  67     [ rot hash-count+ set-nth-pair t ]
  68     [ rot drop set-nth-pair f ] if ; inline
  69
  70 : find-pair-next >r 2 fixnum+fast r> ; inline
  71
  72 : (find-pair) ( quot i array -- key value ? )
  73     2dup array-capacity eq? [
  74         3drop f f f
  75     ] [
  76         2dup array-nth tombstone? [
  77             find-pair-next (find-pair)
  78         ] [
  79             [ nth-pair rot call ] 3keep roll [
  80                 nth-pair >r nip r> t
  81             ] [
  82                 find-pair-next (find-pair)
  83             ] if
  84         ] if
  85     ] if ; inline
  86
  87 : find-pair ( array quot -- key value ? )
  88     0 rot (find-pair) ; inline
  89
  90 : (rehash) ( hash array -- )
  91     [ swap pick (set-hash) drop f ] find-pair 2drop 2drop ;
  92
  93 : hash-large? ( hash -- ? )
  94     [ hash-count 3 fixnum*fast  ]
  95     [ hash-array array-capacity ] bi > ;
  96
  97 : hash-stale? ( hash -- ? )
  98     [ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ;
  99
 100 : grow-hash ( hash -- )
 101     [ dup hash-array swap assoc-size 1+ ] keep
 102     [ reset-hash ] keep
 103     swap (rehash) ;
 104
 105 : ?grow-hash ( hash -- )
 106     dup hash-large? [
 107         grow-hash
 108     ] [
 109         dup hash-stale? [
 110             grow-hash
 111         ] [
 112             drop
 113         ] if
 114     ] if ; inline
 115
 116 PRIVATE>
 117
 118 : <hashtable> ( n -- hash )
 119     hashtable new [ reset-hash ] keep ;
 120
 121 M: hashtable at* ( key hash -- value ? )
 122     key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
 123
 124 M: hashtable clear-assoc ( hash -- )
 125     dup init-hash hash-array [ drop ((empty)) ] change-each ;
 126
 127 M: hashtable delete-at ( key hash -- )
 128     tuck key@ [
 129         >r >r ((tombstone)) dup r> r> set-nth-pair
 130         hash-deleted+
 131     ] [
 132         3drop
 133     ] if ;
 134
 135 M: hashtable assoc-size ( hash -- n )
 136     dup hash-count swap hash-deleted - ;
 137
 138 : rehash ( hash -- )
 139     dup hash-array
 140     dup length ((empty)) <array> pick set-hash-array
 141     0 pick set-hash-count
 142     0 pick set-hash-deleted
 143     (rehash) ;
 144
 145 M: hashtable set-at ( value key hash -- )
 146     dup >r (set-hash) [ r> ?grow-hash ] [ r> drop ] if ;
 147
 148 : associate ( value key -- hash )
 149     2 <hashtable> [ set-at ] keep ;
 150
 151 M: hashtable assoc-find ( hash quot -- key value ? )
 152     >r hash-array r> find-pair ;
 153
 154 M: hashtable clone
 155     (clone) dup hash-array clone over set-hash-array ;
 156
 157 M: hashtable equal?
 158     over hashtable? [
 159         2dup [ assoc-size ] bi@ number=
 160         [ assoc= ] [ 2drop f ] if
 161     ] [ 2drop f ] if ;
 162
 163 ! Default method
 164 M: assoc new-assoc drop <hashtable> ;
 165
 166 M: f new-assoc drop <hashtable> ;
 167
 168 : >hashtable ( assoc -- hashtable )
 169     H{ } assoc-clone-like ;
 170
 171 M: hashtable assoc-like
 172     drop dup hashtable? [ >hashtable ] unless ;
 173
 174 : ?set-at ( value key assoc/f -- assoc )
 175     [ [ set-at ] keep ] [ associate ] if* ;
 176
 177 INSTANCE: hashtable assoc