@prog idea.muf
1 9999 d
1 i
(
All data strings below are strings of numbers 0-65535, with exactly one
space separating numbers, with no leading or trailing spaces.
Key schedule strings should be considered opaque; if you mess with them,
various code is likely to crash in cryptic and random ways.

Call idea-makekey-e or idea-makekey-d with a key string, and it returns a
key schedule string set up for encryption or decryption, respectively.  The
key string must be a data string with eight numbers.

Call idea-keycvt-e->d or idea-keycvt-e->d to convert key schedule strings
between encrypt and decrypt setups.

Call idea-crypt or idea-crypt-n to do the actual encryption or decryption.

idea-crypt:  data key-schedule -- data
  where data must be a data string of four numbers.  This is ECB mode; if
  you want other modes [eg, CBC] you have to build them yourself on top
  of idea-crypt.

idea-crypt-n:  data1 data2 data3 data4 key-schedule -- data1 data2 data3 data4
  where data1...data4 are the data, already in numeric form.  Except for
  the packing and unpacking of the data strings, this is identical to
  idea-crypt.  Note that the string form of the four data values 1 2 3 4
  is "4 3 2 1".
)

(
Warning: this is serious cryptography.  This has some implications.  In
particular, it means that exporting this code from the USA and probably
other countries [eg, Australia] is illegal.  In some countries using it
even domestically is illegal; there are probably countries in which mere
possession of it is illegal.  I take no responsibility for any trouble
you may get into on any such score - or any other, for that matter, but
with strong crypto a warning is probably in order.
)

(For fuzzball compatability, uncomment the following stuff...)
(
$def -rot rot rot
$def /% over over / -rot %
$def neg -1 *
$def << bitshift 
$def >> neg bitshift 
$def & bitand 
$def | bitor 
$def ^ bitxor 
$def != = not 
$def loop repeat
: roll over swap - over % dup 0 < if over + then begin dup 0 > while
	over 2 + rotate rot rot 1 - loop pop pop ;
)

: mpop (x1 ... xN N -- ) begin dup 0 > while 1 - swap pop loop pop ;

(Compute m such that n*m=1 mod 0x10001.  Algorithm is a variant of Euclid's
gcd algorithm:

Compute a sequence of Ai, Xi, Bi, Yi as follows.  [Let K = 0x10001.]
  Initial state:
    A0 = 1, X0 = K, B0 = 0, Y0 = n
  Important loop invariants:
    Ai Xi + Bi Yi = K
    K | [Y0 Bi + Xi]
    K | [Y0 Ai - Yi]
    Xi != Yi
    GCD[Xi,Yi] = 1
    Xi != 0
    Yi != 0
  Computation [j = i+1]:
    if Xi=1, stop; return -Bi [mod K]
    if Yi=1, stop; return Ai [mod K]
    if Xi > Yi:
      Xi / Yi = Qi remainder Ri [that is, Xi = Yi Qi + Ri, 0 <= Ri < Yi]
      Aj = Ai, Xj = Ri, Bj = Bi + Qi Ai, Yj = Yi
    else [Xi < Yi]
      Yi / Xi = Qi remainder Ri [that is, Yi = Xi Qi + Ri, 0 <= Ri < Xi]
      Aj = Ai + Qi Bi, Xj = Xi, Bj = Bi, Yj = Ri

Noting that the computation will always take alternate branches of the
Xi<Yi condition each time through, we unroll the loop and don't bother
doing the test [since we know Y0<X0].  We also do the first iteration
of the loop "by hand", as part of the initial setup.  [Arguments
0=0x10000 and 1 are special-cased.]  Note also that A and B are always
< K [because of the first loop invariant, and X and Y are always at least
1], so the reduction mod K in the final return is trivial.  Also, R gets
trivially optimized away.
)
: multinv (n -- m)
	dup 2 < if exit then
	65537 over /% 1 -rot 4 rotate
	begin
		(a b x y)
		over 1 = if pop pop swap pop 65537 swap - exit then
		over /% swap 4 pick * 5 rotate +
		(b x y a)
		over 1 = if -4 rotate pop pop pop exit then
		rot 3 pick /% -rot over * 5 rotate +
		rot 4 rotate
	loop
