const
  Alphabet = 'абвгдеёжзийклмнопрстуфхцчшщъыьэюя0123456789$!.,?;*(){}+=:/[]@\^"';

type
  Rotor = array [1..64] of byte;


type
  TCrypt = class(TThread)
  private
    CloseText: TStrings;
    OpenText: TStrings;
    key: string;
    textlength: longword;
    R1, R2, R3: Rotor;
    ComPanel: Rotor;
    Reflector: Rotor;
    Action: Char;

    procedure CreateObjects;
    procedure SetByKey;
    procedure ChangeComPanel(index1, index2: byte);
    function  RollRotorLeft(R:Rotor; count: byte =1): Rotor;
    function  RollRotorRight(R:Rotor; count: byte =1): Rotor;
    procedure RollRotors(Direction: char);

    function  GetCharNumber(chr: char): byte;
    function  FindNumber(R: Rotor; Num: byte): byte;

    procedure Encrypt;

  protected
    procedure Execute; override;
  end;

type
  TStats = class
    counter: array [1..33] of integer;  // счетчики для частотного анализа
    bigramms: string; // список часто встречающихся биграмм
    bscounter: integer; // счетчик встретившихся наивероятнейших биграмм
    bcounter: int64; // количество исследованных биграмм
    text: TStrings;
    textlength: longword;

    constructor create;
    destructor destroy;
    procedure UpdateCounter;
    procedure UpdateBCounter;
    function FrequencyAnalysis: boolean;
    function BigrammsAnalysis: boolean;
  end;


procedure TCrypt.CreateObjects;
var
  i: byte;
begin
  // заполним роторы, коммутационную панель и рефлектор
  for i := 1 to 64 do
    begin
      R1[i] := i;
      R2[i] := i;
      R3[i] := i;
      ComPanel[i] := i;
      if i = 32 then
        Reflector[i] := 64
      else
        Reflector[i] := (i + 32) mod 64;
    end; // for

  // создадим строковые списки OpenText и CloseText
  OpenText := TStringList.Create;
  OpenText.Clear;
  CloseText := TStringList.Create;
  CloseText.Clear;
end;


procedure TCrypt.SetByKey;
var
  i: byte;
  tmpstr: string;
begin
  // крутим роторы нужное количество раз
  R1 := RollRotorLeft(cR1, GetCharNumber(key[1])-1);
  R2 := RollRotorLeft(cR2, GetCharNumber(key[2])-1);
  R3 := RollRotorLeft(cR3, GetCharNumber(key[3])-1);

  // генерируем новую коммутационную панель
  for i := 1 to 64 do
    ComPanel[i] := i;
  // меняем коммутацию символов согласно ключу
  if (length(key) > 4) then
    begin
      tmpstr := copy(key, 4, length(key)-3);
      for i := 0 to Round(length(tmpstr)/2)-1 do
        ChangeComPanel(GetCharNumber(tmpstr[2*i+1]), GetCharNumber(tmpstr[2*i+2]));
    end;
end;


procedure TCrypt.ChangeComPanel(index1, index2: byte);
var
  tmp1, tmp2: byte;
begin

// если изменяется соединение задействованных контактов, сбросить их
  tmp1 := ComPanel[index1];
  Companel[tmp1] := tmp1;

  tmp2 := ComPanel[index2];
  Companel[tmp2] := tmp2;


  // изменяем способ коммутации
  Companel[index1] := index2;
  Companel[index2] := index1;

  // прорисовываем изменения
  fmMain.sgComPanel.Cells[tmp1-1,1] := Alphabet[ComPanel[tmp1]];
  fmMain.sgComPanel.Cells[tmp2-1,1] := Alphabet[ComPanel[tmp2]];
  fmMain.sgComPanel.Cells[index1-1,1] := Alphabet[ComPanel[index1]];
  fmMain.sgComPanel.Cells[index2-1,1] := Alphabet[ComPanel[index2]];

end;


