Товарищи модераторы!!!!
Воспользовавшись поиском, я не нашёл решения своей задачи, т.к. её необходимо решить рекурсией и суть её совсем в другом...
*
У меня возникла такая проблема.Необходимо найти расстановку 5 ферзей, при которой каждое поле шахматной доски будет находиться под ударом хотя бы одного из них.
Давным давно эта задача уже была решена, вот только програмного кода что-то нигде нет.
Помогите, кто чем может...
*
Кстати, тебе какой из вариантов нужен? Тот, в котором ферзи угрожают друг другу, но при этом всю доску контролируют, или второй - когда они мало того, что всю доску под прицелом держат, так еще и друг другу не угрожают?
Возможно и то и другое. Вот пример:
Эскизы прикрепленных изображений
Vardes прав, задача другая. Сходство есть, но это не повод закрывать тему.. Я уже почти ответил в нее тогда - вот мой пост.
Я сначала подумал, что решение полным перебором будет слишком медленным. Но чисто из любопытства (сколько же времени это может занять) я набросал прогу. Когда писал, ничего не оптимизировал, рассматриваются абсолютно все комбинации, включая по нескольку ферзей в одной клетке (что по сути есть просто меньшее количество ферзей). Использовал далеко не самые эффективные конструкции и тешил себя мыслью, что потом будет приятно оптимизироать и смотреть, как уменьшается время счета .
Но никакой оптимизации не потребовалось! Первый же вариант на моем компе (P4 1900) отстрелялся за доли секунды! Даже скучно..
Решений находит довольно много, но многие одинаковые (отбраковка одинаковых - это другая интересная задача, надо подумать).
Выводит:
- положение ферзей в обычной шахматной нотации:
- положение ферзей (обозначены номерами) на поле:
- поле, заполненное цифрами, означающими какой по счету ферзь (последний) бьет это поле.
Так что я был немного разочарован . Но когда я задал поиск с доской 10х10 при 8 ферзях - я зачаровался обратно..
Как грится - enjoy!
program Queens;
uses
CRT;
const
M=8; {Board Size, 8 }
MaxL=5; {Number of Queens, 5 }
type
tCell=byte;
tBo=array[1..M,1..M]of tCell;
tCo=record
x,y:integer
end;
var
Bo:tBo;
BoCo:array[1..MaxL]of tBo;
Co:array[1..MaxL]of tCo;
L:integer;
i,j:integer;
procedure Show;
var
i,j,k,f:integer;
begin
for j:=M downto 1 do begin
Write(j:2,' ');
for i:=1 to M do begin
f:=0;
for k:=1 to L do if (Co[k].x=i)and(Co[k].y=j) then f:=k;
if f=0 then Write(' ') else Write(f);
end;
Write(' ');
for i:=1 to M do if Bo[i,j]=0 then Write(' ') else Write(Bo[i,j]);
WriteLn;
end;
Write(' ');
for i:=1 to M do Write(Char(i+96));
end;
procedure Put(x,y:integer);
var
i,j:integer;
t:boolean;
begin
Inc(L);
BoCo[L]:=Bo;
Co[L].x:=x;
Co[L].y:=y;
for i:=1 to M do begin
Bo[i,y]:=L;
Bo[x,i]:=L;
end;
for i:=-M to M do begin
if ((x+i)>0)and((y+i)>0)and((x+i)<=M)and((y+i)<=M) then Bo[x+i,y+i]:=L;
if ((x+i)>0)and((y-i)>0)and((x+i)<=M)and((y-i)<=M) then Bo[x+i,y-i]:=L;
end;
if L=MaxL then begin
t:=true;
for i:=1 to M do for j:=1 to M do t:=t and(Bo[i,j]<>0);
if t then begin
WriteLn;
Write('Found: ');
for i:=1 to L do Write(Char(96+Co[i].x),Co[i].y,' ');
WriteLn;
WriteLn;
Show;
ReadLn;
end;
end
else for i:=1 to M do for j:=1 to M do Put(i,j);
Bo:=BoCo[L];
Dec(L);
end;
begin
for i:=1 to M do for j:=1 to M do Bo[i,j]:=0;
L:=0;
Put(1,1);
end.
Опять ПОЛНЫЕ решения? Ну-ну... И после ЭТОГО вы все еше удивляетесь, ПОЧЕМУ же сами-то они решить не могут? Да вот поэтому и не могут!
Потому, что придет lapp, и напишет программу полностью! И откомпилирует, и проверит, и ошибок однозначно не будет! Можно даже не проверять, Copy+Paste и сдавать...
Меня эта тема перестала интересовать ровно в тот момент, как она стала ХАЛЯВОЙ для ничего не хотящих делать студентов. Объяснения это одно, а полное, готовое решение на блюдечке - другое.
lapp, Вот тебе ответ: http://forum.sources.ru/index.php?showtopic=135382&view=findpost&p=1038597
Сообщение будет удалено через 2 часа после создания...
Даааа, спасибо, volvo, за вашу критику в мой адрес.....
Знаете бывают такие случаи, когда времени просто не хватает и человек обращается за помощью к своим товарищам.
Я благодарен за ваше содействие, но знаете нельзя человека судить по тому, что он пишет на форумах
сорри за офф.
не удержалась.
Lapp, если вам не сложно, прокомментируйте plz переменные, которые вы использовали, а то что-то я ваш алгоритм решения никак не пойму.
Ещё хотел задать вопрос, вашим алгоритмом я получил 11568 вариантов, хотя всего и 4096. Из-за чего появляются одинаковые решения?
program Queens;
uses
CRT;
const
M=8; {Board Size, 8 }
MaxL=5; {Number of Queens, 5 }
type
tCell=byte;
tBo=array[1..M,1..M]of tCell;
tCo=record
x,y:integer
end;
var
Bo:tBo;
BoCo:array[1..MaxL]of tBo;
Co:array[1..MaxL]of tCo;
L:integer;
i,j:integer;
procedure Show;
var
i,j,k,f:integer;
begin
for j:=M downto 1 do begin
Write(j:2,' ');
for i:=1 to M do begin
f:=0;
for k:=1 to L do if (Co[k].x=i)and(Co[k].y=j) then f:=k;
if f=0 then Write(' ') else Write(f);
end;
Write(' ');
for i:=1 to M do if Bo[i,j]=0 then Write(' ') else Write(Bo[i,j]);
WriteLn;
end;
Write(' ');
for i:=1 to M do Write(Char(i+96));
end;
procedure Put(x,y:integer);
var
i,j:integer;
t:boolean;
begin
Inc(L);
BoCo[L]:=Bo;
Co[L].x:=x;
Co[L].y:=y;
for i:=1 to M do begin
Bo[i,y]:=L;
Bo[x,i]:=L;
end;
for i:=-M to M do begin
if ((x+i)>0)and((y+i)>0)and((x+i)<=M)and((y+i)<=M) then Bo[x+i,y+i]:=L;
if ((x+i)>0)and((y-i)>0)and((x+i)<=M)and((y-i)<=M) then Bo[x+i,y-i]:=L;
end;
if L=MaxL then begin
t:=true;
for i:=1 to M do for j:=1 to M do t:=t and(Bo[i,j]<>0);
if t then begin
WriteLn;
Write('Found: ');
for i:=1 to L do Write(Char(96+Co[i].x),Co[i].y,' ');
WriteLn;
WriteLn;
Show;
ReadLn;
end;
end
else for i:=1 to M do for j:=1 to M do Put(i,j);
Bo:=BoCo[L];
Dec(L);
end;
begin
for i:=1 to M do for j:=1 to M do Bo[i,j]:=0;
L:=0;
Put(1,1);
end.