VolksForth/sources/cpm/hashcash.fth

86 lines
5.2 KiB
Forth
Raw Normal View History

\ *** Block No. 0 Hexblock 0
\ HashCash Suchalgorithmus UH 11Nov86
Ein Algorithmus, der die Dictionarysuche beschleunigt:
Zuerst wird uebr das gesucht Wort gehasht und in in einer
Tabelle nachgesehen. Schlaegt der Versuch fehl, wird ganz normal
gesucht. Suchzeit geht auf ca. 70-80% gegenueber normalem Suchen
herunter.
Hinzu kommen die Worte:
cash, hash-thread, erase-cash, 'cash, und found?
Im Kernal neudefiniert oder gepatched werden muessen:
(find, hide, reveal, forget-words
(find und (forget benutzen jejweils die alten Worte. Sie muessen
umbenannt oder in die neuen Worte eingebettet werden.
\ *** Block No. 1 Hexblock 1
\ Hash Cash fuer volksFORTH UH 11Nov86
Create cash $200 allot
' Forth >body Constant hash-thread
: erase-cash ( -- ) cash $200 erase ; erase-cash
1 3 +thru
patch (find
( patch forget-words ) ' forget-words \ forget-words
dup ' clear >body 6 + ! \ liegt auf einer ungluecklichen
dup ' (forget >body $12 + ! \ Adresse, sodass das automa-
dup ' empty >body 8 + ! \ tische Patchen nicht klappt.
' save >body 4+ !
patch hide patch reveal forget (patch save
\ *** Block No. 2 Hexblock 2
\ 'cash found? hfind UH 23Oct86
: 'cash ( nfa -- 'cash )
count $1F and under bounds
?DO I c@ + LOOP $FF and 2* cash + ;
: found? ( str nfa -- f )
count rot count rot over = IF swap -text 0= exit THEN
drop 2drop false ;
: (find ( str thread -- str false | nfa true )
dup hash-thread - IF (find exit THEN
drop dup 'cash @ 2dup found? IF nip true exit THEN
drop hash-thread (find dup 0= ?exit over dup 'cash ! ;
\ *** Block No. 3 Hexblock 3
\ Kernal changes UH 23Oct86
' hide >body @ | Alias last?
: hide last? IF 0 over 'cash ! 2- @ current @ ! THEN ;
: reveal last? IF dup dup 'cash ! 2- current @ ! THEN ;
' clear >body 6 + @ | Alias forget-words
| : forget-words erase-cash forget-words ;
: .cash cash $200 bounds DO I @ ?dup IF .name THEN 2 +LOOP ;
\ *** Block No. 4 Hexblock 4
\ patching UH 23Oct86
: (patch ( new old -- )
['] cash 0 DO
i @ over = IF cr I u. over I ! THEN LOOP 2drop ;
: patch \ name
>in @ ' swap >in ! dup >name 2- context push context ! '
(patch ;