Resh

unit Unit2;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Layouts,
  FMX.Objects, FMX.Controls.Presentation, FMX.StdCtrls;

type
  TForm2 = class(TForm)
    btnDecrypt: TButton;
    Button3: TButton;
    btnEncrypt: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure btnEncryptClick(Sender: TObject);
    procedure btnDecryptClick(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
  Arr = array of array of char;
  BoolArr = array of array of Boolean;
  IntArr = array of Integer;
const
  N = 4;
var
  Form2: TForm2;
  IsFirst, IsSecond, IsThird, IsFourth: Boolean;
  Counter: Integer;
  TempArr, BuffArr, BigArr: IntArr;
  Color1, Color2, Color3, Color4: Integer;
  ChArr, MyArr: Arr;
  MaskStr: string;
  StartIndex: Integer;

implementation

{$R *.fmx}

function ExtractString(SourceStr: string): string;
var
   ExtractStr: string;
   i: Integer;
begin
   for i := 1 to Length(SourceStr) do
      if (MaskStr[i] in (['a'..'z', 'A'..'Z'])) then
         ExtractStr := ExtractStr + SourceStr[i];
   ExtractString := ExtractStr;
end;

function LowCase(ch: char): char;
begin
   if ch in ['A'..'Z'] then
      LowCase := chr(ord(ch) + 32)
   else
      LowCase := ch;
end;

function GetMask(Str: string): string;
var
   i: Integer;
begin
   for i := 1 to Length(Str) do
      if (Str[i] in (['a'..'z', 'A'..'Z'])) then
         Str[i] := 'w';
   GetMask := Str;
end;

function ReadFromFile(FileName: string): string;
var
   i: Integer;
   MyFile: TextFile;
   letter: char;
begin
   for i := 1 to Length(MaskStr) do
      MaskStr := '';
   AssignFile(MyFile, FileName);
   Reset(MyFile);
   while not Eof(MyFile) do
   begin
      read(MyFile, letter);
      letter := LowCase(letter);
      MaskStr := MaskStr + letter;
   end;
   CloseFile(MyFile);
   ReadFromFile := MaskStr;
end;

procedure WriteToFile(Str: string; FinalStr: string; FileName: string);
var
   MyFile: TextFile;
   i, k: Integer;
begin
   AssignFile(MyFile, FileName);
   Rewrite(MyFile);
   k := 1;
   for i := 1 to Length(Str) do
      if (Str[i] = 'w') then
      begin
         Str[i] := FinalStr[k];
         inc(k);
      end;
   begin
      Write(MyFile, str);
   end;
   CloseFile(MyFile);
end;

function StringLength(Str: string): integer;
var
   Amount: Integer;
begin
   if Length(Str) < N then
      Amount := Length(Str)
   else
      Amount := N;
   StringLength := Amount;
end;

function ArrToStr(HelpArr: Arr): string;
var
   i, j: Integer;
   TempStr: string;
begin
   SetLength(HelpArr, n, n);
   for i := 0 to n - 1 do
      for j := 0 to n - 1 do
         if (HelpArr[i, j] in ['a'..'z']) then
            TempStr := TempStr + HelpArr[i, j];
   ArrToStr := TempStr;
end;

function FillHoles(CharArr: Arr; BooleanArr: BoolArr; Str: string): Arr;
var
   i, j: Integer;
begin
   for i := 0 to N - 1 do
      for j := 0 to N - 1 do
         if (BooleanArr[i, j] = True) then
         begin
            CharArr[i, j] := Str[StartIndex];
            inc(StartIndex);
            BooleanArr[i, j] := False;
         end;
   FillHoles := CharArr;
end;

function ReadHoles(CharArr: Arr; BooleanArr: BoolArr; Str: string): string;
var
   i, j: Integer;
begin
   for i := 0 to N - 1 do
      for j := 0 to N - 1 do
         if (BooleanArr[i, j] = True) and (CharArr[i, j]  <> '') and (CharArr[i, j]  <> ' ') then
         begin
            Str := Str + CharArr[i, j];
            inc(StartIndex);
            BooleanArr[i, j] := False;
         end;
   ReadHoles := Str;
end;

function MakeHole(AmountSymbols: Integer; IndArr: IntArr; var BooleanArr: BoolArr; var TempCounter: Integer): BoolArr;
var
   i: Integer;
   CurrentI, CurrentJ: Integer;
   NextI, NextJ: Integer;
begin
   if TempCounter = 33 then
      TempCounter := 0;
   for i := 0 to AmountSymbols - 1 do
   begin
      CurrentI := IndArr[TempCounter];
      CurrentJ := IndArr[TempCounter + 1];
      NextI :=  CurrentJ;
      NextJ :=  N - CurrentI - 1;
      BooleanArr[Currenti, Currentj] := True;
      IndArr[TempCounter + N * 2] := NextI;
      IndArr[TempCounter + N * 2 + 1] := NextJ;
      inc(TempCounter, 2);
   end;
   MakeHole := BooleanArr;
end;

function Encryption(AmountSymbols: Integer; Str: string; IndArr: IntArr; CharArr: Arr): string;
var
   i, j: Integer;
   TempCounter: Integer;
   EncryptStr: string;
   BooleanArr: BoolArr;
begin
   SetLength(BooleanArr, N, N);
   for i := 0 to N - 1 do
      for j := 0 to N - 1 do
         BooleanArr[i, j] := False;
   TempCounter := 0;
   for i := 0 to AmountSymbols - 1  do
   begin
      BooleanArr := MakeHole(N, TempArr, BooleanArr, TempCounter);
      CharArr := FillHoles(CharArr, BooleanArr, Str);
   end;
   EncryptStr := ArrToStr(CharArr);
   Encryption := EncryptStr;
end;

procedure ClearMatrix(CharArr: Arr);
var
   i, j: Integer;
begin
   for i := 0 to N - 1 do
      for j := 0 to N - 1 do
         CharArr[i, j] := ' ';
end;

procedure TForm2.btnEncryptClick(Sender: TObject);
var
   SourceStr, NewStr: string;
   PosAm: Integer;
   BlockAmount, i: Integer;
begin
   MaskStr := ReadFromFile('Source.txt');
   SourceStr := ExtractString(MaskStr);
   MaskStr := GetMask(MaskStr);
   if (Length(SourceStr) div (N * N) > 0) and (Length(SourceStr) mod (N * N) = 0) then
      BlockAmount :=  Length(SourceStr) div (N * N)
   else
      if (Length(SourceStr) <> 0) then
         BlockAmount :=  Length(SourceStr) div (N * N) + 1
      else
         BlockAmount := 0;
   if BlockAmount <> 0 then
      for i := 0 to BlockAmount - 1 do
      begin
         if i =  BlockAmount - 1 then
            ClearMatrix(MyArr);
         if i < BlockAmount - 1 then
            PosAm := N
         else
            PosAm := (Length(SourceStr) - StartIndex) div N + 1;
         Counter := 0;
         NewStr := NewStr + Encryption(PosAm, SourceStr, TempArr, MyArr);
      end;
   WriteToFile(MaskStr, NewStr, 'Encrypt.txt');
end;

procedure TForm2.Button1Click(Sender: TObject);
var
   i: Integer;
begin
   Counter := 0;
   for i := 0 to 2 * N - 1 do
   begin
      TempArr[i] := 0;
      BuffArr[i] := 0;
   end;
end;

function StrToArr(TempStr: string; k: Integer): Arr;
var
   i, j: Integer;
   CharArr: Arr;
begin
   SetLength(CharArr, n, n);
   for i := 0 to n - 1 do
      for j := 0 to n - 1 do
      begin
         CharArr[i, j] := TempStr[k];
         inc(k);
      end;
   StrToArr := CharArr;
end;

function SortArray(AmountSymbols: Integer; IndArr: IntArr; var BooleanArr: BoolArr; var TempCounter: Integer): BoolArr;
var
  i, Amount: Integer;
  Temper, SaveCounter, CurrentI, CurrentJ: Integer;
  tempi, tempj: Integer;
begin
   Amount := N - 1;
   dec(TempCounter, 8);
   SaveCounter := TempCounter;
   for i := 0 to N - 2 do
   begin
      Temper := Amount;
      while Amount <> 0 do
      begin
      if IndArr[TempCounter] > IndArr[TempCounter + 2] then
      begin
         tempi := IndArr[TempCounter];
         IndArr[TempCounter] := IndArr[TempCounter + 2];
         IndArr[TempCounter + 2] := tempi;
         tempj := IndArr[TempCounter + 1];
         IndArr[TempCounter + 1] := IndArr[TempCounter + 3];
         IndArr[TempCounter + 3] := tempj;
      end;
      inc(TempCounter, 2);
      dec(Amount);
      end;
      TempCounter := SaveCounter;
      Amount := Temper;
      dec(Amount);
   end;
   if ((AmountSymbols mod n) = 0) then
      AmountSymbols := 0
   else
      AmountSymbols := N - AmountSymbols mod N;
   TempCounter := TempCounter + 2 * (N - AmountSymbols);
   while AmountSymbols <> 0 do
   begin
      CurrentI := IndArr[TempCounter];
      CurrentJ := IndArr[TempCounter + 1];
      BooleanArr[Currenti, Currentj] := False;
      inc(TempCounter, 2);
      dec(AmountSymbols);
   end;
   SortArray := BooleanArr;
end;

function Decryption(AmountSymbols: Integer; Str: string; IndArr: IntArr; CharArr: Arr; Itra: Integer): string;
var
   TempCounter: Integer;
   i, j: Integer;
   NewStr2: string;
   NewArr: Arr;
   BooleanArr: BoolArr;
begin
   SetLength(BooleanArr, N, N);
   for i := 0 to N - 1 do
      for j := 0 to N - 1 do
         BooleanArr[i, j] := False;
   SetLength(NewArr, N, N);
   for i := 0 to N - 1 do
      for j := 0 to N - 1 do
         NewArr[i, j] := ' ';
   TempCounter := 0;
   if (AmountSymbols mod N <> 0) then
      inc(AmountSymbols, N);
   BooleanArr := MakeHole((AmountSymbols div N) * N, TempArr, BooleanArr, TempCounter);
   if (AmountSymbols mod N <> 0) then
      dec(AmountSymbols, N);
   BooleanArr := SortArray(AmountSymbols, TempArr, BooleanArr, TempCounter);
   NewArr := FillHoles(NewArr, BooleanArr, Str);
   StartIndex := 1;
   TempCounter := 0;
   if (AmountSymbols mod N <> 0) then
      inc(AmountSymbols, N);
   for j := 0 to AmountSymbols div N - 1 do
   begin
       BooleanArr := MakeHole(N, TempArr, BooleanArr, TempCounter);
       NewStr2 := ReadHoles(NewArr, BooleanArr, NewStr2);
   end;
   StartIndex := (Itra + 1) * 16 + 1;
   Decryption := NewStr2;
end;

procedure TForm2.btnDecryptClick(Sender: TObject);
var
   SourceStr: string;
   BlockAmount, i, PosAm: Integer;
   NewStr: string;
begin
   StartIndex := 1;
   MaskStr := ReadFromFile('Encrypt.txt');
   SourceStr := ExtractString(MaskStr);
   MaskStr := GetMask(MaskStr);
   if (Length(SourceStr) div (N * N) > 0) and (Length(SourceStr) mod (N * N) = 0) then
      BlockAmount :=  Length(SourceStr) div (N * N)
   else
      if (Length(SourceStr) <> 0) then
         BlockAmount :=  Length(SourceStr) div (N * N) + 1
      else
         BlockAmount := 0;
   if BlockAmount <> 0 then
   for i := 0 to BlockAmount - 1 do
   begin
      if i =  BlockAmount - 1 then
         ClearMatrix(MyArr);
      if i < BlockAmount - 1 then
         PosAm := N * N
      else
         PosAm := (Length(SourceStr) - 16 * i);
      Counter := 0;
      NewStr := NewStr + Decryption(PosAm, SourceStr, TempArr, MyArr, i);
   end;
   WriteToFile(MaskStr, NewStr, 'Decrypt.txt');
end;

procedure RandomKey();
var
  Starti, Startj: Integer;
  Nexti, Nextj: Integer;
  amount, i, j, f: Integer;
  BoolMatrix: BoolArr;
  cc: integer;
begin
   randomize;
   amount := N;
   //firstcc := 0;
   SetLength(BoolMatrix, n, n);
   for i := 0 to n-1 do
       for j := 0 to n-1 do
          BoolMatrix[i, j] := False;
   for i := 0 to amount - 1 do
   begin
     repeat
        f := random(N);
        j := random(N);
     until (BoolMatrix[f, j] = False);
     BoolMatrix[f, j] := True;
     cc := 1;
     Starti := f;
     Startj := j;
     repeat
       Nexti :=  Startj;
       Nextj :=  N - Starti - 1;
       if (Starti + Nextj = n - 1) then
       begin
         BoolMatrix[Nexti, Nextj] := True;
         inc(cc);
       end;
       Starti := Nexti;
       Startj := Nextj;
     until cc = amount;
     TempArr[Counter] := f;
     TempArr[Counter + 1] := j;
     inc(Counter, 2);
   end;
end;

procedure TForm2.Button3Click(Sender: TObject);
begin
   RandomKey();
   btnEncrypt.Enabled := True;
   btnDecrypt.Enabled := True;
end;

procedure TForm2.FormCreate(Sender: TObject);
var
   i, j: Integer;
begin
   IsFirst := True;
   IsSecond := True;
   IsThird := True;
   IsFourth := True;
   Counter := 0;
   StartIndex := 1;
   SetLength(TempArr, 10 * N);
   SetLength(BuffArr, 2 * N);
   SetLength(BigArr, 10 * N);
   SetLength(MyArr, N, N);
   SetLength(ChArr, N, N);
   for i := 0 to N - 1 do
      for j := 0 to N - 1 do
         ChArr[i, j] := ' ';
end;

begin
end.