IPB
ЛогинПароль:

> Внимание! Действует предмодерация

Подраздел FAQ (ЧАВО, ЧАстые ВОпросы) предназначен для размещения готовых рабочих программ, реализаций алгоритмов. Это нечто вроде справочника, он наполнялся в течение 2000х годов. Ваши вопросы, особенно просьбы решить задачу, не пройдут предмодерацию. Те, кто наполнял раздел, уже не заходят на форум, а с теми, кто на форуме сейчас, лучше начинать общение в других разделах. В частности, решение задач — здесь.

 
 Ответить  Открыть новую тему 
> Переборные Алгоритмы, Перебор
сообщение
Сообщение #1


Знаток
****

Группа: Пользователи
Сообщений: 419
Пол: Мужской

Репутация: -  6  +


Существует особый класс задач ,в которых ответ может быть найден только полным перебором всех вариантов решения. Поэтому необходимо иметь некоторое представление о том как решаются подобные задачи.

1) задача о ферзях :
Условие :
на шахматной доске размера n*n расставить n ферзей так ,что-бы они не били друг друга.
Решение :
диагональ первого типа: Прикрепленное изображение
диагональ второго типа: Прикрепленное изображение
var
{ признак занятости диагоналей первого типа }
up: array[2 .. 16] of boolean;

{ признак занятости диагоналей второго типа }
down: array[-7 .. 7] of boolean;

{ признак занятости вертикали }
vert: array[1 .. 8]of boolean;

{ номер вертикали, на которой стоит ферзь на каждой горизонтали }
ihor: array[1 .. 8]of integer;
n: integer;

{ проверка на допустимость хода в позицию (i,j) }
function d_hod(i, j: integer): boolean;
begin
d_hod := vert[j] and up[i+j] and down[i-j];
end;

procedure hod(i, j: integer); { сделать ход }
begin
ihor[i] := j;
vert[j] := false;
up[i+j] := false;
down[i-j] := false;
end;

procedure o_hod(i, j: integer); { отменить ход }
begin
vert[j] := true;
up[i+j] := true;
down[i-j] := true;
end;

Нахождение одного варианта расстановки :
procedure find_one(i: integer; var q: boolean);
var j: integer;
begin
j:=0;
repeat
inc(j);
q:=false;
if d_hod(i, j) then begin
hod(i,j);
if i < n then begin
find_one(i+1,q);
if not q then o_hod(i,j);
end
else q:=true;
end;
until q or (j=n);
end;

Нахождение всех решений :
procedure print;
var i: integer;
begin
write(' ',s,' ');for i:=1 to n do write(ihor[i],' ');
writeln;
end;

procedure find_all(i: integer);
var j: integer;
begin
if i<=n then begin
for j:=1 to n do
if d_hod(i,j) then begin
hod(i,j);
find_all(i+1);
o_hod(i,j);
end;
end
else begin
inc(s);
print;
end;
end;



2) задача о шахматном коне :
Условие :
Найти количество всех вариантов обхода шахматной доски конем.
Решение :
program kon_in_nm_matr_full_variants;
const
_maxnm=8;
dx: array[1 .. 8] of integer = (-2,-1,1,2,2,1,-1,-2);
dy: array[1 .. 8] of integer = (1,2,2,1,-1,-2,-2,-1);
var
a: array[-1 .. _maxnm+2, -1 .. _maxnm+2] of integer;
n, m, i, j: integer;
t: longint;

procedure solve(x, y, l: integer);
var k, i, j: integer;
begin
a[x, y] := l;
if l = n*m then inc(t)
else
for k:=1 to 8 do begin
i:=x+dx[k];j:=y+dy[k];
if a[i,j] = 0 then solve(i, j, l+1);
end;
a[x,y] := 0;
end;

begin
readln(n, m);
for i:=-1 to n+2 do a[i,-1]:=-1;
for i:=-1 to n+2 do a[i,0]:=-1;
for i:=-1 to n+2 do a[i,m+1]:=-1;
for i:=-1 to n+2 do a[i,m+2]:=-1;
for j:=1 to m do a[-1,j]:=-1;
for j:=1 to m do a[0,j]:=-1;
for j:=1 to m do a[n+1,j]:=-1;
for j:=1 to m do a[n+2,j]:=-1;
for i:=1 to n do
for j:=1 to m do a[i,j]:=0;

