core/hashtables/hashtables.factor

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