fork download
copy 
  1. //Шифрование Плэйфера
  2. function Playfair_Crypt(s,key:string):string;
  3. const
  4.   //Размер ключевой матрицы:
  5.   MaxX = 6;//столбцы
  6.   MaxY = 5;//строки
  7.   //Наш алфавит. Размер должен быть MaxY*MaxX.
  8.   //Поэтому в нашем случае убраны буквы "ё", "й", "ь".
  9.   URusA = 'абвгдежзиклмнопрстуфхцчшщъыэюя';
  10.  
  11. var i,j,t,x1,x2,y1,y2 :integer;
  12.     M : array[1..MaxY,1..MaxX]of char; //ключевая матрица
  13.     temp :string;
  14.  
  15.   //Функция поиска символа "с" в ключевой матрице.
  16.   //Возвращает строку "y" и столбец "x".
  17.   Procedure SimbolPos(c:char;var x,y:integer);
  18.   var i,j:integer;
  19.   begin
  20.   x:=0;
  21.   y:=0;
  22.   for i := 1 to MaxY do
  23.     for j := 1 to MaxX do
  24.       if c=M[i,j] then
  25.         begin
  26.         x:=j;
  27.         y:=i;
  28.         exit;
  29.         end;
  30.   end;
  31.  
  32. label M1;
  33. begin
  34. //переводим ключ и исходный текст в нижний регистр.
  35. key:=AnsiLowerCase(key);
  36. s:=AnsiLowerCase(s);
  37. //удаляем из строки все символы, не входящие в наш алфавит.
  38. temp:='';
  39. for i := 1 to length(s) do if pos(s[i],URusA)<>0 then temp:=temp+s[i];
  40. s:=temp;
  41. //Создание ключевой матрицы, с использованием ключевого слова "key".
  42. temp:='';
  43. for i:=1 to length(key) do
  44.  if pos(key[i],temp)=0 then temp:=temp+key[i];
  45. for i:=1 to length(URusA) do
  46.  if pos(URusA[i],temp)=0 then temp:=temp+URusA[i];
  47. t:=0;
  48. for i:=1 to 5 do
  49.  for j:=1 to 6 do
  50.  begin
  51.  inc(t);
  52.  M[i,j]:=temp[t];
  53.  form1.StringGrid1.Cells[j,i]:=temp[t];
  54.  end;
  55.  
  56.  
  57. //просмотр строки по парам символов и вставка разделяющего символа
  58. //"ъ" в случае когда в паре попались одинаковые символы.
  59. M1:
  60. for i:=1 to length(s)div 2 do
  61.   begin
  62.   if s[2*i-1]=s[2*i] then
  63.     begin
  64.     insert('ъ',s,2*i);
  65.     goto M1;
  66.     end;
  67.   end;
  68. //Добавляем символ в конец строки, если её длина нечётная.
  69. if length(s) MOD 2 = 1 then if s[length(s)]<>'ъ' then s:=s+'ъ'
  70.                                                  else s:=s+'я';
  71. temp:='';
  72. for i:=1 to length(s)div 2 do
  73.   begin
  74.   SimbolPos(s[2*i-1],x1,y1);
  75.   SimbolPos(s[2*i],x2,y2);
  76.   //Правило 1
  77.   if y1 = y2 then
  78.     begin
  79.     inc(x1); inc(x2);
  80.     if x1 > MaxX then x1:=x1-MaxX;
  81.     if x2 > MaxX then x2:=x2-MaxX;
  82.     temp:=temp+M[y1,x1]+M[y2,x2];
  83.     end;
  84.   //Правило 2
  85.   if x1 = x2 then
  86.     begin
  87.     inc(y1); inc(y2);
  88.     if y1 > MaxY then y1:=y1-MaxY;
  89.     if y2 > MaxY then y2:=y2-MaxY;
  90.     temp:=temp+M[y1,x1]+M[y2,x2];
  91.     end;
  92.   //Правило 3
  93.   if (x1<>x2) and (y1<>y2) then temp:=temp+M[y1,x2]+M[y2,x1];
  94.   end;
  95. Playfair_Crypt:=temp;
  96. end;
  97.  
  98. //Дешифрование Плэйфера
  99. function Playfair_DeCrypt(s,key:string):string;
  100. const
  101.   //Размер ключевой матрицы:
  102.   MaxX = 6;//столбцы
  103.   MaxY = 5;//строки
  104.   //Наш алфавит. Размер должен быть MaxY*MaxX.
  105.   //Поэтому в нашем случае убраны буквы "ё", "й", "ь".
  106.   URusA = 'абвгдежзиклмнопрстуфхцчшщъыэюя';
  107.  
  108. var i,j,t,x1,x2,y1,y2 :integer;
  109.     M : array[1..MaxY,1..MaxX]of char; //ключевая матрица
  110.     temp :string;
  111.  
  112.   //Функция поиска символа "с" в ключевой матрице.
  113.   //Возвращает строку "y" и столбец "x".
  114.   Procedure SimbolPos(c:char;var x,y:integer);
  115.   var i,j:integer;
  116.   begin
  117.   x:=0;
  118.   y:=0;
  119.   for i := 1 to MaxY do
  120.     for j := 1 to MaxX do
  121.       if c=M[i,j] then
  122.         begin
  123.         x:=j;
  124.         y:=i;
  125.         exit;
  126.         end;
  127.   end;
  128.  
  129. label M1;
  130. begin
  131. //переводим ключ и исходный текст в нижний регистр.
  132. key:=AnsiLowerCase(key);
  133. s:=AnsiLowerCase(s);
  134. //удаляем из строки все символы, не входящие в наш алфавит.
  135. temp:='';
  136. for i := 1 to length(s) do
  137.   begin
  138.   if pos(s[i],URusA)<>0 then temp:=temp+s[i];
  139.   end;
  140. s:=temp;
  141. //Создание ключевой матрицы, с использованием ключевого слова "key".
  142. temp:='';
  143. for i:=1 to length(key) do
  144.  if pos(key[i],temp)=0 then temp:=temp+key[i];
  145. for i:=1 to length(URusA) do
  146.  if pos(URusA[i],temp)=0 then temp:=temp+URusA[i];
  147. t:=0;
  148. for i:=1 to 5 do
  149.  for j:=1 to 6 do
  150.  begin
  151.  inc(t);
  152.  M[i,j]:=temp[t];
  153.  end;
  154.  
  155. temp:='';
  156. for i:=1 to length(s)div 2 do
  157.   begin
  158.   SimbolPos(s[2*i-1],x1,y1);
  159.   SimbolPos(s[2*i],x2,y2);
  160.   //Правило 1
  161.   if y1 = y2 then
  162.     begin
  163.     dec(x1); dec(x2);
  164.     if x1 <= 0 then x1:=x1+MaxX;
  165.     if x2 <= 0 then x2:=x2+MaxX;
  166.     temp:=temp+M[y1,x1]+M[y2,x2];
  167.     end;
  168.   //Правило 2
  169.   if x1 = x2 then
  170.     begin
  171.     dec(y1); dec(y2);
  172.     if y1 <= 0 then y1:=y1+MaxY;
  173.     if y2 <= 0 then y2:=y2+MaxY;
  174.     temp:=temp+M[y1,x1]+M[y2,x2];
  175.     end;
  176.   //Правило 3
  177.   if (x1<>x2) and (y1<>y2) then temp:=temp+M[y1,x2]+M[y2,x1];
  178.   end;
  179. Playfair_DeCrypt:=temp;
  180. end;
  181.  
  182.  
  183.  
  184.  
  185.  
Compilation error #stdin compilation error #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
compilation info 
prog.pas:1: warning: missing program header
prog.pas:2: warning: missing string capacity -- assuming 255
prog.pas: In function `Playfair_Crypt':
prog.pas:13: warning: missing string capacity -- assuming 255
prog.pas:35: error: undeclared identifier `AnsiLowerCase' (first use in this routine)
prog.pas:35: error:  (Each undeclared identifier is reported only once
prog.pas:35: error:  for each routine it appears in.)
prog.pas:53: error: undeclared identifier `form1' (first use in this routine)
prog.pas:69: warning: string comparison is always true due to different length of fixed-size strings
prog.pas: At top level:
prog.pas:99: warning: missing string capacity -- assuming 255
prog.pas: In function `Playfair_DeCrypt':
prog.pas:110: warning: missing string capacity -- assuming 255
prog.pas:132: error: undeclared identifier `AnsiLowerCase' (first use in this routine)
prog.pas:129: error: label `M1' not set
prog.pas:129: warning: label `M1' not used
prog.pas: At top level:
prog.pas:185: error: syntax error at end of input
stdout
copy 
Standard output is empty
https://ideone.com/24e641
language:
Pascal (gpc 20070904)
created:
5 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!