A2OS/source/CryptoKeccakF1600.Mod

MODULE CryptoKeccakF1600; (** AUTHOR "GF"; PURPOSE "KeccakF-1600 sponge function"; *)
(*
	The Keccak sponge function, designed by Guido Bertoni, Joan Daemen,
	Michaël Peeters and Gilles Van Assche. For more information, feedback or
	questions, please refer to our website: http://keccak.noekeon.org/
*)

IMPORT S := SYSTEM;

CONST
	Width* = 1600;			(* state size in bits *)
	LaneSize* = 8;			(* lane size in bytes *)

CONST
	nrRounds = 24;  nrLanes = 25;

TYPE
	Lane = RECORD  low, high: SET32  END;
	State = ARRAY nrLanes OF Lane;

VAR
	roundConstants: ARRAY nrRounds OF Lane;
	rhoOffsets: ARRAY nrLanes OF LONGINT;

TYPE
	Instance* = OBJECT
	VAR
		state: State;


		PROCEDURE & Init*;
		BEGIN
			Initialize
		END Init;

		PROCEDURE Initialize*;
		VAR i: LONGINT;
		BEGIN
			FOR i := 0 TO nrLanes-1 DO  state[i].low := {};  state[i].high := {}  END
		END Initialize;


		PROCEDURE XORBytesInLane*( laneNo, laneOffset, length: LONGINT;  CONST data: ARRAY OF CHAR; dataOffset: LONGINT );
		VAR
			lane: Lane;
		BEGIN
			ASSERT( (laneNo < nrLanes) & (laneOffset < LaneSize) & (laneOffset+length <= LaneSize) );
			lane.low := {};  lane.high := {};
			S.MOVE( ADDRESSOF( data[dataOffset] ), ADDRESSOF( lane ) + laneOffset, length );

			ToBitInterleaving( lane, lane );

			state[laneNo].low := state[laneNo].low / lane.low;
			state[laneNo].high := state[laneNo].high / lane.high;
		END XORBytesInLane;


		PROCEDURE XORLanes*( CONST data: ARRAY OF CHAR; offset, laneCount: LONGINT );
		VAR
			lane: Lane;  laneNo: LONGINT;
		BEGIN
			ASSERT( laneCount <= nrLanes );
			FOR laneNo := 0 TO laneCount - 1 DO
				S.MOVE( ADDRESSOF( data[offset + laneNo*LaneSize] ), ADDRESSOF( lane ), LaneSize );

				ToBitInterleaving( lane, lane );

				state[laneNo].low := state[laneNo].low / lane.low;
				state[laneNo].high := state[laneNo].high / lane.high;
			END
		END XORLanes;


		PROCEDURE ComplementBit*( position: LONGINT );
		VAR
			laneNo, bit: LONGINT;
		BEGIN
			ASSERT( position < 1600 );
			laneNo := position DIV 64;  bit := position MOD 64;
			IF bit < 32 THEN
				state[laneNo].low := SET32( state[laneNo].low / {bit} )
			ELSE
				state[laneNo].high := SET32( state[laneNo].high / {bit - 32} );
			END
		END ComplementBit;


		PROCEDURE ExtractBytesInLane*( laneNo, laneOffset, length: LONGINT;  VAR data: ARRAY OF CHAR; dataOffset: LONGINT );
		VAR
			lane: Lane;
		BEGIN
			ASSERT( (laneNo < nrLanes) & (laneOffset < LaneSize) & (laneOffset+length <= LaneSize) );
			FromBitInterleaving( state[laneNo], lane );
			S.MOVE( ADDRESSOF( lane ) + laneOffset, ADDRESSOF( data[dataOffset] ), length )
		END ExtractBytesInLane;


		PROCEDURE ExtractLanes*( VAR data: ARRAY OF CHAR; offset, laneCount: LONGINT );
		VAR
			lane: Lane;  laneNo: LONGINT;
		BEGIN
			ASSERT( laneCount <= nrLanes );
			FOR laneNo := 0 TO laneCount - 1 DO
				FromBitInterleaving(state[laneNo], lane );
				S.MOVE( ADDRESSOF( lane ), ADDRESSOF( data[offset + laneNo*LaneSize] ), LaneSize )
			END
		END ExtractLanes;

		PROCEDURE XORPermute*(	CONST inData: ARRAY OF CHAR; offset, count: LONGINT );
		BEGIN
			XORLanes( inData, offset, count );
			Permute;
		END XORPermute;


		PROCEDURE XORPermuteExtract*(	CONST inData: ARRAY OF CHAR; inOffset, inLaneCount: LONGINT;
												VAR outData: ARRAY OF CHAR; outOffset, outLaneCount: LONGINT );
		BEGIN
			XORLanes( inData, inOffset, inLaneCount );
			Permute;
			ExtractLanes( outData, outOffset, outLaneCount )
		END XORPermuteExtract;


		PROCEDURE Permute*;
		VAR r: LONGINT;
		BEGIN
			FOR r := 0 TO nrRounds-1 DO  Round( state, r ) END
		END Permute;


	END Instance;





	(* Credit to Henry S. Warren, Hacker's Delight, Addison-Wesley, 2002	*)
	PROCEDURE ToBitInterleaving( CONST in: Lane; VAR out: Lane );
	VAR temp, temp0, temp1: SET32;
	BEGIN
	        temp0 := in.low;
	        temp1 := in.high;
	        temp := (temp0 / LSH( temp0, -1 )) * S.VAL( SET32, 022222222H );  temp0 := temp0 / temp / LSH( temp, 1 );
	        temp := (temp0 / LSH( temp0, -2 )) * S.VAL( SET32, 00C0C0C0CH );  temp0 := temp0 / temp / LSH( temp, 2 );
	        temp := (temp0 / LSH( temp0, -4 )) * S.VAL( SET32, 000F000F0H );  temp0 := temp0 / temp / LSH( temp, 4 );
	        temp := (temp0 / LSH( temp0, -8 )) * S.VAL( SET32, 00000FF00H );  temp0 := temp0 / temp / LSH( temp, 8 );

	        temp := (temp1 / LSH( temp1, -1 )) * S.VAL( SET32, 022222222H );  temp1 := temp1 / temp / LSH( temp, 1 );
	        temp := (temp1 / LSH( temp1, -2 )) * S.VAL( SET32, 00C0C0C0CH );  temp1 := temp1 / temp / LSH( temp, 2 );
	        temp := (temp1 / LSH( temp1, -4 )) * S.VAL( SET32, 000F000F0H );  temp1 := temp1 / temp / LSH( temp, 4 );
	        temp := (temp1 / LSH( temp1, -8 )) * S.VAL( SET32, 00000FF00H );  temp1 := temp1 / temp / LSH( temp, 8 );
	        out.low := (temp0 * S.VAL( SET32, 00000FFFFH )) + LSH( temp1, 16 );
	        out.high := LSH( temp0, - 16) + (temp1 * S.VAL( SET32, 0FFFF0000H ));
	END ToBitInterleaving;

	(* Credit to Henry S. Warren, Hacker's Delight, Addison-Wesley, 2002 *)
	PROCEDURE FromBitInterleaving( CONST in: Lane;  VAR out: Lane );
	VAR temp, temp0, temp1: SET32;
	BEGIN
	        temp0 := in.low;
	        temp1 := in.high;
	        temp := (temp0 * S.VAL( SET32, 00000FFFFH )) + LSH( temp1, 16 );
	        temp1 := LSH( temp0, - 16) + (temp1 * S.VAL( SET32, 0FFFF0000H ));
	        temp0 := temp;
	        temp := (temp0 / LSH( temp0, -8 )) * S.VAL( SET32, 00000FF00H );  temp0 := temp0 / temp / LSH( temp, 8 );
	        temp := (temp0 / LSH( temp0, -4 )) * S.VAL( SET32, 000F000F0H );  temp0 := temp0 / temp / LSH( temp, 4 );
	        temp := (temp0 / LSH( temp0, -2 )) * S.VAL( SET32, 00C0C0C0CH );  temp0 := temp0 / temp / LSH( temp, 2 );
	        temp := (temp0 / LSH( temp0, -1 )) * S.VAL( SET32, 022222222H );  temp0 := temp0 / temp / LSH( temp, 1 );

	        temp := (temp1 / LSH( temp1, -8 )) * S.VAL( SET32, 00000FF00H );  temp1 := temp1 / temp / LSH( temp, 8 );
	        temp := (temp1 / LSH( temp1, -4 )) * S.VAL( SET32, 000F000F0H );  temp1 := temp1 / temp / LSH( temp, 4 );
	        temp := (temp1 / LSH( temp1, -2 )) * S.VAL( SET32, 00C0C0C0CH );  temp1 := temp1 / temp / LSH( temp, 2 );
	        temp := (temp1 / LSH( temp1, -1 )) * S.VAL( SET32, 022222222H );  temp1 := temp1 / temp / LSH( temp, 1 );
	        out.low := temp0;
	        out.high := temp1;
	END FromBitInterleaving;



	PROCEDURE ROL64( VAR lane: Lane; offset: LONGINT );
	VAR tmp: SET32;
	BEGIN
		IF ODD( offset ) THEN
			tmp := lane.low;
			lane.low := ROT( lane.high, (offset+1) DIV 2 );
			lane.high := ROT( tmp, (offset-1) DIV 2 )
		ELSE
			lane.low := ROT( lane.low, offset DIV 2 );
			lane.high := ROT( lane.high, offset DIV 2 )
		END;
	END ROL64;


	PROCEDURE ROL64_1XOR( CONST in1, in2: Lane; VAR out: Lane );
	BEGIN
		out.low := ROT( in1.high, 1 ) / in2.low;
		out.high := in1.low / in2.high;
	END ROL64_1XOR;


	PROCEDURE Round( VAR a: State; r: LONGINT );
	VAR
		x, y, i, i1, i2: LONGINT;
		c, d: ARRAY 5 OF Lane;
		a0: State;
	BEGIN
		(* theta *)
		FOR x := 0 TO 4 DO
			c[x].low := {};  c[x].high := {};
			FOR y := 0 TO 20 BY 5 DO
				c[x].low := c[x].low / a[x+y].low;
				c[x].high := c[x].high / a[x+y].high;
			END
		END;
		FOR x := 0 TO 4 DO
			ROL64_1XOR( c[(x+1) MOD 5], c[(x+4) MOD 5], d[x] );
		END;
		FOR x := 0 TO 4 DO
			FOR y := 0 TO 4 DO
				i := x + 5*y;
				a[i].low := a[i].low / d[x].low;
				a[i].high := a[i].high / d[x].high
			END
		END;
		(* rho *)
		FOR i := 0 TO 24 DO
			ROL64( a[i], rhoOffsets[i] );
		END;
		(* pi *)
		a0 := a;
		FOR x := 0 TO 4 DO
			FOR y := 0 TO 4 DO
				a[y + 5*((2*x + 3*y) MOD 5)] := a0[x + 5*y]
			END
		END;
		(* chi *)
		FOR y := 0 TO 20 BY 5 DO
			FOR x := 0 TO 2 DO
				i := x + y;  i1 := x + 1 + y;  i2 := x + 2 + y;
				c[x].low := a[i].low / ((-a[i1].low) * a[i2].low);
				c[x].high := a[i].high / ((-a[i1].high) * a[i2].high);
			END;
			i := 3 + y;  i1 := 4 + y;  i2 := 0 + y;
			c[3].low := a[i].low / ((-a[i1].low) * a[i2].low);
			c[3].high := a[i].high / ((-a[i1].high) * a[i2].high);
			i := 4 + y;  i1 := 0 + y;  i2 := 1 + y;
			c[4].low := a[i].low / ((-a[i1].low) * a[i2].low);
			c[4].high := a[i].high / ((-a[i1].high) * a[i2].high);
			FOR x := 0 TO 4 DO
				a[x+y].low := c[x].low;
				a[x+y].high := c[x].high
			END
		END;
		(* iota *)
		a[0].low := a[0].low / roundConstants[r].low;
		a[0].high := a[0].high / roundConstants[r].high;
	END Round;



	(* ---------------------------------------------------------------- *)


	PROCEDURE InitializeRoundConstants;
	VAR
		LFSRstate: SET32;
		i, j, bit: LONGINT;
		lane: Lane;
	BEGIN
		LFSRstate := {0};
		FOR i := 0 TO nrRounds - 1 DO
			lane.low := {};  lane.high := {};
			FOR j := 0 TO 6 DO
	       		bit := ASH( 1, j ) - 1;
	 			IF LFSR86540( LFSRstate ) THEN
	      			IF bit < 32 THEN  INCL( lane.low, bit )  ELSE  INCL( lane.high, bit - 32 )  END
	   			END
	  		END;
	   		ToBitInterleaving( lane, roundConstants[i] );
	 	END
	END InitializeRoundConstants;



	PROCEDURE InitializeRhoOffsets;
	VAR
	    x, y, t, oldY: LONGINT;
	BEGIN
	  	rhoOffsets[0] := 0;
	 	x := 1;
		y := 0;
		FOR t := 0 TO 23 DO
			rhoOffsets[x + 5*y] := ((t+1)*(t+2) DIV 2) MOD 64;
	        	oldY := y;  y := (2*x + 3*y) MOD 5;
	        	x := oldY;
		END
	END InitializeRhoOffsets;

	PROCEDURE LFSR86540( VAR LFSR: SET32 ): BOOLEAN;
	VAR result: BOOLEAN;
	BEGIN
		result := 0 IN LFSR;
		IF 7 IN LFSR THEN
			(* Primitive polynomial over GF(2): x^8+x^6+x^5+x^4+1 *)
			LFSR := LSH( LFSR, 1) / S.VAL( SET32, 71H );
		ELSE
			LFSR := LSH( LFSR, 1 )
		END;
		RETURN result;
	END LFSR86540;



BEGIN
	InitializeRoundConstants;
	InitializeRhoOffsets;
END CryptoKeccakF1600.