Расстановка 5 ферзей... Опции

[Vardes]

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

*
У меня возникла такая проблема.Необходимо найти расстановку 5 ферзей, при которой каждое поле шахматной доски будет находиться под ударом хотя бы одного из них.
Давным давно эта задача уже была решена, вот только програмного кода что-то нигде нет.
Помогите, кто чем может...

*

[Lapp]

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.

[Shashlyk]

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.

Скажите Пожалуйста, какой алгоритм вы использовали при написании данного кода?

Сообщение отредактировано: Shashlyk - 28.09.2011 13:15