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 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     [ drop 3drop 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 4 * ((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 + ] change-count drop ; inline
  49
  50 : hash-deleted+ ( hash -- )
  51     [ 1 + ] change-deleted drop ; inline
  52
  53 : hash-deleted- ( hash -- )
  54     [ 1 - ] change-deleted drop ; inline
  55
  56 ! i = first-empty-or-found
  57 ! j = first-deleted
  58 : (new-key@) ( key array i probe# j -- array i j empty? )
  59     [ 2dup swap array-nth ] 2dip pick tombstone?
  60     [
  61         rot ((empty)) eq?
  62         [ nip [ drop ] 3dip t ]
  63         [ pick or [ probe ] dip (new-key@) ]
  64         if
  65     ] [
  66         [ [ pick ] dip = ] 2dip rot
  67         [ nip [ drop ] 3dip f ]
  68         [ [ probe ] dip (new-key@) ]
  69         if
  70     ] if ; inline recursive
  71
  72 : new-key@ ( key hash -- array n )
  73     [ array>> 2dup hash@ 0 f (new-key@) ] keep
  74     over [ pick [ hash-deleted- ] [ hash-count+ ] if ] [ drop ] if
  75     [ swap or ] [ drop ] if ; inline
  76
  77 : set-nth-pair ( value key seq n -- )
  78     2 fixnum+fast [ set-slot ] 2keep
  79     1 fixnum+fast set-slot ; inline
  80
  81 : (rehash) ( hash alist -- )
  82     swap [ swapd set-at ] curry assoc-each ; inline
  83
  84 : hash-large? ( hash -- ? )
  85     [ count>> 3 fixnum*fast 1 fixnum+fast ]
  86     [ array>> length>> ] bi fixnum> ; inline
  87
  88 : grow-hash ( hash -- )
  89     [ [ >alist ] [ assoc-size 1 + ] bi ] keep
  90     [ reset-hash ] keep
  91     swap (rehash) ;
  92
  93 : ?grow-hash ( hash -- )
  94     dup hash-large? [ grow-hash ] [ drop ] if ; inline
  95
  96 PRIVATE>
  97
  98 : <hashtable> ( n -- hash )
  99     hashtable new [ reset-hash ] keep ; inline
 100
 101 M: hashtable at* ( key hash -- value ? )
 102     key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
 103
 104 M: hashtable clear-assoc ( hash -- )
 105     [ init-hash ] [ array>> [ drop ((empty)) ] map! drop ] bi ;
 106
 107 M: hashtable delete-at ( key hash -- )
 108     [ nip ] [ key@ ] 2bi [
 109         [ ((tombstone)) dup ] 2dip set-nth-pair
 110         hash-deleted+
 111     ] [
 112         3drop
 113     ] if ;
 114
 115 M: hashtable assoc-size ( hash -- n )
 116     [ count>> ] [ deleted>> ] bi - ; inline
 117
 118 : rehash ( hash -- )
 119     dup >alist [ dup clear-assoc ] dip (rehash) ;
 120
 121 M: hashtable set-at ( value key hash -- )
 122     dup ?grow-hash dupd new-key@ set-nth-pair ;
 123
 124 : associate ( value key -- hash )
 125     2 <hashtable> [ set-at ] keep ;
 126
 127 <PRIVATE
 128
 129 : push-unsafe ( elt seq -- )
 130     [ length ] keep
 131     [ underlying>> set-array-nth ]
 132     [ [ 1 fixnum+fast { array-capacity } declare ] dip length<< ]
 133     2bi ; inline
 134
 135 PRIVATE>
 136
 137 M: hashtable >alist
 138     [ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
 139         [
 140             [
 141                 [ 1 fixnum-shift-fast ] dip
 142                 [ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi
 143             ] dip
 144             pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
 145         ] 2curry each-integer
 146     ] keep { } like ;
 147
 148 M: hashtable clone
 149     (clone) [ clone ] change-array ; inline
 150
 151 M: hashtable equal?
 152     over hashtable? [ assoc= ] [ 2drop f ] if ;
 153
 154 ! Default method
 155 M: assoc new-assoc drop <hashtable> ; inline
 156
 157 M: f new-assoc drop <hashtable> ; inline
 158
 159 : >hashtable ( assoc -- hashtable )
 160     H{ } assoc-clone-like ;
 161
 162 M: hashtable assoc-like
 163     drop dup hashtable? [ >hashtable ] unless ; inline
 164
 165 : ?set-at ( value key assoc/f -- assoc )
 166     [ [ set-at ] keep ] [ associate ] if* ;
 167
 168 ! borrowed from boost::hash_combine, but the
 169 ! magic number is 2^29/phi instead of 2^32/phi
 170 ! due to max fixnum value on 32-bit machines
 171 : hash-combine ( obj oldhash -- newhash )
 172     [ hashcode HEX: 13c6ef37 + ] dip
 173     [ 6 shift ] [ -2 shift ] bi + + ;
 174
 175 INSTANCE: hashtable assoc