Другие языки программирования и технологии

Задача ферзей. Pascal abc

Известно, что на доске 8×8 можно расставить 8 ферзей так, чтобы они не били друг друга. Вам дана расстановка 8 ферзей на доске, определите, есть ли среди них пара бьющих друг друга.

Программа получает на вход восемь пар чисел, каждое число от 1 до 8 — координаты 8 ферзей. Если ферзи не бьют друг друга, выведите слово NO, иначе выведите YES.
Ферзи с координатами x1,y1 и x2,y2 бьют друг друга, если истинно выражение:

((x1 - x2) * (y1 - y2) = 0) or (abs(x1 - x2) = abs(y1 - y2))
Сделал веселую игрушку по мотивам вопроса))
Расставляет на случайные клетки ферзей и проверяет, бьют ли они друг друга.
Если ферзь никого не бьет - он беленький, иначе - красненький.
На левую кнопку мыши жмешь - генерирует случайный вариант расстановки.
На правую - перебирает случайные варианты пока не найдется такой, чтобы ферзи не били друг друга.
Сносное время ожидания при таком поиске: 5-6 ферзей..)

Сама программа:

program PascalABCdotNET;
uses GraphABC, Events;
const N = 5; // количество ферзей
var queen: array[1..8, 1..8] of boolean; // доска
var x, y: byte; // координаты для отрисовки
answer: boolean; // верное решение
procedure Reset(); {Очистка доски}
begin
for var i := 1 to 8 do
for var j := 1 to 8 do
queen[i,j] := false;
x := 0; y := 0;
end;
procedure Init(); {Расстановка ферзей на случайные клетки доски}
begin
x := Random(1, 8); y := Random(1, 8);
for var i := 1 to N do begin
while queen[x,y] do begin
x := Random(1, 8); y := Random(1, 8);
end;
queen[x,y] := true;
end;
end;
procedure Draw(); {Отрисовка доски с ферзями}
begin
for var i := 1 to 8 do
for var j := 1 to 8 do begin
if (odd(i) and odd(j)) or (not odd(i) and not odd(j)) then
SetBrushColor(RGB(150,90,60));
FillRectangle(50*i, 50*j, 50*(i+1), 50*(j+1));
if queen[i,j] then begin
SetBrushColor(clWhite);
Circle(50*i+25, 50*j+25, 20);
end;
SetBrushColor(RGB(200,200,10));
end;
end;
function Analize(): boolean; {Бьют ли ферзи друг друга}
begin
answer := true;
SetBrushColor(clRed);
for var i := 1 to 8 do begin
for var j := 1 to 8 do
if queen[i,j] then begin
for var m := 1 to 8 do
for var n := 1 to 8 do begin
if (i = m) and (j = n) then continue
else if queen[m,n] then
if ((i - m) * (j - n) = 0) or (abs(i - m) = abs(j - n)) then begin
Circle(50*i+25, 50*j+25, 20);
answer := false;
end;
end;
end;
end;
Result := answer;
end;
procedure Start(x, y, mb: integer); {Варианты работы программы}
begin
case mb of
1: begin // ЛКМ
Reset();
Init();
Draw();
Analize();
end;
2: begin // ПКМ
while not Analize() do begin
Reset();
Init();
Draw();
Analize();
end;
end;
end;
end;
begin
SetWindowSize(500, 500);
SetWindowTitle('Задача ферзей');
TextOut(160, 220, 'ЛКМ - следующий вариант'+#10+'ПКМ - поиск решения');
OnMouseDown := Start;
end.

Вот так выглядит:
ЮА
Юра Антипов
18 091