Универсальная программа для решения арифметических ребусов

{.$define DEBUG}
{$M 64000,0,0}
 
program Solution;
 
{$ifndef DEBUG}
{$A-,B-,D+,E-,F-,G+,I+,L+,N+,O-,P-,Q-,R-,S-,T-,V-,X+,Y+}
const
  inFile                        = 'input.txt';
  outFile                       = 'output.txt';
{$else}
{$A-,B-,D+,E-,F-,G+,I+,L+,N+,O-,P-,Q+,R+,S+,T-,V-,X+,Y+}
const
  inFile                        = 'input1.txt';
  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.