;
: addinv (n -- m) 65536 swap - 65535 & ;
(the mess is because we don't have a 32-bit unsigned % operator)
: mult (a b -- prod)
	dup if
		over if
			( [u* 65537 u%] is what we want...sigh )
			256 /% -rot over * 16 * 65537 % 16 *
			-rot * + 65537 % 65535 & exit
		else
			swap pop
		then
	else
		pop
	then
	65537 swap - 65535 &
;
: add (a b -- sum) + 65535 & ;
: err 0 0 / ; (force a divide-by-zero error)
: idea-makekey-e (key -- key-schedule)
	" " explode dup 8 != if
		mpop "idea-makekey-e: other than 8 numbers in key string" err
	then
	begin dup 0 > while
		dup 1 + rotate atoi over 1 + neg rotate
		1 -
	loop
	pop
	(kb[0]-high kb[0]-low ... kb[3]-high kb[3]-low)
	6 begin dup 0 > while
		9 pick 9 pick 9 pick 9 pick 9 pick 9 pick 9 pick 9 pick
		8 rotate dup 8 begin dup 0 > while
			swap 9 << 10 pick 7 >> | 65535 &
			10 rotate rot 1 -
		loop pop pop 8 rotate
		9 rotate 1 -
	loop pop
	pop pop pop pop
	intostr 51 begin dup 0 > while
		swap rot " " swap intostr strcat strcat swap 1 -
	loop pop
;
: kcadd intostr over if " " strcat then swap strcat ;
: idea-keycvt-e->d
	" " explode pop swap -rot ""
	8 begin dup 0 > while
		1 - -8 rotate
		5 rotate atoi multinv kcadd
		rot atoi addinv kcadd
		rot atoi addinv kcadd
		swap atoi multinv kcadd
		rot atoi kcadd
		swap atoi kcadd
		swap
	loop pop
	5 rotate atoi multinv kcadd
	4 rotate atoi addinv kcadd
	rot atoi addinv kcadd
	swap atoi multinv kcadd
;
: idea-makekey-d
	idea-makekey-e
	idea-keycvt-e->d
;
: idea-keycvt-d->e idea-keycvt-e->d ;
: idea-crypt-n
	" " explode pop
	52 begin dup 0 > while 53 rotate atoi swap 1 - loop pop
	56 rotate 56 rotate 56 rotate 56 rotate
	0
	(s0 ... s51 x1 x2 x3 x4 zpx)
	8 begin dup 0 > while
		(s0 ... s51 x1 x2 x3 x4 -zpx N)
		over 58 + pick 7 rotate mult
		3 pick 57 + pick 7 rotate add
		4 pick 56 + pick 7 rotate add
		5 pick 55 + pick 7 rotate mult
		over 5 pick ^
		over 5 pick ^
		8 pick 56 + pick rot mult
		swap over add
		8 pick 55 + pick mult
		swap over add
		over 7 rotate ^
		rot 5 rotate ^
		5 rotate 4 pick ^
		5 rotate 5 rotate ^
		6 rotate 6 -
		6 rotate 1 -
	loop pop pop
	(s0 ... s48 s49 s50 s51 x1 x2 x3 x4)
	8 rotate 5 rotate mult
	7 rotate 4 rotate add
	6 rotate 5 rotate add
	5 rotate 5 rotate mult
	-52 rotate -52 rotate -52 rotate -52 rotate
	48 mpop
;
: idea-crypt (data key-schedule -- data)
	swap
	" " explode dup 4 != if
		mpop pop "idea-crypt: other than 4 numbers in data" err
	then
	pop
	atoi 4 rotate atoi 4 rotate atoi 4 rotate atoi 4 rotate
	5 rotate
	idea-crypt-n
	intostr
	" " strcat swap intostr strcat
	" " strcat swap intostr strcat
	" " strcat swap intostr strcat
;

( Test driver: )

: say me @ swap notify ;
: usage
	"Usage:" say
	"        i<key>e<data> (basic IDEA encrypt)" say
	"        i<key>d<data> (basic IDEA decrypt)" say
	"        e<key>/<numbers> (Myst save encrypt)" say
	"        d<key>/<text> (Myst save decrypt)" say
;
( : xps pop pop ; )
( : xps pstack ; )
: xps me @ "_idea-pstack" prop-exists? if pstack else pop pop then ;
: clrdebug prog "!d" set ;
: setdebug prog "d" set ;
: key prog "_key" getpropstr ;
: do-encrypt (data-string key-string -- )
	idea-makekey-e idea-crypt say
;
: do-decrypt (data-string key-string -- )
	idea-makekey-d idea-crypt say
;
: do-idea-test
	pop
	"e" explode dup 1 = if
		pop "d" explode dup 1 = if pop pop usage exit then
		dup 2 != if mpop usage exit then
		pop do-decrypt exit
	then
	dup 2 != if mpop usage exit then
	pop do-encrypt
;
(note we can never form "offensive" words 'cause all vowels have been removed)
: base64-string
	"bcdfghjklmnpqrstvwxz.BCDFGHJKLMNPQRSTVWXZ/0123456789,:-=+_!$%<>?"
;
: to-base64 (n n n -- s)
	( abcdefghABCDEFGH ijklmnopIJKLMNOP qrstuvwxQRSTUVWX )
	dup 63 & swap 6 >>
	dup 63 & swap 6 >>
	16 << 4 rotate |
	dup 63 & swap 6 >>
	dup 63 & swap 6 >>
	dup 63 & swap 6 >>
	16 << 7 rotate |
	dup 63 & swap 6 >>
	dup 63 & swap 6 >>
	( STUVWX uvwxQR KLMNOP mnopIJ stijkl CDEFGH efghAB qrabcd )
	base64-string
	dup rot strcut 1 strcut pop swap pop
	7 begin dup 0 > while
		3 pick 5 rotate strcut 1 strcut pop swap pop rot strcat
		swap 1 -
	loop pop
	swap pop
	( <STUVWX><uvwxQR><KLMNOP><mnopIJ><stijkl><CDEFGH><efghAB><qrabcd> )
;
: from-base64 (s -- n n n)
	( <STUVWX><uvwxQR><KLMNOP><mnopIJ><stijkl><CDEFGH><efghAB><qrabcd> )
	base64-string 8 begin dup 0 > while
		( ... cs bs N )
		rot 1 strcut 4 pick rot instr dup if 1 - then -4 rotate -rot 1 -
	loop pop pop pop
	6 << | 6 << |
	dup 65535 & -7 rotate 16 >>
	6 << | 6 << | 6 << |
	dup 65535 & -4 rotate 16 >>
	6 << | 6 << |
	( abcdefghABCDEFGH ijklmnopIJKLMNOP qrstuvwxQRSTUVWX )
;
: do-myst-encode ( key-schedule d1 ... dN N -- encoded-string )
dup 2 + "(enc entry)" xps
	random 65535 & swap 1 +
	0 over begin dup 0 > while
		( di+1 ... dN random d1 ... di N+1 sum i )
		3 pick 3 + rotate rot over + swap -4 rotate swap
		1 -
	loop pop
	65535 & swap 1 -
	( ks d1 ... dN random cksum N )
dup 3 + "(ks) d1 ... dN random cksum N" xps
	rot over 3 + begin dup 4 % while 0 -4 rotate 1 + loop
	( ks d1 ... dN cksum z1 ... zX N random N+X+3  [X [0..3], 4|[N+X+3]] )
dup 1 + "(ks) d1 ... dN cksum z1 ... zX N random N+X+3" xps
	( ks x1 ... xM M  [4|M] )
	dup -6 rotate 2 + pick idea-crypt-n 5 rotate dup 4 / 1 -
	( ks x1 ... xM-3' xM-2' xM-1' xM' M loopcnt )
	begin dup 0 > while
over 2 + "(ks) x ... x M loopcnt" xps
		( ks x1 ... xM-7 ... xM-4 xM-3' ... xM' M lc )
		10 2 roll 4 pick 4 pick 4 pick 4 pick
		( ks x1 ... M lc xM-7 ... xM-4 xM-3' ... xM' xM-3' ... xM' )
		14 pick 6 + 4 roll
		( ks xM-3' ... xM' x1 ... M lc xM-7 ... xM-4 xM-3' ... xM' )
		4 rotate 8 rotate ^
		4 rotate 7 rotate ^
		4 rotate 6 rotate ^
		4 rotate 5 rotate ^
		( ks xM-3' ... xM' x1 ... xM-8 M lc xM-7x ... xM-4x )
		6 pick 3 + pick idea-crypt-n 6 -2 roll
		( ks xM-3' ... xM' x1 ... xM-8 xM-7' ... xM-4' M lc )
		1 -
	loop pop
dup 1 + "(ks) x ... x M" xps
	0 swap begin random 65535 & -rot 1 + swap 1 + swap dup 3 % while loop
	( ks x1'' ... xM'' r1 ... rY Y M+Y  [ Y [1..3], 3|[M+Y] ] )
dup 2 + "(ks) x1'' ... xM'' r1 ... rY Y M+Y" xps
	rot 3 / 3 * rot 3 % + swap
	dup -6 rotate 2 + pick idea-crypt-n 5 rotate
	( ks y1 ... yC C  [3|C, C>4] )
dup 1 + "(ks) y1 ... yC C" xps
	"" swap begin dup 0 > while
		( ks y1 ... yC-2 yC-1 yC s C )
		-5 rotate -4 rotate to-base64 strcat swap 3 -
	loop pop swap pop
1 "(enc returning)" xps
	( string )
;
: do-myst-decode
	( key-schedule encoded-string -- d1 ... dN N 1, if successful)
	( key-schedule encoded-string -- why-error-string 0, if unsuccessful)
	( key-schedule string )
2 "(dec entry)" xps
	dup strlen dup 8 % if pop pop pop "Invalid length (a)" 0 exit then
	( ks string len )
	dup 16 < if pop pop pop "Invalid length (b)" 0 exit then
	dup 8 / 3 * -rot
	( ks C string len )
3 "(ks) C str len" xps
	begin dup 0 > while
		8 - swap over strcut from-base64 6 3 roll swap
	loop pop pop
	( ks y1 ... yC C )
dup 1 + "(ks) y1 ... yC C" xps
	dup -6 rotate 2 + pick idea-crypt-n 5 rotate
	over 3 % dup not if pop 3 then
	swap over - swap begin dup 0 > while rot pop 1 - loop pop
	( ks x1'' ... xM'' M )
dup 1 + "(ks) x1'' ... xM'' M" xps
	dup 4 % if mpop pop "Corrupt count (a)" 0 exit then
	( ks x5' ... xM' x1' ... x4' M )
	dup 4 / 1 -
	( ks x5' ... xM' x1' ... x4' M loopcnt )
	begin dup 0 > while
over 2 + "(ks) x ... x M loopcnt" xps
		( ks xM-3' ... xM' x1 ... xM-8 xM-7' ... xM-4' M lc )
		6 2 roll 6 pick 3 + pick idea-crypt-n
		( ks xM-3' ... xM' x1 ... xM-8 M lc xM-7 ... xM-4 )
		6 pick 2 + -4 roll
		8 rotate 5 pick ^
		8 rotate 5 pick ^
		8 rotate 5 pick ^
		8 rotate 5 pick ^
		( ks x1 ... xM-8 M lc xM-3' ... xM' xM-7 ... xM-4 )
		8 4 roll 10 -2 roll
		( ks x1 ... xM-8 xM-7 ... xM-4 xM-3' ... xM' M lc )
		1 -
	loop pop
	( ks x1 ... xM-4 xM-3' ... xM' M )
dup 1 + "(ks) x1 ... xM-4 xM-3' ... xM' M" xps
	dup -6 rotate 2 + pick idea-crypt-n 5 rotate
	( ks x1 ... xM M )
	( ks d1 ... dN cksum z1 ... zX N random N+X+3 )
dup 1 + "(ks) d1 ... dN cksum z1 ... zX N random N+X+3" xps
	dup 4 pick - 3 - dup 0 < over 3 > or if
		pop mpop pop "Corrupt count (b)" 0 exit
	then
	swap pop 0 swap begin dup 0 > while
		( ks d1 ... dN cksum z1 ... zX N random or X )
		swap 5 rotate or swap 1 -
	loop pop
	( ks d1 ... dN cksum N random or )
3 pick 4 + "(ks) d1 ... dN cksum N random or" xps
	if pop 2 + mpop "Zeroes aren't" 0 exit then
	( ks d1 ... dN cksum N random )
	over begin dup 0 > while
		( ks d1 ... dN cksum N sum i )
		dup 4 + pick rot + swap 1 -
	loop pop
	( ks d1 ... dN cksum N sum )
over 3 + "(ks) d1 ... dN cksum N sum" xps
	65535 & rot != if mpop pop "Checksum wrong" 0 exit then
	( d1 ... dN N )
	1
over 2 + "(dec returning)" xps
;
: do-myst-encode-str
	pop
	"/" explode dup 2 != if mpop usage exit then
	pop idea-makekey-e swap
	( key-schedule datastring )
	" " explode
	( key-schedule s1 ... sN N )
	dup begin dup 0 > while over 2 + rotate atoi -rot 1 - loop pop
	( key-schedule d1 ... dN N )
	do-myst-encode
	say
;
: do-myst-decode-str
	pop
	dup "/" instr dup not if pop pop usage exit then
	1 - strcut 1 strcut swap pop
	swap idea-makekey-d swap
	do-myst-decode
	if
		( n1 ... nN N )
		1 - swap intostr swap
		( n1 ... nN-1 N-1 s )
		begin dup 0 > while
			( ... n s N )
			swap " " strcat rot intostr strcat swap
			1 -
		loop pop
	else
		"Error: " swap strcat
	then
	say
;
: test-main
	1 strcut swap
	dup "i" stringcmp not if do-idea-test exit then
	dup "e" stringcmp not if do-myst-encode-str exit then
	dup "d" stringcmp not if do-myst-decode-str exit then
	usage
;
.
c
q