-- Serpent - Provide an ideal interface to the Serpent cipher.
-- Copyright (C) 2023 Prince Trippy <programmer@verisimilitudes.net>.

-- This program is free software: you can redistribute it and/or modify it under the terms of the
-- GNU Affero General Public License version 3 as published by the Free Software Foundation.

-- This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without
-- even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-- See the GNU Affero General Public License for more details.

-- You should have received a copy of the GNU Affero General Public License along with this program.
-- If not, see <http://www.gnu.org/licenses/>.

with Interfaces; use type Interfaces.Unsigned_32; -- For some reason, the with seems to be required.

package body Serpent is
   procedure Ltr (W : in out Word_Block) is
      A : Word renames W(1); B : Word renames W(2); C : Word renames W(3); D : Word renames W(4);
   begin
      A := Interfaces.Rotate_Left(A, 13);
      C := Interfaces.Rotate_Left(C, 3);
      B := A xor B xor C;
      D := C xor D xor Interfaces.Shift_Left(A, 3);
      B := Interfaces.Rotate_Left(B, 1);
      D := Interfaces.Rotate_Left(D, 7);
      A := A xor B xor D;
      C := C xor D xor Interfaces.Shift_Left(B, 7);
      A := Interfaces.Rotate_Left(A, 5);
      C := Interfaces.Rotate_Left(C, 22);
   end Ltr;

   procedure Itr (W : in out Word_Block) is
      A : Word renames W(1); B : Word renames W(2); C : Word renames W(3); D : Word renames W(4);
   begin
      C := Interfaces.Rotate_Right(C, 22);
      A := Interfaces.Rotate_Right(A, 5);
      C := C xor D xor Interfaces.Shift_Left(B, 7);
      A := A xor B xor D;
      D := Interfaces.Rotate_Right(D, 7);
      B := Interfaces.Rotate_Right(B, 1);
      D := C xor D xor Interfaces.Shift_Left(A, 3);
      B := A xor B xor C;
      C := Interfaces.Rotate_Right(C, 3);
      A := Interfaces.Rotate_Right(A, 13);
   end Itr;

   procedure S (Box : in S_Box; W : in out Word_Block) is -- Read the paper ``Speeding up Serpent''.
      A : Word renames W(1); B : Word renames W(2); C : Word renames W(3); D : Word renames W(4);
      E : Word;
   begin
      case Box is -- I know there's absolutely nothing interesting about this subprogram whatsoever.
         when 0 => E :=       B; D := D xor A; B := B and D; E := E xor C; B := B xor A;
                   A := A  or D; A := A xor E; E := E xor D; D := D xor C; C := C  or B;
                   C := C xor E; E :=   not E; E := E  or B; B := B xor D; B := B xor E;
                   D := D  or A; B := B xor D; E := E xor D;
                   D := A; A := B; B := E; -- I'd to manually unravel these final assignment orders.
         when 1 => A :=   not A; E :=       A; C :=   not C; A := A and B; C := C xor A;
                   A := A  or D; D := D xor C; B := B xor A; A := A xor E; E := E  or B;
                   B := B xor D; C := C  or A; C := C and E; A := A xor B; B := B and C;
                   B := B xor A; A := A and C; A := A xor E;
                   E := B; B := A; A := C; C := D; D := E;
         when 2 => E :=       A; A := A and C; A := A xor D; C := C xor B; C := C xor A;
                   D := D  or E; D := D xor B; E := E xor C; B :=       D; D := D  or E;
                   D := D xor A; A := A and B; E := E xor A; B := B xor D; B := B xor E;
                   E :=   not E;
                   A := C; C := B; B := D; D := E;
         when 3 => E :=       A; A := A  or D; D := D xor B; B := B and E; E := E xor C;
                   C := C xor D; D := D and A; E := E  or B; D := D xor E; A := A xor B;
                   E := E and A; B := B xor D; E := E xor C; B := B  or A; B := B xor C;
                   A := A xor D; C :=       B; B := B  or D; B := B xor A;
                   A := B; B := C; C := D; D := E;
         when 4 => B := B xor D; E :=       B; D :=   not D; C := C xor D; D := D xor A;
                   B := B and D; B := B xor C; E := E xor D; A := A xor E; C := C and E;
                   C := C xor A; A := A and B; D := D xor A; E := E  or B; E := E xor A;
                   A := A  or D; A := A xor C; C := C and D; A :=   not A; E := E xor C;
                   C := A; A := B; B := E;
         when 5 => A := A xor B; B := B xor D; E :=       B; D :=   not D; B := B and A;
                   C := C xor D; B := B xor C; C := C  or E; E := E xor D; D := D and B;
                   D := D xor A; E := E xor B; E := E xor C; C := C xor A; A := A and D;
                   C :=   not C; A := A xor E; E := E  or D; C := C xor E;
                   E := A; A := B; B := D; D := C; C := E;
         when 6 => E :=       D; C :=   not C; D := D and A; A := A xor E; D := D xor C;
                   C := C  or E; B := B xor D; C := C xor A; A := A  or B; C := C xor B;
                   E := E xor A; A := A  or D; A := A xor C; E := E xor D; E := E xor A;
                   D :=   not D; C := C and E; C := C xor D;
                   D := C; C := E;
         when 7 => E :=       B; B := B  or C; B := B xor D; E := E xor C; C := C xor B;
                   D := D  or E; D := D and A; E := E xor C; D := D xor B; B := B  or E;
                   B := B xor A; A := A  or E; A := A xor C; B := B xor E; C := C xor B;
                   B := B and A; B := B xor E; C :=   not C; C := C  or A; E := E xor C;
                   C := B; B := D; D := A; A := E;
      end case;
   end S;

   procedure I (Box : in S_Box; W : in out Word_Block) is
      A : Word renames W(1); B : Word renames W(2); C : Word renames W(3); D : Word renames W(4);
      E : Word;
   begin
      case Box is
         when 0 => E :=       B; C :=   not C; B := B  or A; E :=   not E; B := B xor C;
                   C := C  or E; B := B xor D; A := A xor E; C := C xor A; A := A and D;
                   E := E xor A; A := A  or B; A := A xor C; D := D xor E; C := C xor B;
                   D := D xor A; D := D xor B; C := C and D; E := E xor C;
                   C := B; B := E;
         when 1 => E :=       B; B := B xor D; D := D and B; E := E xor C; D := D xor A;
                   A := A  or B; C := C xor D; A := A xor E; A := A  or C; B := B xor D;
                   A := A xor B; B := B  or D; B := B xor A; E :=   not E; E := E xor B;
                   B := B  or A; B := B xor A; B := B  or E; D := D xor B;
                   B := A; A := E; E := C; C := D; D := E;
         when 2 => C := C xor D; D := D xor A; E :=       D; D := D and C; D := D xor B;
                   B := B  or C; B := B xor E; E := E and D; C := C xor D; E := E and A;
                   E := E xor C; C := C and B; C := C  or A; D :=   not D; C := C xor D;
                   A := A xor D; A := A and B; D := D xor E; D := D xor A;
                   A := B; B := E;
         when 3 => E :=       C; C := C xor B; A := A xor C; E := E and C; E := E xor A;
                   A := A and B; B := B xor D; D := D  or E; C := C xor D; A := A xor D;
                   B := B xor E; D := D and C; D := D xor B; B := B xor A; B := B  or C;
                   A := A xor D; B := B xor E; A := A xor B;
                   E := A; A := C; C := D; D := E;
         when 4 => E :=       C; C := C and D; C := C xor B; B := B  or D; B := B and A;
                   E := E xor C; E := E xor B; B := B and C; A :=   not A; D := D xor E;
                   B := B xor D; D := D and A; D := D xor C; A := A xor B; C := C and A;
                   D := D xor A; C := C xor E; C := C  or D; D := D xor A; C := C xor B;
                   B := D; D := E;
         when 5 => E :=       D; B :=   not B; C := C xor B; D := D  or A; D := D xor C;
                   C := C  or B; C := C and A; E := E xor D; C := C xor E; E := E  or A;
                   E := E xor B; B := B and C; B := B xor D; E := E xor C; D := D and E;
                   E := E xor B; D := D xor E; E :=   not E; D := D xor A;
                   A := B; B := E; E := C; C := D; D := E;
         when 6 => E :=       C; A := A xor C; C := C and A; E := E xor D; C :=   not C;
                   D := D xor B; C := C xor D; E := E  or A; A := A xor C; D := D xor E;
                   E := E xor B; B := B and D; B := B xor A; A := A xor D; A := A  or C;
                   D := D xor B; E := E xor A;
                   A := B; B := C; C := E;
         when 7 => E :=       C; C := C xor A; A := A and D; E := E  or D; C :=   not C;
                   D := D xor B; B := B  or A; A := A xor C; C := C and E; D := D and E;
                   B := B xor C; C := C xor A; A := A  or C; E := E xor B; A := A xor D;
                   D := D xor E; E := E  or A; D := D xor C; E := E xor C;
                   C := B; B := A; A := D; D := E;
      end case;
   end I;

   function Pad (Key : in User_Key) return Full_Key is
      type Temporary is array (Positive range <>) of Word;
      P : Word := 2**31; -- To properly pad, a one, followed by zeroes, is appended to the User_Key.
      K : User_Key(Key_Length'First .. Key_Length'First + Integer'Pred(Key'Length)) := Key;
      T : Temporary := Temporary(K) & Temporary(Full_Key'(P, others => 0));
   begin
      return Full_Key(T(Key_Length'Range)); -- Amusingly, this is that same method I'd use with APL.
   end Pad;

   function Schedule (Key : in Full_Key) return Sub_Keys is
      Pre : Pre_Keys := (Key(1), Key(2), Key(3), Key(4), Key(5), Key(6), Key(7), Key(8),
                         others => <>);
      Sub : Sub_Keys;
   begin
      for I in Key_Schedule range 0 .. Key_Schedule'Last loop
         Pre(I) := Interfaces.Rotate_Left
           (Amount => 11,
            Value  => Pre(I - 8) xor Pre(I - 5) xor Pre(I - 3) xor Pre(I - 1) xor Phi xor Word(I));
      end loop;

      declare
         B : S_Box := 3;
         J : Key_Schedule := 0;
      begin
         for I in Sub_Keys'Range loop
            Sub(I) := (Pre(J), Pre(J + 1), Pre(J + 2), Pre(J + 3));
            S(Box => B, W => Sub(I));
            exit when I = Sub_Keys'Last; -- This early exit was subtle, and so I missed it at first.
            J := J + 4;
            B := B - 1;
         end loop;
      end;

      return Sub;
   end Schedule;

   function "xor" (Left, Right : in Word_Block) return Word_Block is
      Result : Word_Block;
   begin
      for I in Word_Block'Range loop
         Result(I) := Left(I) xor Right(I);
      end loop;
      return Result;
   end "xor";

   procedure Encrypt (Key : in Sub_Keys; Message : in out Word_Block) is
   begin
      for I in Natural range 0 .. 30 loop
         Message := Message xor Key(I);
         S(Box => S_Box'Mod(I), W => Message);
         Ltr(Message);
      end loop;
      Message := Message xor Key(31);
      S(Box => 7, W => Message);
      Message := Message xor Key(32);
   end Encrypt;

   procedure Decrypt (Key : in Sub_Keys; Message : in out Word_Block) is
   begin
      Message := Message xor Key(32);
      I(Box => 7, W => Message);
      Message := Message xor Key(31);
      for J in reverse Natural range 0 .. 30 loop
         Itr(Message);
         I(Box => S_Box'Mod(J), W => Message);
         Message := Message xor Key(J);
      end loop;
   end Decrypt;

   function Encrypt (Key : in Sub_Keys; Message : in Word_Block) return Word_Block is
      M : Word_Block := Message;
   begin
      Encrypt(Key, M);
      return M;
   end Encrypt;

   function Decrypt (Key : in Sub_Keys; Message : in Word_Block) return Word_Block is
      M : Word_Block := Message;
   begin
      Decrypt(Key, M);
      return M;
   end Decrypt;

   procedure Encrypt (Key : in Sub_Keys;
                      Decrypted : in Decrypted_Block; Encrypted : out Encrypted_Block) is
      M : Word_Block := Word_Block(Decrypted);
   begin
      Encrypt(Key, M);
      Encrypted := Encrypted_Block(M);
   end Encrypt;

   procedure Decrypt (Key : in Sub_Keys;
                      Encrypted : in Encrypted_Block; Decrypted : out Decrypted_Block) is
      M : Word_Block := Word_Block(Encrypted);
   begin
      Decrypt(Key, M);
      Decrypted := Decrypted_Block(M);
   end Decrypt;

   function Encrypt (Key : in Sub_Keys; Message : in Decrypted_Block) return Encrypted_Block is
      M : Encrypted_Block;
   begin
      Encrypt(Key, Decrypted => Message, Encrypted => M);
      return M;
   end Encrypt;

   function Decrypt (Key : in Sub_Keys; Message : in Encrypted_Block) return Decrypted_Block is
      M : Decrypted_Block;
   begin
      Decrypt(Key, Encrypted => Message, Decrypted => M);
      return M;
   end Decrypt;

   procedure Encrypt (Key : in Sub_Keys; Message : in out Word_Array;
                      Initial_Mask : in Word_Block := (others => 0)) is
      M : Word_Block := Initial_Mask;
   begin
      for I in Message'Range loop
         Message(I) := Message(I) xor M;
         Encrypt(Key, Message(I));
         M := Message(I);
      end loop;
   end Encrypt;

   procedure Decrypt (Key : in Sub_Keys; Message : in out Word_Array;
                      Initial_Mask : in Word_Block := (others => 0)) is
      M : Word_Block := Initial_Mask;
      N : Word_Block;
   begin
      for I in Message'Range loop
         N := Message(I);
         Decrypt(Key, Message(I));
         Message(I) := Message(I) xor M;
         M := N;
      end loop;
   end Decrypt;

   function Encrypt (Key : in Sub_Keys; Message : in Word_Array;
                     Initial_Mask : in Word_Block := (others => 0)) return Word_Array is
      M : Word_Array := Message;
   begin
      Encrypt(Key, M, Initial_Mask);
      return M;
   end Encrypt;

   function Decrypt (Key : in Sub_Keys; Message : in Word_Array;
                     Initial_Mask : in Word_Block := (others => 0)) return Word_Array is
      M : Word_Array := Message;
   begin
      Decrypt(Key, M, Initial_Mask);
      return M;
   end Decrypt;

   function Encrypt (Key : in Sub_Keys; Message : in Decrypted_Array;
                     Initial_Mask : in Word_Block := (others => 0)) return Encrypted_Array is
      M : Word_Array := Word_Array(Message);
   begin
      Encrypt(Key, M, Initial_Mask);
      return Encrypted_Array(M);
   end Encrypt;

   function Decrypt (Key : in Sub_Keys; Message : in Encrypted_Array;
                     Initial_Mask : in Word_Block := (others => 0)) return Decrypted_Array is
      M : Word_Array := Word_Array(Message);
   begin
      Decrypt(Key, M, Initial_Mask);
      return Decrypted_Array(M);
   end Decrypt;
end Serpent;
.