8 ферзей

[battlefrogg]

Задача о восьми ферзях. Расставить их так, чтобы они не могли уничтожить друг друга.

Помогите понять почему у меня не работает как нужно функция Check. Скорее тут глупая ошибка, но я уже долго ее не могу найти. Например на вход в ф-цию поступает значения 7 - 2, которые должны быть False (т.к. на 81 стоит 1 ферзь). Вот код

program queens;

var field: array [1..8, 1..8] of boolean;     
    i, j : byte;
    buf: array [1..8] of byte;                

function Check(x, y: byte): boolean; //* Та самая неработающая ф-ция
var i, j: byte;
begin
Check:= true;
for j:= y + 1 to 8 do
  begin
    i:= x + j - y;                             //* По диаг вверх
    if (i > 8) or (j > 8) then break;
    if field[i, j] = true then Check:= false
    else Check:= true;
  end;
i:= x;
for j:= y - 1 downto 1 do
  begin
    i:= i + 1;
    if (i > 8) or (j > 8) or (j = 0) then break;            //* По диаг вниз
    if field[i, j] = true then Check:= false
    else Check:= true;
  end;
for i:= x + 1 to 8 do
  begin
    if i > 8 then break;                            //* По горизонтали
    if field[i, y] = true then Check:= false
    else Check:= true;
  end;
end;

procedure Print(field: array [1..8, 1..8] of boolean);  //* Вывод
begin
for j:= 8 downto 1 do
  begin
    for i:= 1 to 8 do
    if field[i, j] = true then write(' Ô ') else write(' - ');
    if i = 8 then writeln;
  end;
end;

begin
for i:= 8 downto 1 do
  begin
    for j:= 1 to 8 do
    begin
    if Check(i, j) = true then               //* Ищем локальное решение
      begin
        field[i, j]:= true;
        buf[i]:= j;                          //* Запоминаем решение
        break;
      end;
    end;
    if Check(i, 8) = false then  
      begin
        if i <> 8 then i:= i + 1;
        j:= buf[i] + 1;
        field[i, j - 1]:= false;
      end;
    {writeln(Check(i, j));
    writeln(i, j);           // Алгоритм проверки
    Print(field);
    readln; }
  end;
Print(field);
end.

[battlefrogg]

Нашел ошибку в функции, однако программа все еще не работает как надо: цикл застревает на 7.3

function Check(x, y: byte): boolean;
begin
Check:= true;
for j:= y + 1 to 8 do
  begin
    i:= x + j - y;                            
    if (i > 8) or (j > 8) then break;
    if field[i, j] = true then
      begin
        Check:= false;
        exit;
      end;
  end;
i:= x;
for j:= y - 1 downto 1 do
  begin
    i:= i + 1;
    if (i > 8) or (j > 8) or (j = 0) then break;            
    if field[i, j] = true then
      begin
        Check:= false;
        exit;
      end;
  end;

[battlefrogg]

