Добро пожаловать, гость
:: алгоритмы  и методы :: :: олимпиадные задачи :: :: связь :: :: о сайте :: :: форум ::

Форум работает в режиме архива, только для чтения и поиска.
Архив 2004 Архив 2007 Архив 2013

 
 
Опции темы Поиск в этой теме Опции просмотра
  #1  
Старый 13.05.2008, 01:06
Новичок

Отправить личное сообщение для rena Посмотреть профиль Найти все сообщения от rena
 
Регистрация: 13.05.2008
Сообщений: 1

Расстановка ладей на шахматной доске
Задача: Написать программу, выдающую все возможные способы расстановки ладей на шахматной доске, при которых ни одна ладья не угрожает другой
Код:
var
  Form1: TForm1;
  Q:array [1..8] of 1..8;
  H:array [1..8] of boolean;
  j,t,k:integer;
  p:boolean;

procedure TForm1.Button1Click(Sender: TObject);
begin
//Заполнение
for j:=1 to 8 do
begin
H[j]:=true;
end;

Ladya8(1);
end;


procedure TForm1.Ladya8(k: integer);
var j:0..8;
begin
j:=0;
repeat //гориз <>8
    j:=j+1;
  if H[j] then //если гориз не под боем
       begin
      Q[k]:=j;
      H[j]:=false;
      if k<=8 then
      begin
        Memo1.Lines.Add('('+inttostr(k)+','+inttostr(j)+')');
        Ladya8(k+1);
      end
        else
        H[j]:=true;
          
        end;
 until j=8;

end;
Программа выдает только один вариант расстановки -
(1,1)
(2,2)
(3,3)
(4,4)
(5,5)
(6,6)
(7,7)
(8,8)
для того чтобы выводились все варианты, вроде бы нужно добавить цикл, но от этого результ становится ещё хуже. Плиз, подскажите куда и по какому элементу его вставлять? По j?
  #2  
Старый 13.05.2008, 05:58
MBo MBo вне форума
Местный

Отправить личное сообщение для MBo Посмотреть профиль Найти все сообщения от MBo
 
Регистрация: 21.09.2006
Адрес: Новосибирск
Сообщений: 1,374

Нужно сгенерировать все перестановки чисел 1..8 (их 40320)
http://algolist.ru/maths/combinat/index.php
  #3  
Старый 16.05.2008, 22:18
гость

 
Сообщений: n/a

Такой алгоритм будет очень долго выполняться..
  #4  
Старый 30.05.2008, 23:14
гость

 
Сообщений: n/a

ну можно рекурсивно:
var
a:array[1..8,1..8] of byte;
dx,dy:array[1..8] of boolean;
j,k,l,n:integer;
m:longint;
f:text;
procedure input;
begin
assign(f,'input.txt');reset(f);
read(f,n,k);
close(f);
end;

function work(x,y:byte):boolean;
begin
work:=(dx[x])and(dy[y]);
end;

procedure hod(x,y:byte);
begin
a[x,y]:=1;dx[x]:=false;dy[y]:=false;
end;

procedure back(x,y:byte);
begin
a[x,y]:=0;dx[x]:=true;dy[y]:=true;
end;

procedure solve(x,y:byte);
var
i:byte;
begin
if y>k then begin
inc(m);
exit;
end;

for x:=x to n do
for i:=1 to n do
if (a[x,i]=0)and(work(x,i)) then begin
hod(x,i);
solve(x+1,y+1);
back(x,i);
end;

end;

procedure output;
begin
assign(f,'output.txt');rewrite(f);
write(f,m);
close(f);
end;

begin
input;
fillchar(dx,sizeof(dx),true);fillchar(dy,sizeof(dy ),true);
solve(1,1);
output;
end.

проверял на acm, работает
  #5  
Старый 30.05.2008, 23:16
гость

 
Сообщений: n/a

а, забыл, доработать же надо. ну это сами разберётесь, измените кое-что в solve где
if y>k then begin
inc(m);
exit;
end;
  #6  
Старый 01.11.2009, 19:53
гость

 
Сообщений: n/a

HELP!
А можете на С++ данную программулину написать?
  #7  
Старый 01.11.2009, 23:16
гость

 
Сообщений: n/a

Сообщение от гость Посмотреть сообщение
А можете на С++ данную программулину написать?
Для тебя, дорогой, ответ: нет.
  #8  
Старый 27.11.2009, 15:16
гость

 
Сообщений: n/a

эххх....щедро конечно!Но всё же справедливо...
  #9  
Старый 10.04.2010, 23:12
гость

 
Сообщений: n/a

Люди..мне очень срочно нужна это программа на си++...спасите бедную девушку...
  #10  
Старый 11.04.2010, 00:20
гость

 
Сообщений: n/a

не поможем

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


Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск
Опции просмотра


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
компактная расстановка коробок незарегистрированный Математические алгоритмы 2 03.03.2007 04:25