t := 0;
for i:=1 to n do
for j:=1 to m do begin
solve(i,j,1);
end;
writeln(' ', t);
end.


Условие :
Найти один вариант обхода методом Варнсдорфа.
Суть метода : при обходе коня следует ставить на поле ,из которого он может сделать минимальное количество перемещений на еще не занятые поля.
Решение :
program kon_in_nm_matr_one_variant;
const
_maxnm=8;
dx: array[1 .. 8] of integer = (-2,-1,1,2,2,1,-1,-2);
dy: array[1 .. 8] of integer = (1,2,2,1,-1,-2,-2,-1);
var
a: array[-1 .. _maxnm+2, -1 .. _maxnm+2] of integer;
n, m, i, j: integer;

procedure solve(x, y, l: integer);
var
w: array[1 .. 8] of integer;
xn, yn, i, j, m1: integer;
begin
a[x,y] := l;
if l=n*m then begin
writeln;
for i:=1 to n do begin
for j:=1 to m do write(a[i,j],' ');
writeln;
end;
halt;
end
else begin
for i:=1 to 8 do begin
w[i]:=0;
xn:=x+dx[i];
yn:=y+dy[i];
if a[xn,yn]=0 then begin
for j:=1 to 8 do
if a[xn+dx[j],yn+dy[j]]=0 then inc(w[i]);
end
else w[i]:=-1;
end;
i:=1;
while i<=8 do begin
m1:=1;
for j:=2 to 8 do
if w[j]<w[m1] then m1:=j;
if (w[m1]>=0) and (w[m1]<maxint) then
solve(x+dx[m1],y+dy[m1],l+1);
w[m1]:=maxint;
inc(i);
end;
end;
a[x,y]:=0;
end;

begin
readln(n,m);
for i:=-1 to n+2 do a[i,-1]:=-1;
for i:=-1 to n+2 do a[i,0]:=-1;
for i:=-1 to n+2 do a[i,m+1]:=-1;
for i:=-1 to n+2 do a[i,m+2]:=-1;
for j:=1 to m do a[-1,j]:=-1;
for j:=1 to m do a[0,j]:=-1;
for j:=1 to m do a[n+1,j]:=-1;
for j:=1 to m do a[n+2,j]:=-1;
for i:=1 to n do
for j:=1 to m do a[i,j]:=0;
for i:=1 to n do
for j:=1 to m do begin
solve(i,j,1);
end;
end.



3)задача о лабиринте :
Условие :
Дано клеточное поле, некоторые клетки заняты препятствиями. Найти количество путей от начальной точки до конечной.
Решение :
program labirint_way;
const
_maxn=30;
dx: array[1 .. 4] of integer = (1,0,-1,0);
dy: array[1 .. 4] of integer = (0,1,0,-1);
var
a: array[0 .. _maxn+1, 0 .. _maxn+1] of integer;
xn, yn, xk, yk: integer;
i, j, n: integer;
t: longint;

procedure solve(x, y, k: integer);
var i: integer;
begin
a[x,y]:=k;
if (x=xk) and (y=yk) then inc(t)
else
for i:=1 to 4 do
if a[x+dx[i],y+dy[i]]=0 then solve(x+dx[i],y+dy[i],k+1);
a[x,y]:=0;
end;

begin
{ Подправлена инициализация матрицы... }
for i := 0 to _maxn+1 do
for j := 0 to _maxn+1 do a[i, j] := 1;
read(n);
for i:=1 to n do
for j:=1 to n do read(a[i,j]);
readln(xn,yn,xk,yk);
t:=0;
solve(xn,yn,1);
writeln(t);
end.



4)задача о парламенте :
Условие :
На некотором демократическом острове каждый из жителей организовал партию которую и возглавил. В каждой партии кроме президента оказался еще как минимум один член. Составить самый малочисленный парламент, в котором будут представлены члены всех партий.
Решение :
const maxn = 150;
type
zint=0 .. maxn+1;
zset = set of 0 .. maxn;
person=record
man: zint;
num_part: zint;
part: zset;
end;

