unit TranspositionFixedTerm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;
const
  MaxTerm = 100;
type
  TRearrangement = array [0..MaxTerm] of Integer;

  TfmTransposition = class(TForm)
    mmDecryptMessage: TMemo;
    mmEncryptMessage: TMemo;
    lbDecryptMessage: TLabel;
    lbEncryptMessage: TLabel;
    lbRearrangement: TLabel;
    edRearrangement: TEdit;
    btnEncryptMessage: TButton;
    btnDecpyptMessage: TButton;
    procedure btnEncryptMessageClick(Sender: TObject);
    procedure btnDecpyptMessageClick(Sender: TObject);
  private
    { Private declarations }
    Rear: TRearrangement;
    function  RecalcRearrangement(nKey: Integer): Boolean;
    function  GetLine(Lines: TStrings; nRow, nInd: Integer): String;
    procedure EncryptDecrypt(SrcLines, DstLines: TStrings; nKey: Integer);
  public
    { Public declarations }
  end;

var
  fmTransposition: TfmTransposition;

implementation

{$R *.dfm}

// функция разбора строки перестановки и проверки ее на корректность
function TfmTransposition.RecalcRearrangement(nKey: Integer): Boolean;
var
  i: Integer;
  s: String;
  Space: Boolean;
  Used: array [1..MaxTerm] of Boolean;
  ExRear: TRearrangement;
begin
  Result := False;
  Rear[0] := 0;
  Space := True;
  // выделяем каждое слово разделенное пробелом
  // и преобразовываем его к числу
  for i := 1 to Length(edRearrangement.Text) do
    if (edRearrangement.Text[i] = ' ') and (not Space) then
      begin
        Inc(Rear[0]);
        Rear[Rear[0]] := StrToInt(s);
        Space := True;
      end
    else
      if (edRearrangement.Text[i] <> ' ') then
        begin
          if Space then
            begin
              Space := False;
              s := '';
            end;
          s := s + edRearrangement.Text[i];
        end;
  if not Space then
    begin
      Inc(Rear[0]);
      Rear[Rear[0]] := StrToInt(s);
    end;
  // проверяем допустимость полученных чисел
  FillChar(Used, SizeOf(Used), False);
  for i := 1 to Rear[0] do
    if (0 < Rear[i]) and (Rear[i] <= Rear[0]) and not Used[Rear[i]] then
      Used[Rear[i]] := True
    else
      Exit;
  // преобразуем перестановку к обратной,
  // для симметричности процесса дешифровки шифровке
  if nKey = 1 then
    begin
      ExRear[0] := Rear[0];
      for i := 1 to Rear[0] do
        ExRear[Rear[i]] := i;
      Rear := ExRear;
    end;
  Result := Rear[0] > 1;
end;

// получает часть текста заданной длины как одну строку,
// начиная с указанной позиции
function TfmTransposition.GetLine(Lines: TStrings; nRow, nInd: Integer): String;
var
  i, j, k: Integer;
  s: String;
begin
  Result := '';
  s := '';
  k := nInd;
  for i := nRow to Lines.Count - 1 do
    begin
      for j := k to Length(Lines[i]) do
        begin
          s := s + Lines[i][j];
          if Length(s) = Rear[0] then
            begin
              Result := s;
              Exit;
            end;
        end;
      k := 1;
    end;
end;

procedure TfmTransposition.btnEncryptMessageClick(Sender: TObject);
begin
  EncryptDecrypt(mmDecryptMessage.Lines, mmEncryptMessage.Lines, 0);
end;

procedure TfmTransposition.btnDecpyptMessageClick(Sender: TObject);
begin
  EncryptDecrypt(mmEncryptMessage.Lines, mmDecryptMessage.Lines, 1);
end;

procedure TfmTransposition.EncryptDecrypt(SrcLines, DstLines: TStrings; nKey: Integer);
var
  i, j, Cnt: Integer;
  s, EncryptMsg: String;
begin
  if RecalcRearrangement(nKey) then
    begin
      // вычисляем общую длину текста
      Cnt := 0;
      for i := 0 to SrcLines.Count - 1 do
        Inc(Cnt, Length(SrcLines[i]));
      // проверяем кратность общей длины длине перестановки
      if Cnt mod Rear[0] <> 0 then
        begin
          MessageDlg('Ошибка: текст сообщения не кратен длине перестановки',
                      mtError, [mbOk], 0);
          Exit;
        end;
      // преобразовываем сообщение
      Cnt := Rear[0];
      DstLines.BeginUpdate;
      DstLines.Clear;
      for i := 0 to SrcLines.Count - 1 do
        begin
          EncryptMsg := '';
          for j := 1 to Length(SrcLines[i]) do
            begin
              if Cnt = Rear[0] then
                begin
                  s := GetLine(SrcLines, i, j);
                  Cnt := 0;
                end;
              Inc(Cnt);
              EncryptMsg := EncryptMsg + s[Rear[Cnt]];
            end;
          DstLines.Add(EncryptMsg);
        end;
      DstLines.EndUpdate;
    end
  else
    MessageDlg('Ошибка: перестановка задана неверно', mtError, [mbOk], 0);
end;

end.
