keccak

\ Keccak: Forth version by Bernd Paysan
\ derived from "readable keccak"
\ 19-Nov-11  Markku-Juhani O. Saarinen <mjos@iki.fi>
\ A baseline Keccak (3rd round) implementation.

24 Value keccak-rounds
5 cells constant kcol#
25 cells constant kkey#

: carray  Create  DOES> + c@ ;
: array   Create  DOES> swap cells + @ ;

array keccakf-rndc
$0000000000000001 , $0000000000008082 ,
$800000000000808a , $8000000080008000 ,
$000000000000808b , $0000000080000001 ,
$8000000080008081 , $8000000000008009 ,
$000000000000008a , $0000000000000088 ,
$0000000080008009 , $000000008000000a ,
$000000008000808b , $800000000000008b ,
$8000000000008089 , $8000000000008003 ,
$8000000000008002 , $8000000000000080 , 
$000000000000800a , $800000008000000a ,
$8000000080008081 , $8000000000008080 ,
$0000000080000001 , $8000000080008008 ,

carray keccakf-rotc
1 c,  3 c,  6 c,  10 c, 15 c, 21 c,
28 c, 36 c, 45 c, 55 c, 2 c,  14 c, 
27 c, 41 c, 56 c, 8 c,  25 c, 43 c,
62 c, 18 c, 39 c, 61 c, 20 c, 44 c,

: cc,  cells c, ;

carray keccakf-piln
10 cc, 7 cc,  11 cc, 17 cc, 18 cc, 3 cc,
5 cc,  16 cc, 8 cc,  21 cc, 24 cc, 4 cc,
15 cc, 23 cc, 19 cc, 13 cc, 12 cc, 2 cc,
20 cc, 14 cc, 22 cc, 9 cc,  6 cc,  1 cc,

carray mod5
0 cc, 1 cc, 2 cc, 3 cc, 4 cc,
0 cc, 1 cc, 2 cc, 3 cc, 4 cc,

\ update the state with given number of rounds

kcol# buffer: bc
kkey# buffer: st

[undefined] rol [IF]
    : rol ( x1 n -- x2 )  2dup lshift >r
	64 swap - rshift r> or ;
    : rol1 ( x1 -- x2 )  dup 2* swap 0< - ;
[ELSE]
    : rol1 ( x1 -- x2 ) 1 rol ;
[THEN]
: xor! ( x addr -- )  dup >r @ xor r> ! ;

: theta1 ( -- )
    5 0 DO
	0 st i cells + kkey# bounds DO
	I @ xor  kcol# +LOOP
	bc i cells + !
    LOOP ;

: theta2 ( -- )
    5 0 DO
	bc I 4 + mod5 + @
	bc I 1 + mod5 + @ rol1 xor
	st i cells + kkey# bounds DO
	dup I xor!  kcol# +LOOP
	drop
    LOOP ;

: rhopi ( -- )
    st cell+ @
    24 0 DO
	I keccakf-piln st + dup @
	rot I keccakf-rotc rol
	rot !
    LOOP drop ;

: chi ( -- )
    st kkey# bounds DO
	I bc kcol# move
	5 0 DO
	    bc I 1+ mod5 + @ invert
	    bc I 2 + mod5 + @ and
	    J I cells + xor!
	LOOP
    kcol# +LOOP ;

: iota ( round -- )
    keccakf-rndc st xor! ;

: oneround ( round -- )
    theta1  theta2  rhopi  chi  iota ;

: keccakf ( -- )
    keccak-rounds 0 ?DO  I oneround  LOOP ;

: st0 ( -- )  st kkey# erase ;

: >sponge ( addr u -- )
    \ fill in sponge function
    st swap bounds DO
	dup @ I xor!  cell+
    cell +LOOP  drop ;

: >duplex ( addr u -- )
    \ duplex in sponge function: encrypt
    st swap bounds DO
	dup @ I @ xor dup I ! over !  cell+
    cell +LOOP drop ;

: duplex> ( addr u -- )
    \ duplex out sponge function: decrypt
    st swap bounds DO
	dup @ I @ xor over @ I ! over !  cell+
    cell +LOOP drop ;

\ for test, we pad with Keccak's padding function

144 buffer: kpad

: padded ( addr u1 u2 -- addr u )  >r
    \ pad last round
    kpad r@ erase  tuck kpad swap move
    kpad + 1 swap c!
    kpad r@ + 1- dup c@ $80 or swap c!
    kpad r> ;

: .st ( n -- )
    base @ >r hex
    st swap bounds ?DO
	I c@ 0 <# # # #> type
    LOOP r> base ! ;
: .st256 ( -- ) $20 .st ;

: hash256 ( addr u -- )
    st0  bounds ?DO
	I I' over - $88 umin
	dup $88 u< IF $88 padded  THEN  >sponge
	keccakf
    $88 +LOOP ;
: enc256 ( addr u1 key u2 -- )
    st0 >sponge keccakf
    bounds ?DO
	I I' over - $88 umin
	dup $88 u< IF
	    2dup $88 padded >duplex
	    kpad -rot move
	ELSE  >duplex  THEN
	keccakf
    $88 +LOOP ;
: dec256 ( addr u1 key u2 -- )
    st0 >sponge keccakf
    bounds ?DO
	I I' over - $88 umin
	dup $88 u< IF
	    2dup $88 padded >duplex
	    kpad -rot move
	ELSE  >duplex  THEN
	keccakf
    $88 +LOOP ;

0 [IF]    ." Test "
    \ tests - we check only for the first 64 bit
    \ but repeat keccakf 4 times. The input pattern is
    \ from an official Keccak test, the output as well.
    st0 s" SX{9" $80 padded>sponge 0 st 4 + c!
    keccakf st @ $466624B803BF072F =
    keccakf st @ $993340D7F9153F02 = and
    keccakf st @ $6EAAAE36BE8E36D3 = and
    keccakf st @ $1B4AEC08DA6A8BA6 = and
    [IF] ." succeeded" [ELSE] ." failed" [THEN] cr
[THEN]