78 lines
3.1 KiB
Forth
78 lines
3.1 KiB
Forth
|
\ triple words
|
||
|
|
: 3drop drop drop drop ; ( n1 n2 n3 ---)
|
||
|
|
: 3dup >r over over r@ rot rot r> ; ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3)
|
||
|
|
\ ASCIIZ string words
|
||
|
|
: zstring create chars allot ; ( a1 -- a1 n1)
|
||
|
|
: zcount dup begin dup c@ while char+ repeat over - ;
|
||
|
|
: zplace over chars over + >r swap cmove 0 r> c! ;
|
||
|
|
: +zplace zcount chars + zplace ; ( a1 n1 a2 --)
|
||
|
|
\ find character in string
|
||
|
|
: where? ( c a1 n1 -- n2)
|
||
|
|
0 ?do over over i chars + c@ = if drop i negate leave then loop nip negate ;
|
||
|
|
|
||
|
|
64 constant /str \ size of input/output string
|
||
|
|
27 constant /alpha \ size of alphabet
|
||
|
|
|
||
|
|
/str zstring {i} \ input string
|
||
|
|
/str zstring {o} \ output string
|
||
|
|
|
||
|
|
/alpha zstring l \ left alphabet
|
||
|
|
/alpha zstring r \ right alphabet
|
||
|
|
/alpha zstring t \ temporary alphabet
|
||
|
|
|
||
|
|
: [] chars + ; ( a n -- a+n)
|
||
|
|
: .tab 9 emit ; ( --)
|
||
|
|
: .list cr .tab zcount type cr ; ( a --)
|
||
|
|
|
||
|
|
: PermuteLeft ( index --)
|
||
|
|
26 over ?do t over negate i + [] l i [] c@ swap c! loop
|
||
|
|
dup 0 ?do t over negate 26 i + + [] l i [] c@ swap c! loop drop
|
||
|
|
t char+ c@ >r t 2 [] dup char- 12 cmove r> t 13 [] c! t zcount l zplace
|
||
|
|
;
|
||
|
|
|
||
|
|
: PermuteRight ( index --)
|
||
|
|
26 over ?do t over negate i + [] r i [] c@ swap c! loop
|
||
|
|
dup 0 ?do t over negate 26 i + + [] r i [] c@ swap c! loop drop
|
||
|
|
t c@ >r t char+ dup char- 25 cmove r> t 25 [] c!
|
||
|
|
t 2 [] c@ >r t 3 [] dup char- 11 cmove r> t 13 [] c! t zcount r zplace
|
||
|
|
;
|
||
|
|
|
||
|
|
: Encrypt ( input output index1 -- index2)
|
||
|
|
>r swap r@ [] c@ r /alpha where? dup 0< abort" Corrupt right alphabet"
|
||
|
|
l over [] c@ rot r> [] c!
|
||
|
|
;
|
||
|
|
|
||
|
|
: Decrypt ( input output index1 -- index2)
|
||
|
|
>r swap r@ [] c@ l /alpha where? dup 0< abort" Corrupt left alphabet"
|
||
|
|
r over [] c@ rot r> [] c!
|
||
|
|
;
|
||
|
|
|
||
|
|
: chao ( i o xt f --)
|
||
|
|
s" HXUCZVAMDSLKPEFJRIGTWOBNYQ" l zplace
|
||
|
|
s" PTLNBQDEOYSFAVZKGJRIHWXUMC" r zplace
|
||
|
|
t /alpha erase >r \ erase temporary string
|
||
|
|
( i o xt R: f)
|
||
|
|
r@ if cr ." The left and right alphabets after each permutation:" cr then
|
||
|
|
>r over r> swap zcount 1- nip >r ( i o xt R: f len)
|
||
|
|
|
||
|
|
0 begin ( i o xt 0 R: f len)
|
||
|
|
r> r@ if l zcount type 2 spaces r zcount type cr then >r
|
||
|
|
>r 3dup r@ swap execute r> dup r@ <
|
||
|
|
while ( i o xt 0 R: f len)
|
||
|
|
>r dup PermuteLeft PermuteRight r> 1+
|
||
|
|
repeat rdrop rdrop drop drop 3drop
|
||
|
|
;
|
||
|
|
|
||
|
|
: main
|
||
|
|
s" WELLDONEISBETTERTHANWELLSAID" {i} zplace
|
||
|
|
{o} /str erase \ initialize output string
|
||
|
|
|
||
|
|
." The original plaintext is :" {i} .list
|
||
|
|
{i} {o} ['] Encrypt true chao
|
||
|
|
cr ." The ciphertext is :" {o} .list
|
||
|
|
{o} {i} ['] Decrypt false chao
|
||
|
|
cr ." The recovered plaintext is :" {i} .list
|
||
|
|
;
|
||
|
|
|
||
|
|
main
|