• Ребус
  REBUS
  
  Условие  Комментарии  Решение  Тестовые файлы  Оглавление

Описание
Арифметический ребус - это зашифрованная запись сложения двух натуральных чисел (например, КОМП+КОМП=СБОРЫ). При этом одинаковым буквам должны соответствовать одинаковые цифры, разным - разные, и ни одно из чисел не может начинаться с нуля

Задание
Требуется написать программу, находящую все возможные решения такого ребуса


Входные данные
Входной файл содержит единственную строку с записью ребуса. Длина строки не превышает 30 символов

Выходные данные
Первая строка выходного файла должна содержать число возможных решений ребуса, а остальные - список решений в алфавитном порядке. Каждое решение должно быть выведено не более одного раза


Например:

REBUS.IN
ЛЕТО+ЛЕТО=ПОЛЕТ

REBUS.OUT
1
8947+8947=17894
 

Комментарии
Логично организовать перебор, переходя от младших разрядов к старшим. В процессе перебора для каждой еще не известной буквы храним множество значений, которые она может принимать. По виду ребуса можно сразу же сделать некоторые заключения. Например, первая буква числа не может равняться нулю. Если длина суммы на единицу больше, чем длина наибольшего из слагаемых, то первой ее цифрой может быть только единица. Если на i-ом месте первого числа стоит буква А, а на i-ом месте второго числа и суммы стоит буква В, то значением А может быть только 0 или 9, и т.д.



Решение
 
{.$define DEBUG}
{$M 64000,0,0}
 
program rebus;
 
{$ifndef DEBUG}
{$A-,B-,D+,E-,F-,G+,I+,L+,N+,O-,P-,Q-,R-,S-,T-,V-,X+,Y+}
const
  inFile= 'rebus.in';
  outFile= 'rebus.out';

{$else}
{$A-,B-,D+,E-,F-,G+,I+,L+,N+,O-,P-,Q+,R+,S+,T-,V-,X+,Y+}
const
  inFile= 'rebus.in';
  outFile= 'con';
  dbgFile= 'con';
var
  dbg: Text;
{$endif}
 
const
  maxA= 2000;
  maxL = 31;
  alpha = [#0..#255] - [#10,#13,'+','=','*'];
 
type
  TStr  = string[maxL];
  TInt  = array[1..maxL] of shortint;
  TSet  = set of 0..9;

var
  expr : TStr;
  l : integer;
  a,b,c : TStr;
  ia,ib,ic : TInt;
  d : array[char] of shortint;
  s : TSet;
  nAnswers : integer;
  answer : array[1..maxA] of TStr;
 
function FormatInt(var k : TInt) : string;
var
  s : string;
  i : integer;
begin
  i := maxL;
  while k[i] = 0 do dec(i);
  s := '';
  while i > 0 do begin
    s := s + chr(k[i] + ord('0'));
    dec(i);
  end;
  FormatInt := s;
end;
 
function GetToken( var s : string ) : string;
var
  r : string;
begin
  r := '';
  repeat
    if not (s[1] in alpha) then break;
    r := r + s[1];
    delete(s, 1, 1);
  until false;
  delete(s, 1, 1);
  GetToken := r;
end;
 
procedure Update(ch : char; v : shortint);
var
  i : integer;
begin
  for i := 1 to length( a ) do
    if a[i] = ch then ia[i] := v;
  for i := 1 to length( b ) do
    if b[i] = ch then ib[i] := v;
  for i := 1 to length( c ) do
    if c[i] = ch then ic[i] := v;
end;
 
procedure Rec(k : integer; delta : integer);
var
  u,v : integer;
  x : integer;
  fa,fb,fc : boolean;
begin
  if k > maxL then begin
    if (ia[length(a)] <> 0) and
       (ib[length(b)] <> 0) and
       (ic[length(c)] <> 0) then begin
      inc( nAnswers );
      answer[nAnswers] := FormatInt(ia) + '+' +
                          FormatInt(ib) + '=' +
                          FormatInt(ic);
    end;
    exit;
  end;
 
  for u := 0 to 9 do
    if (not (u in s) and (ia[k] = -1)) or (ia[k] = u) then begin
      fa := false;
      if ia[k] = -1 then begin
        include(s, u);
        Update(a[k], u);
        fa := true;
      end;
 
      for v := 0 to 9 do
        if (not (v in s) and (ib[k] = -1)) or (ib[k] = v) then begin
          fb := false;
          if ib[k] = -1 then begin
            include(s, v);
            Update(b[k], v);
            fb := true;
          end;
          x := u + v + delta;
          if ((ic[k] = -1) and not ((x mod 10) in s)) or
             (ic[k] = x mod 10) then begin
            fc := false;
            if ic[k] = -1 then begin
              include(s, x mod 10);
              Update(c[k], x mod 10);
              fc := true;
            end;
 
            Rec(k + 1, x div 10);
 
            if fc then begin
              exclude(s, x mod 10);
              Update(c[k], -1);
            end;
          end;
 
          if fb then begin
            exclude(s, v);
            Update(b[k], -1);
          end;
        end;
 
      if fa then begin
        exclude(s, u);
        Update(a[k], -1);
      end;
    end;
end;
 
procedure StrRev( var s : string );
var
  i : integer;
  ch : char;
begin
  for i := 1 to length( s ) div 2 do begin
    ch := s[i];
    s[i] := s[length(s)-i+1];
    s[length(s)-i+1] := ch;
  end;
end;
 
procedure HeapSort;
var
  i,j,l,r : integer;
  xx : TStr;
 
  procedure Sift;
  begin
    i := l;
    j := l * 2;
    xx := answer[i];
    if (j < r) and (answer[j] < answer[j+1]) then inc( j );
    while (j <= r) and (answer[j] > xx) do begin
      answer[i] := answer[j];
      i := j;
      j := j * 2;
      if (j < r) and (answer[j] < answer[j+1]) then inc( j );
    end;
    answer[i] := xx;
  end;
 
begin
  r := nAnswers;
  for l := nAnswers div 2 downto 1 do Sift;
  while r > 1 do begin
    xx := answer[1];
    answer[1] := answer[r];
    answer[r] := xx;
    dec(r);
    Sift;
  end;
end;
 
procedure Solve;
begin
  expr := expr + '*';
  a := GetToken(expr);
  b := GetToken(expr);
  c := GetToken(expr);
  StrRev(a);
  StrRev(b);
  StrRev(c);
  fillchar(d, sizeof(d), $ff);
  fillchar(ia, sizeof(ia), 0);
  fillchar(ib, sizeof(ib), 0);
  fillchar(ic, sizeof(ic), 0);
  fillchar(ia, length(a), $ff);
  fillchar(ib, length(b), $ff);
  fillchar(ic, length(c), $ff);
  s := [];
  nAnswers := 0;
  Rec(1, 0);
  HeapSort;
end;
 
procedure ReadData;
begin
  readln(expr);
end;
 
procedure WriteData;
var
  i : integer;
begin
  writeln(nAnswers);
  for i := 1 to nAnswers do
    writeln(answer[i]);
end;
 
procedure Initialize;
begin
  assign(input, inFile);
  reset(input);
 
  assign(output, outFile);
  rewrite(output);
 
  {$ifdef DEBUG}
  assign(dbg, dbgFile);
  rewrite(dbg);
  {$endif}
end;
 
procedure Finalize;
begin
  close(input);
  close(output);
 
  {$ifdef DEBUG}
  close(dbg);
  {$endif}
 
  halt(0);
end;
 
begin
  Initialize;
  ReadData;
  Solve;
  WriteData;
  Finalize;
end.

© Особенности национальных задач по информатике