подсчитать буквы, можете исправить программу Опции

[maksimla]

дан головоломка ABCD+ABCD=EFGH где каждая разная буква записана под разным числом .
надо буквы изменить цифрами чтобы былобы правильное решение .напишите програму чтобы нашлабы всевозможные варьянты решения
написал програму но в ней ошибки есть помогите исправить ошибки

program galvosukis;
  type aibe = set of 0..9;
  var sakitmuo, m, u, h, a : 0..9;
      i, n1, n2 : integer;
      S1, S2 : aibe;
      f : boolean;
  procedure spausdink(x, y : integer);
  begin
    write(x);
    write(' + ');
    write(x);
    write(' = ');
    writeln(y);
    writeln;
  end;
begin
  S1 := [];
  for m := 0 to 9 do
    begin
      S1 := S1+[m];
      for u := 0 to 9 do
        if u in S1
          then
            begin
              S1 := S1+[u];
              for h := 0 to 9 do
                if h in S1
                  then
                    begin
                      S1 := S1+[h];
                        for a := 0 to 9 do
                          if a in S1
                            then
                              begin
                                S1 := S1+[a];
                                n1 := 1000*m+100*u+10*h+a;
                                n2 := n1;
                                f := true;
                                S2 := [];
                                for i := 0 to 9 do
                                  begin
                                    sakitmuo := n2 mod 1;
                                    n2 := n2 mod 10;
                                    f := n2 and sakitmuo in s2;
                                    S2 := [sakitmuo] + S2;
                                  end;
                                if (S1+S2=[ ]) and f
                                  then
                                    spausdink(n1, 2 * n1);
                                S1 := S1-[a];
                              end;
                     S1 := S1-[h];
                end;
            S1 := S1-[u];
        end;
      S1 := S1-[m];
    end;
      readln;
end.

[volvo]

Найди тему про ребусы (по словам "+fiat +motor" в поиске, всего 3 темы находит, смотри последнюю), там приведена корректно работающая программа. Достаточно будет только изменить буквы на твои и все.

О проблемах твоего кода: во-первых, у тебя запрограммировано не решение ребуса "ABCD+ABCD=EFGH", а решение с какой-то MUHA-ой... Во-вторых, условие начала цикла должно быть НЕ if u in S1 then, а обратным:
if not (u in S1) then ..., и так везде, по всем переменным кроме первой.

[klem4]

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

{$mode tp}
{$b-}
const alpha = 'abcdefgh';
var   palette: array [1..length( alpha )] of byte;

procedure dump(const s: string);
var
  i: byte;
begin
  for i := 1 to length(s) do write(palette[pos(s[i], alpha)]);
  writeln;
end;

function atoi( const s: string ): integer;
var
  i: byte;
  int, ten, pow, cvalue: longint;
begin
  int := 0;
  ten := 1;
  for i := length(s) downto 1 do begin
    cvalue := palette[ pos(s[i], alpha) ];
    inc(int, cvalue * ten);
    ten := ten * 10;
  end;
  atoi := int;
end;

function next_palette: boolean;
var i: byte;
begin
  i := length(palette) + 1;
  repeat
    dec(i);
    inc( palette[i]);
    if ( palette[i] > 9 ) then palette[i] := 0;
  until (palette[i] <> 0) or ((palette[i] = 0) and (i = 1));
  next_palette := palette[i] <> 0;
end;

procedure solve( const a, b, c: string);
var
  done: boolean;
  _a, _b, _c, i: longint;
begin
  fillchar( palette, sizeof(palette), 0);
  next_palette;

   repeat
     _a := atoi(a); _b := atoi(b); _c := atoi©;
   until (_a + _b = _c) or not (next_palette);

   if ( _a + _b = _c ) then begin
      dump(a); dump(b); dump©;
      writeln(_a, '+', _b, '=', _c);
      for i := 1 to length(alpha) do writeln(alpha[i], '=', palette[i]);
   end else writeln('no');
end;

begin
  solve('abcd', 'abcd', 'efgh');
end.

[volvo]

Ну, попробуй твоим "решателем" разгадать ребус VOLVO+FIAT=MOTOR...

Добавлено через 7 мин.
P.S. Здесь: Множества -> Ребусы лежит универсальный решатель, но только рекурсивный... Находит все 92 возможных решения...

[klem4]

const alpha = 'volfiamtr';
...
function atoi( const s: string ): longint; // вместо integer
...
 solve('volvo', 'fiat', 'motor');

Код

C:\FPC\2.2.2\bin\i386-win32>forum1.exe
00000
0101
00101
0+101=101
v=0
o=0
l=0
f=0
i=1
a=0
m=0
t=1
r=1

[volvo]

И что это? Где ответ? Показать тебе правильные решения?

[klem4]

А почему это нерпавильное ?

volvo=00000 === 0
fiat = 0101 === 101
motor = 00101 === 101

