Шифр "Тарабарщина" - замена одних букв другими, помогите составить программу Опции

[Drughi]

Итак, начну с определения Тарабарщины

Тарабарская грамота, простая литорея — шифр, широко использовавшийся в древнерусских рукописях.

Представляет собой простейший шифр замены без ключа. Согласные в алфавите делят на две равные части, и первую пишут строкой в алфавитном порядке, а вторую под буквами первой в обратном порядке. Таким образом получают таблицу:

б в г д ж з к л м н
щ ш ч ц х ф т с р п


Употребляют в письме верхние буквы вместо нижних и наоборот, а гласные остаются без изменения. Так, например, словарь на тарабарской грамоте будет лсошамь, великий государь — шеситий чолуцамь и т. п. Для расшифровки используют тот же способ, что и для шифрования (шифр симметричный).


Мне нужно написать программу, которая переводит шифрованный текст в обычный.

Например, "Шещ-нмочмарримошапие" будет звучать как "Веб-программирование"

Как реализовать данную задачу в Pascal ABC?

Спасибо!

[volvo]

Ну, например так: (Показать/Скрыть)

function Tarabar(s : string) : string;
const
   alpha : array[boolean] of string = 
   ('БВГДЖЗКЛМН', 'ЩШЧЦХФТСРП');
   
var
   p : integer;
   Changed : boolean;
   
begin
   for i : integer := 1 to length(s) do
   begin
      Changed := false;
      for b : boolean := false to true do
      begin
         p := pos(UpperCase(s[ i ]), alpha[ b ]);
         Changed := p > 0;
         if Changed then
         begin
            if UpperCase(s[ i ]) = s[ i ] then result := result + alpha[not b][p]
            else result := result + LowerCase(alpha[not b][p]);
            break;
         end;
      end;
      
      if not Changed then result := result + s[ i ];
   end;
end;

const
   before : string = 'Веб-программирование';
var
   after : string;

begin
   after := tarabar (before);
   writeln (after);
   after := tarabar (after);
   writeln (after);
end.

Странно, но работает:

[Drughi]

Ну, например так: (Показать/Скрыть)

function Tarabar(s : string) : string;
const
   alpha : array[boolean] of string = 
   ('БВГДЖЗКЛМН', 'ЩШЧЦХФТСРП');
   
var
   p : integer;
   Changed : boolean;
   
begin
   for i : integer := 1 to length(s) do
   begin
      Changed := false;
      for b : boolean := false to true do
      begin
         p := pos(UpperCase(s[ i ]), alpha[ b ]);
         Changed := p > 0;
         if Changed then
         begin
            if UpperCase(s[ i ]) = s[ i ] then result := result + alpha[not b][p]
            else result := result + LowerCase(alpha[not b][p]);
            break;
         end;
      end;
      
      if not Changed then result := result + s[ i ];
   end;
end;

const
   before : string = 'Веб-программирование';
var
   after : string;

begin
   after := tarabar (before);
   writeln (after);
   after := tarabar (after);
   writeln (after);
end.

Странно, но работает:

А почему странно?
Большое спасибо за решение этой задачи. Но оказывается, есть и более простое решение.
В любом случае, большое спасибо вам! Очень помогли!

[Lapp]

А почему странно?

Думаю, потому что ABC не очень склонен к этому занятию - работать.. ))

Но оказывается, есть и более простое решение.

Поделишься?

[Drughi]

Конечно!

var
s: string;
i,k: integer;
begin
WriteLn('Введите строку:');
ReadLn(s);
k:=length(s);
for i:=1 to k do
case s[i] of
'б': s[i]:='щ';
'в': s[i]:='ш';
'г': s[i]:='ч';
'д': s[i]:='ц';
'ж': s[i]:='х';
'з': s[i]:='ф';
'к': s[i]:='т';
'л': s[i]:='с';
'м': s[i]:='р';
'н': s[i]:='п';

'щ': s[i]:='б';
'ш': s[i]:='в';
'ч': s[i]:='г';
'ц': s[i]:='д';
'х': s[i]:='ж';
'ф': s[i]:='з';
'т': s[i]:='к';
'с': s[i]:='л';
'р': s[i]:='м';
'п': s[i]:='н';
{Если необходимо то сделайте и для строчных букф так же}
end;
Write(s);
end.

[TarasBer]

И чем оно проще? Длинный выбор.
Типичный ГК.

Вариант Вольво лучше наличием 2х массивов, но для каждой буквы перебором искать, входит ли она в массив - это тоже не лучший вариант.
+ наращивание по 1 там, где можно обойтись + проверка на регистр - всё это можно убрать

var NewChar: array [char] of char; // сразу составляем массив замены
const alpha: array [boolean] of string = ('бвгджзклмн', 'щшчцхфтсрп'); // ну эти нам тоже пригодятся

procedure InitTarabar;
begin
  for c: char := #0 to #255 do NewChar[c] := c; // сначала массив замены заполняем так, будто ничего заменять не надо
  for b: boolean := false to true do begin
    for i: integer := 1 to Length(alpha[b]) do begin
      NewChar[alpha[b,i]] := alpha[not b,i];  // проходим по строке и делаем замены в массиве
      NewChar[UpCase(alpha[b,i])] := UpCase(alpha[not b,i]);
    end;
  end;
end;

function Tarabar(s: string): string;
begin
  SetLength(result, Length(s));
  for i: integer := 1 to Length(s) do Result[i] := NewChar[s[i]];
end;

var s: string;

begin
  InitTarabar;
  repeat
    Write('Введите строку (или "exit" для выхода): ');
    ReadLn(s);
    WriteLn(Tarabar(s));
  until s = 'exit';
end.

В начале программы пишем InitTarabar (для каждой строки это делать не надо), а потом уже используем, вызывая функцию Tarabar(s).

Сообщение отредактировано: TarasBer - 18.02.2011 10:43

[volvo]

+ наращивание по 1 там, где можно обойтись + проверка на регистр - всё это можно убрать

Может и можно, но программа писалась для реалий Pascal ABC. Твой код он не компилирует. Тот, который я набросал изначально - тоже. Пришлось делать так, "чтоб заработало".

[TarasBer]

> Твой код он не компилирует. Тот, который я набросал изначально - тоже. Пришлось делать так, "чтоб заработало".

Там что, нету SetLength?

[volvo]

Есть. Проблема была в другом. Поправил. Но не работает (я ж говорю - это ABC, тут если заработало - то "внезапно", и "странно") :

[TarasBer]

Я не знаю, почему так.
УМВР в Д7 (только переменные циклов пришлось наружу объявить).