hash-table.fs 4.34 KB
Newer Older
bernd's avatar
bernd committed
1 2
\ generic hash table functions

bernd's avatar
bernd committed
3
require string.fs
bernd's avatar
bernd committed
4
\ require wurstkessel.fs
5
require rng.fs
bernd's avatar
bernd committed
6

bernd's avatar
bernd committed
7
2 64s buffer: hashinit
bernd's avatar
bernd committed
8 9 10

\ random initializer for hash

bernd's avatar
bernd committed
11
: hash-init-rng ( -- )  rng@ rng@ hashinit 128! ;
bernd's avatar
bernd committed
12 13 14

hash-init-rng

bernd's avatar
bernd committed
15
\ this computes a cryptographic secure hash over the input string -
bernd's avatar
bernd committed
16 17
\ in three variants: a medium speed 64 bit hash, a very fast 128 bit hash,
\ and a slow cryptographically secure 512 bit hash
bernd's avatar
bernd committed
18

bernd's avatar
bernd committed
19 20 21
: use-hash-128 ;

[IFDEF] use-hash-64
bernd's avatar
bernd committed
22
    64Variable hash-state
bernd's avatar
bernd committed
23
    
24
    : string-hash ( addr u -- )  hashinit 64@ hash64 hash-state 64! ;
bernd's avatar
bernd committed
25
    
bernd's avatar
bernd committed
26
    : hash$ ( -- addr u )  hash-state [ 1 64s ]L ;
bernd's avatar
bernd committed
27 28 29 30 31
[THEN]
[IFDEF] use-hash-128
    2 64s buffer: hash-state
    
    : string-hash ( addr u -- )  hashinit hash-state [ 2 64s ]L move
bernd's avatar
bernd committed
32
	false hash-state hashkey2 ;
bernd's avatar
bernd committed
33 34 35
    
    : hash$ ( -- addr u )  hash-state [ 2 64s ]L ;
[IFDEF] use-hash-wurst
bernd's avatar
bernd committed
36 37 38 39 40 41 42 43 44 45 46 47
\ hash of the first 510 bytes of the input string, 3 times slower
    state# 8 * Constant message#

    : string-hash ( addr u -- )
	'hashinit wurst-source state# 2* move
	message message# erase
	dup message message# xc!+? drop
	rot umin dup >r move
	message r> 6 rshift $11 + rounds  message 2 rounds ;

    : hash$ ( -- addr u )  wurst-state state# ;
[THEN]
bernd's avatar
bernd committed
48 49 50 51

\ hierarchical hash table

\ hash tables store key,value-pairs.
bernd's avatar
bernd committed
52
\ Each hierarchy uses one byte of state as index (only lower 7 bits)
bernd's avatar
bernd committed
53 54
\ if there is a collission, add another indirection

bernd's avatar
bernd committed
55 56
0 value last#

bernd's avatar
bernd committed
57
: #!? ( addrval u addrkey u bucket -- true / addrval u addrkey u false )
bernd's avatar
bernd committed
58 59 60
    >r r@ @ 0= IF  r@ $! r@ cell+ $!  r> to last#
	true  EXIT  THEN
    2dup r@ $@ str=  IF  2drop r@ cell+ $! r> to last#  true  EXIT  THEN
bernd's avatar
bernd committed
61 62 63 64 65 66 67 68 69 70 71 72 73 74 75
    rdrop false ;

: #@? ( addrkey u bucket -- addrval u true / addrkey u false )
    >r r@ @ 0= IF  rdrop false  EXIT  THEN
    2dup r@ $@ str=  IF  2drop r> cell+ $@ true  EXIT  THEN
    rdrop false ;    

: #off? ( addrkey u bucket -- true / addrkey u false )
    >r r@ @ 0= IF  rdrop false  EXIT  THEN
    2dup r@ $@ str=  IF  2drop r@ $off r> cell+ $off true  EXIT  THEN
    rdrop false ;    

$180 cells Constant table-size#

: hash@ ( bucket -- addr )  >r
bernd's avatar
bernd committed
76
    r@ @ 0= IF  table-size# allocate throw dup r> ! dup table-size# erase
bernd's avatar
bernd committed
77 78 79 80 81
    ELSE  r> @  THEN ;

warnings @ warnings off \ hash-bang will be redefined

: #! ( addrval u addrkey u hash -- ) { hash }
bernd's avatar
bernd committed
82
    2dup string-hash  hash$ bounds ?DO
bernd's avatar
bernd committed
83 84
	I c@ $7F and 2* cells hash hash@ + #!? IF
	    UNLOOP  EXIT  THEN
