Буквенно-цифровые ребусы, рекурсия, решение любых ребусов Опции

[Lapp]

Недавно снова попалась мне на глаза задачка типа "решить ТОЧКА+КРУГ=КОНУС", вместе с решением. И, как обычно, это решение вызвало у меня внутреннее отвращение.. ага, набор переменных: t,o,c,k,a, r,u,g,.. Тоска, короче )). Программирование для арифмометра. Я думаю, вы уже поняли, что я сделал.. А потом я подумал - чего добру пропадать? забацаю-ко я темку.. Но, как человек, претендующий на корректность по отношению к другим, я сначала запустил поиск по "ребус*" на нашем Форуме..

Моему вниманию открылся список тем, многие из которых были вполне по предмету. Идя по ним, я все больше утверждался в мнении, что, по крайней мере, тут подобный подход не применялся - пока, наконец, не наткнулся на это сообщение:
помогите решить ребус!

Sir volvo снова меня опередил! Но - что интересно! - на этот пост нет ни одного ответа ((. И, более того, после этого все снова и снова предлагались "решения" по типу "тоска", описанному выше.. Я, конечно, не упустил своей (не такой уж редкой, впрочем)) возможности поставить +1 автору, но хочу спросить его: volvo, почему ты даже не упомянул там ГЛАВНОГО?? Ведь главное, ессно, не то, что циклы заменены на рекурсию!! А то, что этот код годится для решения ЛЮБЫХ ребусов вида a+b=c! Достаточно просто заменить входные строки.. ))

Итак, ближе к делу.. Признавая первенство volvo, я все же публикую свой код (причем в новой теме, которую предполагаю в дальнейшем двинуть в FAQ). Этот код имеет некоторые преимущества (которые, я уверен, volvo мог бы легко добавить при желании), а именно: допустимы несколько знаков операций (как слева, так и справа от знака = ), в том числе +, -, *, / (без приоритетов). Ну и по мелочам, типа русские буквы..

Вот, собсно, код (писался под FP):

REBUS v.1.0 (Показать/Скрыть)

// REBUS Ver.1.0
// by Lapp
// forum.pascal.net.ru

const
  s: string = '';
  Alph: set of char= ['A'..'Z']+['А'..'Я'];
 
type
  tCS= set of char;
  tBS= set of byte;
 
var
  d: array ['A'..'Я'] of byte;  // Lat 'A' through Rus 'Я'
  Op: char;
  a,b,x,n: longint;
 
procedure Next(i: integer; a,b,x: longint; Op: char; UsedC: tCS; UsedD: tBS);
  procedure Calculate(c: char);
  begin
    case Op of
      '+': a:= a+x;
      '-': a:= a-x;
      '*': a:= a*x;
      '/': a:= a div x;
    end;
    if c='=' then begin
      Op:='+';
      b:=a;
      a:=0;
    end
    else Op:=c;
    x:=0
  end;
var
  j: integer;
begin
  if i>Length(s) then begin
    Calculate(' ');
    if a=b then begin
      for j:=1 to Length(s) do if s[j] in Alph then write(d[s[j]]) else write(s[j]);
      writeln;
      Inc(n)
    end
  end
  else case s[i] of
    'A'..'Z','А'..'Я': if s[i] in UsedC then begin
      if (x>0) or (d[s[i]]>0) then Next(i+1,a,b,x*10+d[s[i]],Op,UsedC,UsedD)
    end
    else for j:=0 to 9 do if not (j in UsedD) then begin
      d[s[i]]:=j;
      Next(i,a,b,x,Op,UsedC+[s[i]],UsedD+[j])
    end;
    '+','-','*','/','=': begin
      Calculate(s[i]);
      Next(i+1,a,b,x,Op,UsedC,UsedD)
    end;
    else Next(i+1,a,b,x,Op,UsedC,UsedD)
  end
end;
 
var
  i: integer;
 
begin
  if s='' then begin
    write('Введите формулировку ребуса: ');
    readln(s)
  end;
  for i:=1 to Length(s) do begin
    s[i]:=UpCase(s[i]);
    case s[i] of
      'а'..'п': Dec(s[i],32);
      'р'..'я': Dec(s[i],80)
    end
  end;
  n:=0;
  Next(1,0,0,0,'+',[],[]);
  writeln('found ',n,' solutions');
  readln
end.

Если у кого-то есть вопросы/критика по коду - милости прошу.

Казалось бы - все, но есть еще один аспект этого вопроса. И про него я сейчас создам тему в разделе Свободное Общение.. ))
(тема создана: Конкурс ребусов! )

[Lapp]

Размещаю новую версию программы, разгадывающей ребусы.
Что нового:

