Правила форума
Внимание! Действует предмодерация
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 -