procedure TCrypt.RollRotors(Direction: char);
begin
  case Direction of
  'L','l':
    begin
      R1 := RollRotorLeft(R1);

      if (textlength mod 7 = 0) then
        R2 := RollRotorLeft(R2);

      if (textlength mod 13 = 0) then
        R3 := RollRotorLeft(R3);
    end; // L

  'R','r':
    begin
      R1 := RollRotorRight(R1);

      if (textlength mod 7 = 0) then
        R2 := RollRotorRight(R2);

      if (textlength mod 13 = 0) then
        R3 := RollRotorRight(R3);
    end; // R
  end; // case
end;


function TCrypt.RollRotorLeft(R:Rotor; count: byte =1): Rotor;
var
  i, j, tmp: byte;
  tmpR: Rotor;
begin
  tmpR := R;

  // крутим ротор count раз
  for i := 1 to count do
    begin
      // запоминаем первый символ
      tmp := tmpR[1];

      // смещаем все символы на 1
      for j := 1 to 63 do
        tmpR[j] := tmpR[j+1];

      // присваиваем последнему значение первого
      tmpR[64] := tmp;
    end;

  // выводим результат
  Result := tmpR;
end;


function TCrypt.RollRotorRight(R:Rotor; count: byte =1): Rotor;
var
  i, j, tmp: byte;
  tmpR: Rotor;
begin
  tmpR := R;

  // крутим ротор count раз
  for i := 1 to count do
    begin
      // запоминаем последний символ
      tmp := tmpR[64];

      // смещаем все символы на 1
      for j := 63 downto 1 do
        tmpR[j+1] := tmpR[j];

      // присваиваем первому значение последнего
      tmpR[1] := tmp;
    end;

  // выводим результат
  Result := tmpR;
end;


function TCrypt.GetCharNumber(chr: char): byte;
begin
  Result := POS(chr, Alphabet);
end;


function TCrypt.FindNumber(R: Rotor; Num: byte): byte;
var
  i: integer;
begin
  // просматриваем все символы алфавита
  for i := 1 to 64 do
    // если i-тый символ ротора искомый, то останавливаемся и выводим результат
    if R[i] = Num then
      begin
        Result := i;
        exit;
      end;
  Result := 0;
end;

procedure TCrypt.Encrypt;
var
  tmp: byte;
  i, j: integer;
  tmpstr: string;
begin
  textlength := 0;

  // устанавливаем все параметры по ключу
  SetByKey;

  for i := 0 to OpenText.Count - 1 do
    begin
      // используем временную строку для шифрования строки открытого текста
      tmpstr := '';

      for j := 1 to length(OpenText[i]) do
        begin
          // увеличиваем счетчик длины текста и крутим роторы
          inc(textlength);
          RollRotors('L');

          // если символ из алфавита, то зашифровываем его
          if (POS(OpenText[i][j], Alphabet) <> 0) then
            begin
              // совершаем переходы по подстановкам
              tmp := GetCharNumber(OpenText[i][j]);
              tmp := ComPanel[tmp];
              tmp := R1[tmp];
              tmp := R2[tmp];
              tmp := R3[tmp];
              tmp := Reflector[tmp];
              tmp := FindNumber(R3, tmp);
              tmp := FindNumber(R2, tmp);
              tmp := FindNumber(R1, tmp);
              tmp := ComPanel[tmp];

              // выводим зашифрованный символ
              tmpstr := tmpstr + Alphabet[tmp];
            end // if
          // если не из алфавита, то пропускаем
          else
            tmpstr := tmpstr + OpenText[i][j];
        end; // for j
      CloseText.Append(tmpstr);
    end; // for i
end;

procedure TCrypt.Execute;
begin
  case action of
    'E', 'e': Encrypt;
  end;
end;


constructor TStats.create;
var
  i: integer;