1. Интерфейс. Теперь в начале выдается информация о том, сколько присутствует различных букв. Мне кажется, это полезно (так как надо следить, чтоб их число не превзошло 10).

2. Теперь можно использовать и цифры! Цифры, конечно, просто имеют свои значения. Например, ребус:
a*3-5=7
- имеет одно решение:
4*3-5=7
(помним, что решением называется ВСЯ строка).
В связи с этим интересная особенность: ребус, составленный из одних только цифр (без букв) может служить для проверки верности соотношения. И это совсем нелишне, потому что не каждый калькулятор сделает вам вычисления БЕЗ учета приоритетов операций!

3. Исправлена небольшая ошибка (умножение и деление фактически не работали, извиняюсь..) - отсутствовали символы * и / в операторе CASE (исправления уже внесены в предыдущий пост, так что тот код тоже верен теперь).

Итак, прошу любить и жаловать:

REBUS v.1.1 (Показать/Скрыть)

// REBUS
// v.1.1
// by Lapp
// forum.pascal.net.ru

const
  s: string =
    //'abc+cde-2f=g*h' +  // уберите первые "//", чтобы отлаживаться на этой строке
    '';
  Alph: set of char= ['A'..'Z']+['А'..'Я'];
  Rus: array ['А'..'Я'] of char = 'абвгдежзийклмнопрстуфхцчшщъыьэюя';

type
  tCS= set of char;
  tBS= set of byte;

var
  d: array ['A'..'Я'] of byte;  // Lat 'A' through Rus 'Я'
  Op: char;
  a,b,x,n: longint;

procedure Next(i: integer; a,b,x: longint; Op: char; UsedC: tCS; UsedD: tBS);
  procedure Calculate(c: char);
  begin
    case Op of
      '+': a:= a+x;
      '-': a:= a-x;
      '*': a:= a*x;
      '/': a:= a div x;
    end;
    if c='=' then begin
      Op:='+';
      b:=a;
      a:=0;
    end
    else Op:=c;
    x:=0
  end;
var
  j: integer;
begin
  if i>Length(s) then begin
    Calculate(' ');
    if a=b then begin
      for j:=1 to Length(s) do if s[j] in Alph then write(d[s[j]]) else write(s[j]);
      writeln;
      Inc(n)
    end
  end
  else case s[i] of
    'A'..'Z','А'..'Я': if s[i] in UsedC then begin
      if (x>0) or (d[s[i]]>0) then Next(i+1,a,b,x*10+d[s[i]],Op,UsedC,UsedD)
    end
    else for j:=0 to 9 do if not (j in UsedD) then begin
      d[s[i]]:=j;
      Next(i,a,b,x,Op,UsedC+[s[i]],UsedD+[j])
    end;
    '0'..'9': Next(i+1,a,b,x*10+Ord(s[i])-48,Op,UsedC,UsedD);
    '+','-','*','/','=': begin
      Calculate(s[i]);
      Next(i+1,a,b,x,Op,UsedC,UsedD)
    end;
    else Next(i+1,a,b,x,Op,UsedC,UsedD)
  end
end;

var
  i,m: integer;
  Letters: set of char;

begin
  if s='' then begin
    write('Введите формулировку ребуса: ');
    readln(s)
  end
  else WriteLn('Решаем ребус: ',s);
  for i:=1 to Length(s) do begin
    s[i]:=UpCase(s[i]);
    case s[i] of
      'а'..'п': Dec(s[i],32);
      'р'..'я': Dec(s[i],80)
    end
  end;
  for i:=1 to Length(s) do
    if (s[i] in Alph) and not (s[i] in Letters) then begin
      Inc(m);
      Letters:= Letters+[s[i]]
    end;
  writeln('В выражении содержится ',m,' различных букв');
  if m<=10 then begin
    n:=0;
    Next(1,0,0,0,'+',[],[]);
    writeln('found ',n,' solutions')
  end
  else writeln('Задача неразрешима');
  readln
end.

[Cheburashka]

Первый раз использовал Вашу программу (1.1) и сразу заметил невообразимое!
Ввёл последовательность Ножницы+Бумага=Кусочки.
В итоге мне говорится что тут 14 решений И на следующей строке выводится надпись "Задача не разрешима"
Пользуюсь Borland Pascal'ем

Извиняюсь за вопрос) Повнимательней взглянул на алгоритм, я понял, что решений должно быть меньше 10.

Сообщение отредактировано: Cheburashka - 19.01.2011 17:40

[volvo]

В итоге мне говорится что тут 14 решений

Не 14 решений, а 14 разных букв... Именно поэтому задача и неразрешима.

Только если в 16-ричной СС решать ребусы