var
a: array[zint] of person;
n, mn, min, i: zint;
rwork, rbest: zset;

{ ... }
procedure include(k: zint);
begin
rwork:=rwork+[a[k].man];
inc(mn);
end;

procedure exclude(k: zint);
begin
rwork:=rwork-[a[k].man];
dec(mn);
end;

procedure solve(k: zint; res, rt: zset);
var i: zint;
begin
if rt=[] then begin
if mn<min then begin
min:=mn;
rbest:=rwork;
end;
end
else begin
i:=k;
while i<=n do begin
include(i);
solve(i+1,res+a[i].part,rt-a[i].part);
exclude(i);
inc(i);
end;
end;
end;

begin
init;
solve(1, [], [1..n]);
for i:=1 to n do
if i in rbest then write(i,' ');
end.



5)задача о рюкзаке :
Условие :
Дано - максимальный вес рюкзака. Дано n предметов имеющих свой вес и стоимость. Определить максимальную стоимость груза, вес которого не превышает максимального веса рюкзака.
Решение :
program rukzak_perebor;
const maxn = 20;
var
n, w: integer;
weight, price: array[1 .. maxn] of integer;
best, now: array[1 .. maxn] of integer;
maxprice: longint;

procedure init;
var i: integer;
begin
read(n);
read(w);
for i:=1 to n do read(weight[i]);
for i:=1 to n do read(price[i]);
end;

procedure rec(k, w: integer; st: longint);
var i: integer;
begin
if (k>n) and (st>maxprice) then begin
best:=now;
maxprice:=st;
end
else
if k<=n then
for i:=0 to w div weight[k] do begin
now[k]:=i;
rec(k+1,w-i*weight[k],st+i*price[k]);
end;
end;

begin
init;
rec(1, w, 0);
writeln(' ',maxprice);
end.


Сообщение отредактировано: volvo -
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


Знаток
****

Группа: Пользователи
Сообщений: 419
Пол: Мужской

Репутация: -  6  +


6) задача о коммивояжёре :
Условие :
Имеется n городов, расстояния между которыми заданы. Коммивояжеру необходимо выйти из какого-то города, побывать во всех остальных n-1 городах точно по одному разу, и вернуться в исходный город. Маршрут должен быть минимальным по длине.
Решение :
const maxv = 100;
var
{ матрица расстояний между городами }
a: array[1 .. maxv, 1 .. maxv] of integer;
b: array[1 .. maxv, 1 .. maxv] of byte;
way, best: array[1 .. maxv] of byte;

{ был ли коммивояжер в данном городе }
nnew: array[1 .. maxv] of boolean;
bestcost: integer;
n, i: integer;

{ ... }

{
сортируем каждую строку матрицы А по возрастанию
расстояний. Однако сами элементы матрицы А не
переставляем ,а изменяем в матрице B номера столбцов
матрицы А.
}
procedure sortlines;
var
k, i, j: integer;
w: integer;
begin
for i:=1 to n do
for j:=1 to n do b[i,j]:=j;
for k:=1 to n do
for i:=1 to n-1 do
for j:=i+1 to n do
if a[k,b[k,i]]>a[k,b[k,j]] then begin
w:=b[k,i]; b[k,i]:=b[k,j]; b[k,j]:=w;
end;
end;


procedure solve(v, count: byte; cost: integer); { основная процедура }
var i: integer;
begin
if cost > bestcost then exit;
if count=n then begin
cost:=cost+a[v,1];
way[n]:=v;
if cost<bestcost then begin
bestcost:=cost;
best:=way;
end;
exit;
end;
nnew[v]:=false;
way[count]:=v;
for i:=1 to n do
if nnew[b[v,i]] then solve(b[v,i],count+1,cost+a[v,b[v,i]]);
nnew[v]:=true;
end;

begin
init;
sortlines;
solve(1,1,0);
writeln(bestcost:4); { вывод результата }
for i:=1 to n do write(best[i],' '); writeln;
end.


Прикрепленные файлы
Прикрепленный файл  perebor.zip ( 4.27 килобайт ) Кол-во скачиваний: 2500


--------------------
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 4.10.2024 11:56
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name