begin
  // сбросим счетчик частот
  for i := 1 to 33 do
    counter[i] := 0;

  // сбросим счетчики биграмм и длины текста
  bscounter := 0;
  bcounter := 0;
  textlength := 0;
  text := TStringList.Create;
  text.Clear;

  // укажем ожидаемые биграммы
  bigramms := 'ал ан ас ат ар ав ак ам ' +
              'бо бы бе ба бр бу ' +
              'во ва ви вы вс вн вл вр ' +
              'го га гр гл ги гв ' +
              'де да ди до дн ду др дв ' +
              'ен ет ер ес ел ев ем еи ' +
              'же жи жд жа жн ' +
              'за зн зв зо зм зд ' +
              'ис ин ив ии ие им ик из ' +
              'ко ка ки кр ку кт кл ке ' +
              'ли ле ло ла ль ля лю лу ' +
              'ми ме мо му ма мн мп мы ' +
              'но на ни не ны нн ну ' +
              'ов ос от ор ои од он ом ' +
              'по пр пе па пу пи пл ' +
              'ра ре ро ри ру ря ры рн ' +
              'ст ск со ся се сь сс сн ' +
              'то та те ти ть тв тр тс ' +
              'ут уп ус уд ун ую уж ' +
              'фи фе фо фа фе фо фа ' +
              'хо хи хс хн хв хп хр ' +
              'ци це ца цы ' +
              'че чи чт чн ' +
              'ше ши шн ша шо шл ' +
              'ще щи ща ' +
              'ыл ых ые ым ыи ыв ыс ын ' +
              'ьн ьк ьв ьп ьс ье ьо ьи ' +
              'эн эт эр эс эк ' +
              'юд ют ющ юц юн юп ' +
              'яв яс ят яп яд як ям ял';
end;

destructor TStats.destroy;
begin
end;


procedure TStats.UpdateCounter;
// процедура пересчета частот символов в тексте
var
  i, j: integer;
begin
  if (text.Count >= 0) then
    for i := 0 to text.count - 1 do
      for j := 1 to length(text[i]) do
        case text[i][j] of
          'ё','Ё':
            begin
              inc(textlength);
              inc(counter[7]);
              continue;
            end;

          'а'..'я':
            begin
              inc(textlength);
              inc(counter[ord(text[i][j])-223]);
              continue;
            end;

          'А'..'Я':
            begin
              inc(counter[ord(text[i][j])-191]);
              inc(textlength);
            end;
        end;
end;


procedure TStats.UpdateBCounter;
// процедура пересчета биграмм в тексте
var
  i, j: integer;
begin
  if (text.Count >= 0) then
    for i := 0 to text.count - 1 do
      for j := 2 to length(text[i]) do
        case text[i][j] of
        'А'..'я':
          begin
            inc(bcounter);
            if (POS(text[i][j-1]+text[i][j],bigramms) <> 0) then
              inc(bscounter);
          end;
        end; // case
end;


function TStats.FrequencyAnalysis: Boolean;
var
  tmp: longint;
begin
  // обозначим самые используемые символы
  tmp := counter[1] + counter[3] + counter[6] + counter[10] + counter[11] +
       counter[15] + counter[16] + counter[18] + counter[19] + counter[20];

  // если эти символы встречаются чаще остальных, то текст похож на правильный
  if (tmp > textlength - tmp) then
        Result := true
  else
    Result := false;
end;

function TStats.BigrammsAnalysis: Boolean;
var
  tmp: double;
begin
  // на случай, если не встретилось символов из алфавита
  if bcounter > 0 then
    tmp := bscounter/bcounter
  else
    tmp := 0;

  // если ожидаемых биграмм больше 70% то текст можно считать правильным
  if (tmp > 0.7) then
    Result := true
  else
    Result := false;

end;


procedure TfmMain.sbDecryptClick(Sender: TObject);
var
  DecryptThread: TCrypt;
  Stats: TStats;
begin
  
  // нужно запустить несколько таких потоков
  DecryptThread := TCrypt.Create(true);
  Stats := TStats.create;


  //  smResultText - Memo
  //  BruteKey - текущий ключ - строка вида 'xyz'
  //  ResultTexts - массив TStrings расшифрованных текстов 

  smResultText.Lines.Clear;
  DecryptThread.CreateObjects;
  DecryptThread.OpenText := smInputText.Lines;
  DecryptThread.key := BruteKey;
  DecryptThread.action := 'E';
  DecryptThread.Execute;
  Stats.text := DecryptThread.CloseText;
  Stats.UpdateCounter;
  Stats.UpdateBCounter;
  if Stats.FrequencyAnalysis and Stats.BigrammsAnalysis then
    ResultTexts := DecryptThread.CloseText;
      DecryptThread.Terminate;


end;