bernd's avatar
bernd committed
85
	I c@ $80 or $80 + cells hash hash@ + to hash
bernd's avatar
bernd committed
86 87 88 89 90
    LOOP  2drop 2drop true abort" hash exhausted, please reboot universe" ;

warnings !

: #@ ( addrkey u hash -- addrval u / 0 0 ) { hash }
bernd's avatar
bernd committed
91
    2dup string-hash  hash$ bounds ?DO
bernd's avatar
bernd committed
92 93
	I c@ $7F and 2* cells hash @ dup 0= IF  2drop  LEAVE  THEN
	+ #@? IF  UNLOOP  EXIT  THEN
bernd's avatar
bernd committed
94
	I c@ $80 or $80 + cells hash @ + to hash
bernd's avatar
bernd committed
95 96 97
    LOOP  2drop 0 0 ;

: #off ( addrkey u hash -- )  { hash }
bernd's avatar
bernd committed
98
    2dup string-hash  hash$ bounds ?DO
bernd's avatar
bernd committed
99
	I c@ $7F and 2* cells hash @ dup 0= IF  2drop  LEAVE  THEN
bernd's avatar
bernd committed
100
	+ #off? IF  UNLOOP  EXIT  THEN
bernd's avatar
bernd committed
101
	I c@ $80 or $80 + cells hash @ + to hash
bernd's avatar
bernd committed
102
    LOOP  2drop ;
bernd's avatar
bernd committed
103

bernd's avatar
bernd committed
104 105 106 107 108
-1 8 rshift invert Constant msbyte#

: leftalign ( key -- key' )
    BEGIN  dup msbyte# and 0= WHILE  8 lshift  dup 0= UNTIL  THEN ;

bernd's avatar
bernd committed
109
: #key ( addrkey u hash -- path / -1 ) 0 { hash key }
bernd's avatar
bernd committed
110
    2dup string-hash  hash$ drop cell bounds ?DO
bernd's avatar
bernd committed
111
	key 8 lshift I c@ $80 or or  to key
bernd's avatar
bernd committed
112
	I c@ $7F and 2* cells hash @ dup 0= IF  2drop  LEAVE  THEN
bernd's avatar
bernd committed
113
	+ #@? IF  2drop key -$81 and leftalign   UNLOOP  EXIT  THEN
bernd's avatar
bernd committed
114
	I c@ $80 or $80 + cells hash @ + to hash
bernd's avatar
bernd committed
115 116
    LOOP  2drop -1 ;

bernd's avatar
bernd committed
117
: #.key ( path hash -- item ) @ { hash }
bernd's avatar
bernd committed
118
    BEGIN
bernd's avatar
bernd committed
119
	hash 0= IF  drop 0  EXIT  THEN
bernd's avatar
bernd committed
120
	$100 um* dup $80 and WHILE
121
	    $80 + cells hash + @ to hash
bernd's avatar
bernd committed
122
    REPEAT
bernd's avatar
bernd committed
123
    nip 2* cells hash + ;
bernd's avatar
bernd committed
124

bernd's avatar
bernd committed
125
: #map  { hash xt -- } \ xt: ( ... node -- ... )
bernd's avatar
bernd committed
126
    hash @ 0= ?EXIT
bernd's avatar
bernd committed
127 128 129 130
    hash @ $100 cells bounds DO
	I @ IF  I xt execute  THEN
    2 cells +LOOP
    hash @ $100 cells + $80 cells bounds DO
bernd's avatar
bernd committed
131
	I @ IF  I xt recurse  THEN
bernd's avatar
bernd committed
132 133 134 135 136 137 138 139
    cell +LOOP ;

: #.entry ( hash-entry -- ) dup $@ type ."  -> " cell+ $@ type cr ;

: #. ( hash -- )  ['] #.entry #map ;

\ test: move dictionary to hash

140
0 [IF]
bernd's avatar
bernd committed
141 142 143 144 145
variable ht
: test ( -- )
    context @ cell+ BEGIN  @ dup  WHILE
	    dup name>string 2dup ht #!
    REPEAT  drop ;
bernd's avatar
bernd committed
146 147 148 149 150 151 152 153
: test1 ( -- )
    context @ cell+ BEGIN  @ dup  WHILE
	    dup name>string 2dup ht #@ str= 0= IF ." unequal" cr THEN
    REPEAT  drop ;
: test2 ( -- )
    context @ cell+ BEGIN  @ dup  WHILE
	    dup name>string 2dup ht #key dup hex. cr ht #.key $@ str= 0= IF ." unequal" cr THEN
    REPEAT  drop ;
bernd's avatar
bernd committed
154
[THEN]