Все, почти решил. Только 1 ферзь куда то пропадает( Теперь как мне ее оптимизировать?

program queens;

var field: array [1..8, 1..8] of boolean;     //* Èãðàþò ðîëü ëèøü ïîëÿ
    i, j: byte;
    buf, ERR: array [1..8] of byte;                //* Âðåìåííîå ðåøåíèå ïî Y

function Check(x, y: byte): boolean; //*Ïðîâåðÿåì ïîëÿ
var i, j: byte;
begin
Check:= true;
for j:= y + 1 to 8 do
  begin
    i:= x + j - y;                             //* Ñìåùåíèå ïî âåðòèêàëè ââåðõ
    if (i > 8) or (j > 8) then break;
    if field[i, j] = true then
      begin
        Check:= false;
        exit;
      end;
  end;
i:= x;
for j:= y - 1 downto 1 do
  begin
    i:= i + 1;
    if (i > 8) or (j > 8) or (j = 0) then break;  //* Ñìåùåíèå ïî âåðòèêàëè âíèç
    if field[i, j] = true then
      begin
        Check:= false;
        exit;
      end;
  end;
for i:= x + 1 to 8 do
  begin
    if i > 8 then break;                            //* Ñìåùåíèå ïî ãîðèçîíòàëè
    if field[i, y] = true then
      begin
        Check:= false;
        exit;
      end;
  end;
end;

procedure Print(field: array [1..8, 1..8] of boolean);  //* Âûâîä
begin
for j:= 8 downto 1 do
  begin
    for i:= 1 to 8 do
    if field[i, j] = true then write(' Ô ') else write(' - ');
    if i = 8 then writeln;
  end;
end;

begin
for i:= 8 downto 1 do
  begin
    for j:= 1 to 8 do
    begin
    writeln(i, j);
    writeln(Check(i, j));
    if Check(i, j) = true then               //* Íàõîäèì ÷àñòíîå ðåøåíèå
      begin
        field[i, j]:= true;
        buf[i]:= j;                   //* Çàïîìèíàåì åãî
        break;
      end else ERR[i]:= ERR[i] + 1;
     //* Åñëè äîøëè äî êîíöà
     if ERR[i] = 8 then
       begin
         if i <> 8 then i:= i + 1;
         j:= buf[i] + 1;
         field[i, j - 1]:= false;
       end;
    end;
  end;
Print(field);
end.

[Grag]

Зайди на мой сайт по ссылке http://igor-bachin.narod.ru/Pages/pfolio3.htm
Там есть архив с программой и исходниками, как раз твоя задача. Программу запускай в полноэкранном режиме. Не забудь оставить благодарность в гостевой книге!!!

[battlefrogg]

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

program queens;

var field: array [1..8, 1..8] of boolean;          //* Играют роль лишь клетки
    i, j: byte;
    buf, ERR: array [1..8] of byte;                //* Временное решение по Y и число ошибок на столбце

function Check(x, y: byte): boolean;               //*Функция проверки
var i, j: byte;
begin
Check:= true;
for j:= y + 1 to 8 do
  begin
    i:= x + j - y;                                 //* Сдвиг вправо вверх
    if (i > 8) or (j > 8) then break;
    if field[i, j] = true then
      begin
        Check:= false;
        exit;
      end;
  end;
i:= x;
for j:= y - 1 downto 1 do
  begin
    i:= i + 1;
    if (i > 8) or (j > 8) or (j = 0) then break;   //* Сдвиг вправо вниз
    if field[i, j] = true then
      begin
        Check:= false;
        exit;
      end;
  end;
for i:= x + 1 to 8 do
  begin
    if i > 8 then break;                           //* Сдвиг вправо
    if field[i, y] = true then
      begin
        Check:= false;
        exit;
      end;
  end;
end;

procedure Print(field: array [1..8, 1..8] of boolean);  //* Вывод
begin
for j:= 8 downto 1 do
  begin
    for i:= 1 to 8 do
    if field[i, j] = true then write(' Ф ') else write(' - ');
    if i = 8 then writeln;
  end;
end;

begin
writeln('Введите Y координату 8 ферзя');
readln(j);
field[8, j]:= true;
for i:= 7 downto 1 do
  begin
    for j:= 1 to 8 do
    begin
    if Check(i, j) = true then               //* Находим частное решение
      begin
        field[i, j]:= true;
        buf[i]:= j;                          //* Запоминаем его
        break;
      end else ERR[i]:= ERR[i] + 1;
     if ERR[i] >= 8 then                     //* Все клетки с ошибками, откат
       begin
         ERR[i]:= 0;
         if i <> 8 then i:= i + 1;
         j:= buf[i];
         field[i, j]:= false;
         ERR[i]:= ERR[i] + 1;
         if buf[i] = 8 then j:= 0;
       end;
    end;
  end;
Print(field);
end.

[Grag]

Молодец! Так дальше и действуй! Свое - оно и есть свое!