0 + 101 = 101

[volvo]

Потому что

каждая разная буква записана под разным числом

. А у тебя? V = L ??? И так далее?

[klem4]

Понятно.

[maksimla]

а мне чтоли так надо было исправить

program galvosukis;
  type aibe = set of 0..9;
  var sakitmuo, a,b,c,d : 0..9;
      i, n1, n2 : integer;
      S1, S2 : aibe;
      f : boolean;
  procedure spausdink(x, y : integer);
  begin
    write(x);
    write(' + ');
    write(x);
    write(' = ');
    writeln(y);
    writeln;
  end;
begin
  S1 := [0];
  for a := 0 to 9 do
    begin
      S1 := S1+[a];
      for b := 0 to 9 do
        if  not(b in S1)
          then
            begin
              S1 := S1+[b];
              for c := 0 to 9 do
                if not (c in S1)
                  then
                    begin
                      S1 := S1+[c];
                        for a := 0 to 9 do
                         if not (d in S1)
                            then
                              begin
                                S1 := S1+[d];
                                n1 := 1000*a+100*b+10*c+d;
                                n2 := n1;
                                f := true;
                                S2 := [];
                                for i := 0 to 9 do
                                  begin
                                    sakitmuo := n2 mod 1;
                                    n2 := n2 mod 10;
                                    f := n2 and sakitmuo in s2;
                                    S2 := [sakitmuo] + S2;
                                  end;
                                if (S1+S2=[ ]) and f
                                  then
                                    spausdink(n1, 2 * n1);
                                S1 := S1-[d];
                              end;
                     S1 := S1-[c];
                end;
            S1 := S1-[b];
        end;
      S1 := S1-[a];
    end;
      readln;
end.

но серавно тут неправильно идет

Сообщение отредактировано: maksimla - 28.02.2009 18:02

[volvo]

а мне чтоли так надо было исправить

Нет, тебе надо было сделать так:

program galvosukis;
  type aibe = set of 0..9;
  var sakitmuo, a,b,c,d, e,f,g,h : 0..9;
      i, n1, n2 : integer;
      S1: aibe;

  procedure spausdink(x, y : integer);
  begin
    write(x);
    write(' + ');
    write(x);
    write(' = ');
    writeln(y);
  end;
begin
  S1 := [];
  for a := 0 to 9 do begin
    S1 := S1+[a];
    for b := 0 to 9 do if not (b in S1) then begin
      S1 := S1+[b];
      for c := 0 to 9 do if not (c in S1) then begin
        S1 := S1+[c];
        for d := 0 to 9 do if not (d in S1) then begin
          S1 := S1+[d];
          for e := 0 to 9 do if not (e in S1) then begin
            s1 := s1+[e];
            for f := 0 to 9 do if not (f in S1) then begin
              S1 := S1+[f];
              for g := 0 to 9 do if not (g in S1) then begin
                s1 := s1+[g];
                for h := 0 to 9 do if not (h in S1) then begin
                  s1 := s1+[h];

                  n1 := 1000*a+100*b+10*c+d;
                  n2 := 1000*e+100*f+10*g+h;
                  if n1 + n1 = n2 then spausdink(n1, n2);

                  s1 := s1-[h];
                end;
                s1 := s1-[g];
              end;
              s1 := s1-[f];
            end;
            s1 := s1-[e];
          end;
          s1 := s1-[d];
        end;
        s1 := s1-[c];
      end;
      S1 := S1-[b];
    end;
    S1 := S1-[a];
  end;
  readln;
end.

[Vinchkovsky]

А разве не достаточно сделать 4-х уровневый цикл, а остальные буквы получить с полученного числа? Как-то так:

for a:=0 to 9 do
 for b:=0 to 9 do
  if not (b in [a]) then
   for c:=0 to 9 do
    if not (c in [a,b]) then
     for d:=0 to 9 do
      if not (d in [a,b,c]) then
        begin
          result:=(1000*a+100*b+10*c+d)*2;
          if result<10000 then
            begin
              e:=result div 1000;
              result:=result mod 1000;
              f:=result div 100;
              result:=result mod 100;
              g:=result div 10;
              h:=result mod 10;
              if (not (e in [a,b,c,d,f,g,h])) and (not (f in [a,b,c,d,e,g,h])) and
              (not (g in [a,b,c,d,f,e,h])) and (not (h in [a,b,c,d,f,g,e])) then
              writeLn(a,' ',b,' ',c,' ',d,' ',e,' ',f,' ',g,' ',h)
            end;
        end;
  readln
end.

Да и можно сократить пределы поиска вдвое (а - от 0 до 4-х)


Сообщение отредактировано: Vinchkovsky - 28.02.2009 19:13

[maksimla]

спасибо всем за помощь

[maksimla]

вопрос образовался у меня а это что вы мне помогли ошибки исправить будит программа с поиском в глубину?