задание:
1)В заданном графе найти кратчайший путь от одной вершины к другой и найти все пути между этими вершинами, не пересекающиеся по вершинам.
вот исходник:
Код
{Bellman-Ford algorithm}
var a : array [1..20,1..20] of word;
c, pred : array [1..20] of word;
i, j, k, n, first, last : byte;
f, g : text;
begin
assign(f,'in.txt');
reset(f);
readln(f, n);
for i := 1 to n do
begin
for j := 1 to n do
read(f, a[i,j]);
readln(f);
end;
readln(f, first, last);
close(f);
for j := 1 to n do
begin
c[j] := a[first,j];if a[first,j] < 32767 then pred[j] := first;
end;
for i := 3 to n do
for j := 1 to n do
if j <> first then
for k := 1 to n do
if (c[k] < 32767) and (c[k] + a[k,j] < c[j]) then begin c[j] := c[k] + a[k,j];pred[j] := k;end;
assign(g,'out.txt');
rewrite(g);
if c[last] = 32767 then writeln(g,'N') else
begin
writeln(g,'Y');
write(g,first,' ');
i := last;k := 1;
while i <> first do
begin
a[1,k] := i;
k := k + 1;
i := pred[i];
end;
for i := k - 1 downto 1 do
write(g,a[1,i],' ');
writeln(g);
writeln(g,c[last]);
end;
close(g);
end.
var a : array [1..20,1..20] of word;
c, pred : array [1..20] of word;
i, j, k, n, first, last : byte;
f, g : text;
begin
assign(f,'in.txt');
reset(f);
readln(f, n);
for i := 1 to n do
begin
for j := 1 to n do
read(f, a[i,j]);
readln(f);
end;
readln(f, first, last);
close(f);
for j := 1 to n do
begin
c[j] := a[first,j];if a[first,j] < 32767 then pred[j] := first;
end;
for i := 3 to n do
for j := 1 to n do
if j <> first then
for k := 1 to n do
if (c[k] < 32767) and (c[k] + a[k,j] < c[j]) then begin c[j] := c[k] + a[k,j];pred[j] := k;end;
assign(g,'out.txt');
rewrite(g);
if c[last] = 32767 then writeln(g,'N') else
begin
writeln(g,'Y');
write(g,first,' ');
i := last;k := 1;
while i <> first do
begin
a[1,k] := i;
k := k + 1;
i := pred[i];
end;
for i := k - 1 downto 1 do
write(g,a[1,i],' ');
writeln(g);
writeln(g,c[last]);
end;
close(g);
end.
требуется, чтоб матрица смежности забивалась нулями и единицами, и чтоб на выходе была последовательность из номеров пути
2)написать программу, проверяющую заданный граф на двудольность.
требования такие же, матрица смежности из единиц и нулей, на выходе фраза, типа, граф двудольный, или наоборот
вот, что есть у меня
Код
{Proverka dvudolnosti grafa}
const nv = 20;
type pz = ^z;
z = record
v : byte;
next : pz;
end;
var a : array [1..nv,1..nv] of byte;
cc : array [1..nv] of byte;
i, j, n, c : byte;
f, g : text;
top, p : pz;
begin
assign(f,'in.txt');
assign(g,'out.txt');
rewrite(g);
reset(f);
readln(f,n);
for i := 1 to n do
begin
read(f,a[i,1]);
j := 2;
while a[i,j-1] > 0 do
begin
read(f,a[i,j]);
j := j + 1;
end;
end;
close(f);
new(top);
top^.next := nil;
top^.v := 1;
cc[1] := 1;
c := 2;
while top <> nil do
begin
j := 1;
while (a[top^.v,j] > 0)and(cc[a[top^.v,j]] > 0) do
begin
if cc[a[top^.v,j]] <> c then begin writeln(g,'N');close(g);
exit;end;
j := j + 1;
end;
if a[top^.v,j] > 0 then
begin
cc[a[top^.v,j]] := c;c := c and 1 + 1;
new(p);
p^.v := a[top^.v,j];
p^.next := top;
top := p;
end
else begin p := top^.next;dispose(top);top := p;c := cc[top^.v] and 1 + 1;end;
end;
writeln(g,'Y');
j := 1;
while cc[j] > 0 do
begin if cc[j] = cc[1] then write(g,j,' ');j := j + 1;end;
write(g,'0');
writeln(g);
j := 1;
while cc[j] > 0 do
begin if cc[j] = cc[1] and 1 + 1 then write(g,j,' ');j := j + 1;end;
close(g);
end.
const nv = 20;
type pz = ^z;
z = record
v : byte;
next : pz;
end;
var a : array [1..nv,1..nv] of byte;
cc : array [1..nv] of byte;
i, j, n, c : byte;
f, g : text;
top, p : pz;
begin
assign(f,'in.txt');
assign(g,'out.txt');
rewrite(g);
reset(f);
readln(f,n);
for i := 1 to n do
begin
read(f,a[i,1]);
j := 2;
while a[i,j-1] > 0 do
begin
read(f,a[i,j]);
j := j + 1;
end;
end;
close(f);
new(top);
top^.next := nil;
top^.v := 1;
cc[1] := 1;
c := 2;
while top <> nil do
begin
j := 1;
while (a[top^.v,j] > 0)and(cc[a[top^.v,j]] > 0) do
begin
if cc[a[top^.v,j]] <> c then begin writeln(g,'N');close(g);
exit;end;
j := j + 1;
end;
if a[top^.v,j] > 0 then
begin
cc[a[top^.v,j]] := c;c := c and 1 + 1;
new(p);
p^.v := a[top^.v,j];
p^.next := top;
top := p;
end
else begin p := top^.next;dispose(top);top := p;c := cc[top^.v] and 1 + 1;end;
end;
writeln(g,'Y');
j := 1;
while cc[j] > 0 do
begin if cc[j] = cc[1] then write(g,j,' ');j := j + 1;end;
write(g,'0');
writeln(g);
j := 1;
while cc[j] > 0 do
begin if cc[j] = cc[1] and 1 + 1 then write(g,j,' ');j := j + 1;end;
close(g);
end.