version 1.1, 1994/07/21 10:52:43
|
version 1.4, 1994/10/18 15:51:18
|
Line 1
|
Line 1
|
\ Hashed dictionaries 15jul94py |
\ Hashed dictionaries 15jul94py |
|
|
$80 Value Hashlen |
9 value hashbits |
|
1 hashbits lshift Value Hashlen |
|
|
Variable insRule insRule on |
Variable insRule insRule on |
|
Variable revealed |
|
|
\ Memory handling 15jul94py |
\ Memory handling 10oct94py |
|
|
Variable HashPointer |
Variable HashPointer |
|
Variable HashTable |
|
Variable HashIndex |
|
|
: hash-alloc ( addr -- addr ) dup @ 0= IF |
\ DelFix and NewFix are from bigFORTH 15jul94py |
Hashlen cells allocate throw over ! |
|
dup @ Hashlen cells erase THEN ; |
|
|
|
\ DelFix and NewFix is from bigFORTH 15jul94py |
|
|
|
: DelFix ( addr root -- ) dup @ 2 pick ! ! ; |
: DelFix ( addr root -- ) dup @ 2 pick ! ! ; |
: NewFix ( root len # -- addr ) |
: NewFix ( root len # -- addr ) |
Line 22 Variable HashPointer
|
Line 22 Variable HashPointer
|
|
|
\ compute hash key 15jul94py |
\ compute hash key 15jul94py |
|
|
: hash ( addr len -- key ) (hashkey) |
: hash ( addr len -- key ) |
\ tuck bounds ?DO I c@ toupper + LOOP |
hashbits (hashkey1) ; |
Hashlen 1- and ; |
\ (hashkey) |
|
\ Hashlen 1- and ; |
: hash-find ( addr len wordlist -- nfa / false ) $C + @ >r |
|
2dup hash cells r> + @ (hashfind) ; |
|
\ BEGIN dup WHILE |
: hash-find ( addr len wordlist -- nfa / false ) |
\ 2@ >r >r dup r@ cell+ c@ $1F and = |
$C + @ >r |
\ IF 2dup r@ cell+ char+ capscomp 0= |
2dup hash r> xor cells HashTable @ + @ (hashfind) ; |
\ IF 2drop r> rdrop EXIT THEN THEN |
|
\ rdrop r> |
|
\ REPEAT nip nip ; |
|
|
|
\ hash vocabularies 16jul94py |
\ hash vocabularies 16jul94py |
|
|
Line 41 Variable HashPointer
|
Line 38 Variable HashPointer
|
BEGIN dup @ dup WHILE nip REPEAT drop ! ; |
BEGIN dup @ dup WHILE nip REPEAT drop ! ; |
|
|
: (reveal ( addr voc -- ) $C + dup @ 0< IF 2drop EXIT THEN |
: (reveal ( addr voc -- ) $C + dup @ 0< IF 2drop EXIT THEN |
hash-alloc @ over cell+ count $1F and Hash cells + >r |
@ over cell+ count $1F and Hash xor cells >r |
HashPointer 8 $400 NewFix |
HashPointer 8 $400 NewFix |
tuck cell+ ! r> insRule @ |
tuck cell+ ! r> HashTable @ + insRule @ |
IF dup @ 2 pick ! ! ELSE lastlink! THEN ; |
IF dup @ 2 pick ! ! ELSE lastlink! THEN revealed on ; |
|
|
: hash-reveal ( -- ) (reveal) last? IF |
: hash-reveal ( -- ) (reveal) last? IF |
current @ (reveal THEN ; |
current @ (reveal THEN ; |
|
|
Create hashsearch ' hash-find A, ' hash-reveal A, ' drop A, |
: addall ( -- ) |
|
voclink |
|
BEGIN @ dup @ WHILE dup 'initvoc REPEAT drop ; |
|
|
|
: clearhash ( -- ) |
|
HashTable @ Hashlen cells bounds |
|
DO I @ |
|
BEGIN dup WHILE |
|
dup @ swap HashPointer DelFix |
|
REPEAT I ! |
|
cell +LOOP HashIndex off ; |
|
|
|
: rehash clearhash addall ; |
|
: (rehash) ( addr -- ) |
|
drop revealed @ IF rehash revealed off THEN ; |
|
|
|
Create hashsearch ' hash-find A, ' hash-reveal A, ' (rehash) A, |
|
|
|
\ hash allocate and vocabulary initialization 10oct94py |
|
|
|
: hash-alloc ( addr -- addr ) HashTable @ 0= IF |
|
Hashlen cells allocate throw HashTable ! |
|
HashTable @ Hashlen cells erase THEN |
|
HashIndex @ over ! 1 HashIndex +! |
|
HashIndex @ Hashlen >= |
|
IF clearhash |
|
1 hashbits 1+ dup to hashbits lshift to hashlen |
|
HashTable @ free |
|
addall |
|
THEN ; |
|
|
|
: (initvoc) ( addr -- ) |
|
cell+ dup @ 0< IF drop EXIT THEN |
|
insRule @ >r insRule off hash-alloc |
|
3 cells - hashsearch over cell+ ! dup |
|
BEGIN @ dup WHILE 2dup swap (reveal REPEAT |
|
2drop r> insRule ! ; |
|
|
: (initvoc ( addr -- ) cell+ dup @ 0< IF drop EXIT THEN |
' (initvoc) IS 'initvoc |
insRule @ >r insRule off hash-alloc |
|
3 cells - hashsearch over cell+ ! dup |
|
BEGIN @ dup WHILE 2dup swap (reveal REPEAT |
|
2drop r> insRule ! ; |
|
|
|
' (initvoc IS 'initvoc |
|
|
|
: addall ( -- ) voclink |
|
BEGIN @ dup @ WHILE dup (initvoc REPEAT drop ; |
|
|
|
\ Hash-Find 01jan93py |
\ Hash-Find 01jan93py |
|
|
Line 68 addall \ Baum aufbauen
|
Line 92 addall \ Baum aufbauen
|
\ Baumsuche ist installiert. |
\ Baumsuche ist installiert. |
|
|
: .words ( -- ) |
: .words ( -- ) |
base @ >r hex context @ 3 cells + HashLen 0 |
base @ >r hex HashTable @ Hashlen 0 |
DO cr i 2 .r ." : " dup @ i cells + |
DO cr i 2 .r ." : " dup i cells + |
BEGIN @ dup WHILE |
BEGIN @ dup WHILE |
dup cell+ @ .name REPEAT drop |
dup cell+ @ .name REPEAT drop |
LOOP drop r> base ! ; |
LOOP drop r> base ! ; |
|
|
|
\ \ this stuff is for evaluating the hash function |
|
\ : square dup * ; |
|
|
|
\ : countwl ( -- sum sumsq ) |
|
\ \ gives the number of words in the current wordlist |
|
\ \ and the sum of squares for the sublist lengths |
|
\ 0 0 |
|
\ hashtable @ Hashlen cells bounds DO |
|
\ 0 i BEGIN |
|
\ @ dup WHILE |
|
\ swap 1+ swap |
|
\ REPEAT |
|
\ drop |
|
\ swap over square + |
|
\ >r + r> |
|
\ 1 cells |
|
\ +LOOP ; |
|
|
|
\ : chisq ( -- n ) |
|
\ \ n should have about the same size as Hashlen |
|
\ countwl Hashlen 2 pick */ swap - ; |