Версия для печати темы

Нажмите сюда для просмотра этой темы в обычном формате

Форум «Всё о Паскале» _ FAQ _ графы

Автор: virt 12.02.2005 21:57

Графы можно представлять в виде множества вершин и множества соединяющих их ребер. (Города и дороги их соединяющие)

1. Просмотр вершин графа в некотором фиксированном порядке.

общие структуры данных :

const Maxn=100;
var a:array[1..Maxn,1..Maxn]of integer;
Nnew:array[1..Maxn]of boolean;
n,i,j:integer;


поиск в глубину :

{ рекурсивный вариант }
procedure Pg(v:integer);
var i:integer;
begin
Nnew[v]:=false;
write(v:2);
for i:=1 to n do
if (a[v,i]<>0) and Nnew[i] then Pg(i);
end;

{ нерекурсивный вариант }
procedure Pg_nonrec(v:integer);
var St:array[1..Maxn]of integer;
yk:integer;
t,j:integer;
pp:boolean;
begin
fillchar(St,sizeof(St),0);
yk:=1;
St[yk]:=v;Nnew[v]:=false;
write(v:2);
while yk <> 0 do
begin
t:=St[yk];j:=0;pp:=false;
repeat
if (a[t,j+1] <> 0) and Nnew[j+1] then pp:=true
else inc(j);
until pp or (j >= n);
if pp then
begin
inc(yk);St[yk]:=j+1;Nnew[j+1]:=false;
write(j+1:2);
end else
dec(yk);
end;
end;


Поиск в ширину:
procedure Pw(v:integer);
var Og:array[1..Maxn]of 0..Maxn;
yk1,yk2:integer;
j:integer;
begin
fillchar(Og,sizeof(Og),0);yk2:=0;
yk1:=1;Og[yk1]:=v;Nnew[v]:=false;
while yk2 < yk1 do
begin
inc(yk2);v:=Og[yk2];
write(v:2);
for j:=1 to n do
if (a[v,j] <> 0) and Nnew[j] then
begin
inc(yk1);Og[yk1]:=j;Nnew[j]:=false;
end;
end;
end;



2. Каркасы (стягивающие деревья)

const Maxn=100;
var a:array[1..Maxn,1..Maxn]of byte;
Nnew:array[1..Maxn]of boolean;
Tree:array[1..2,1..Maxn]of integer;
n,i,j:integer;
yk:integer;


Построение стягивающего дерева поиском в глубину:
procedure Tree_Depth(v:integer);
var i:integer;
begin
Nnew[v]:=false;
for i:=1 to n do
if (a[v,i] <> 0) and Nnew[i] then
begin
inc(yk);Tree[1,yk]:=v;Tree[2,yk]:=i;
Tree_Depth(i);
end;
end;


Построение стягивающего дерева поиском в ширину:
procedure Tree_Width(v:integer);
var Turn:array[1..Maxn]of integer;
yr,yw,i:integer;
begin
fillchar(Turn,sizeof(Turn),0);yr:=0;
yw:=1;Turn[yw]:=v;Nnew[v]:=false;
while yw <> yr do
begin
inc(yr);v:=Turn[yr];
for i:=1 to n do
if (a[i,j] <> 0) and Nnew[i] then
begin
inc(yw);Turn[yw]:=i;Nnew[i]:=false;
inc(yk);Tree[1,yk]:=v;Tree[2,yk]:=i;
end;
end;
end;


Построение всех каркасов графа:
const Maxn=100;
var a:array[1..Maxn,1..Maxn]of byte;
Nnew:array[1..Maxn]of boolean;
Tree:array[1..2,1..Maxn]of integer;
Turn:array[1..maxn]of integer;
n,i,j:integer;
numb:integer;
down,up:integer;

..............

procedure solve(v,q:integer);
var j:integer;
begin
if down >= up then exit;
j:=q;
while (j <= n) and (numb < n-1) do
begin
if (a[v,j] <> 0) and Nnew[j] then
begin
Nnew[j]:=false;
inc(numb);
Tree[1,numb]:=v;Tree[2,numb]:=j;
Turn[up]:=j;inc(up);
solve(v,j+1);
dec(up);Nnew[j]:=true;dec(numb);
end;
inc(j);
end;
if numb = n-1 then
begin
writeln;
for i:=1 to numb do
write(Tree[1,i],' ',Tree[2,i],' ');
exit;
end;
if j = n+1 then
begin
inc(down);
solve(Turn[down],1);
dec(down);
end;
end;


Построение минимального каркаса методом Краскала:
(Исправлено. Присоединенный архив перезалит)

Граф задан списком ребер с указанием их весов:
program minim_tree_kraskal;
const maxn=100;
var p:array[1..3,1..maxn*(maxn-1) div 2]of integer;
Mark:array[1..maxn]of integer;
k,i,t:integer;
m,n:integer;{m - rebra;n - vershini }

procedure Change_Mark(l,m:integer);
var i,t:integer;
begin
if m < l then
begin
t:=l;l:=m;m:=t;
end;
for i:=1 to n do
if Mark[i]=m then Mark[i]:=l;
end;

begin
readln(n,m);
for i:=1 to m do
read(p[1,i],p[2,i],p[3,i]);
for i:=1 to m-1 do
for t:=i+1 to m do
if p[3,i] > p[3,t] then
begin
k:=p[1,i];p[1,i]:=p[1,t];p[1,t]:=k;
k:=p[2,i];p[2,i]:=p[2,t];p[2,t]:=k;
k:=p[3,i];p[3,i]:=p[3,t];p[3,t]:=k;
end;
for i:=1 to n do mark[i]:=i;
k:=0;t:=m;
while k < n-1 do
begin
i:=1;
while (i <= t) and (Mark[p[1,i]] = Mark[p[2,i]]) and (p[1,i] <> 0) do inc(i);
inc(k);

if p[1, i] * p[2, i] <> 0 then begin { Добавлена проверка на ненулевые вершины }
write(p[1,i],' ',p[2,i],' ');
change_Mark(Mark[p[1,i]],Mark[p[2,i]]);
end;
end;
end.


Построение минимального каркаса методом Прима:
procedure solve;
var sm,sp:set of 1..maxn;
min,i,j,l,t:integer;
begin
min:=maxint;
sm:=[1..n];sp:=[];
for i:=1 to n-1 do
for j:=i+1 to n do
if (a[i,j] < min) and (a[i,j] <> 0) then
begin
min:=a[i,j];
l:=i;t:=j;
end;
sp:=[l,t];sm:=sm-[l,t];
write(l,' ',t ,' ');
while sm <> [] do
begin
min:=maxint;
l:=0;t:=0;
for i:=1 to n do
if not (i in sp) then
for j:=1 to n do
if (j in sp) and (a[i,j] < min) and (a[i,j] <> 0) then
begin
min:=a[i,j];
l:=i;t:=j;
end;
sp:=sp+[l];sm:=sm-[l];
write(l,' ',t,' ');
end;
end;



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

Автор: Altair 5.05.2005 19:02

Поиск кратчайших путей.

Алгоритм Флойда

Описание алгоритма:
Над матрицей A (NxN) выполняется n итераций. После k-ой итерации, A[i,j] содержит значение наименьшей длинны путей из вершины i в вершину j, которые не проходят через вершины с номером, большим k.
На k-ой итерации для вычисления матрицы A, используется слудующая формула:

Ak[i,j] = min (Ak-1[i,j], Ak-1[i,k]+ Ak-1[k,j]).

Графическая интерпретация формулы:
Прикрепленное изображение

Сложность алгоритма
Время выполнения программы, имеетпорядок O(n3), так как в ней нет практически ничего, кроче 3 вложенных друг в друга циклов.

Сохранение маршрутов.
Что бы сохранять маршруты, от одной вершины кдругой, следует, ввести еще одну матрицу, в которой каждому элементу P[I,j]присваивать вершину K (номер), полученную при нахождении наименьшего значения a[I,j].


Const
NN=100;
Type
Graph = array[1..nn,1..nn] of longint; {граф задан матрицей смежности}
Var
n:integer;
Procedure Floyd (var a:graph; c:graph; var p:graph);
var i,j,k:integer;
begin
for i:=1 to n do
for j:=1 to n do begin a[i,j]:=c[i,j]; p[i,j]:=0; end;
for i:=1 to n do a[i,i]:=0;
for k:=1 to n do
for i:=1 to n do
for j:=1 to n do
If (a[i,k]+a[k,j]<a[i,j]) then
begin
a[i,j]:=a[i,k]+a[k,j];
p[i,j]:=k;
end;
end;

procedure ReadGraph(var a:graph);
var
i,j:integer;
begin
write('n= ');readln(n);
For i:=1 to n do for j:=1 to n do
begin write('G',i,',',j,'= ');readln(a[i,j]); end;
writeln;
end;

procedure ReadFileGraph(var a:graph);
var
i,j:integer; filename:string; f:text;
begin
Write('Enter file name:'); readln(filename);
Assign (f,filename); reset(f);
Readln(f,N);
For i:=1 to n do for j:=1 to n do read(f,a[i,j]); close(f);
end;

var
a,c,p:graph;
i,j:integer;
begin
{ ReadGraph( c );}
ReadFileGraph( c );
floyd(a,c,p);
writeln('---------------------------');
for i:=1 to n do {
begin
for j:=1 to n do write(a[i,j]:3);
writeln
end;
writeln('---------------------------');
for i:=1 to n do
begin
for j:=1 to n do write(p[i,j]:3);
writeln
end;
readln;
end.


В программе C-граф, заданный матрицей смежности.
A- матрица содержащая кратчайшие пути.
P - матрица, сохраняющая маршруты.

Автор: Altair 31.05.2005 11:01

Поиск кратчайшего пути. Алгоритм Дейкстры
Процедура

procedure Deikstr(n:integer; W:graph; u1,u2:integer;
var length:integer; var Weight:real; var Path: array of integer);

находит путь минимального веса в графе G, заданном весовой матрицей (матрица смежности) -W.
При этом предполагается, что все элементы Wij неотрицательны.
Путь ищется из вершины номер u1 к вершине номер u2 .
Для представления веса, равного бесконечности (машинная бесконечность), используется число GM,
передаваемое в алгоритм.
Это число можно задавать в зависимости от конкретной задачи...
модуль
UNIT Dijkstra;
Interface
Const
NN=30;
Type
graph=array [1..nn,1..nn] of integer;

procedure Deikstr(n:integer; W:graph; u1,u2:integer;
var length:integer; var Weight:real; var Path: array of integer);
Implementation
procedure Deikstr(n:integer; W:graph; u1,u2:integer;
var length:integer; var Weight:real; var Path: array of integer);
var
i,k,j:integer;
GM:real;
d,m:array[1..nn] of real;
p:array[1..nn] of integer;
t:integer;
dd,min:real;
begin
GM:=10000;{бесконечность}
length:=0;
if u1<>u2 then
begin
i:=1;
repeat
d[i]:=GM; p[i]:=0; m[i]:=0; i:=i+1
until not(i<=n);
d[u1]:=0; t:=u1;
while length=0 do
begin
i:=1;
repeat
if w[t,i]<GM then
begin
dd:=d[t]+w[t,i];
if d[i]>dd then begin d[i]:=dd; p[i]:=t end;
end;
i:=i+1
until not(i<=n);
Min:=GM; i:=1; k:=0;
repeat
if m[i]=0 then
begin
if d[i]<min then begin min:=d[i]; k:=i end;
end;
i:=i+1
until not(i<=n);
if k<>0 then begin
m[k]:=1; t:=k;
if t=u2 then begin length:=1; end;
end else begin length:=-1 end;
end;
if length=1 then
begin
Path[1]:=u2; length:=2; j:=u2;
repeat
Path[length]:=P[j]; j:=P[j]; length:=length+1
until not(j<>u1);
i:=1; k:=trunc(length/2);
repeat
t:=Path[i]; Path[i]:=Path[length-i]; Path[length-i]:=t; i:=i+1
until not(i<=k);
length:=length-1
end;
Weight:=d[u2]
end;
end;
end.



демонстрационная программа
компилятор BP7 (target windows)
uses wincrt,dijkstra;
var
i,u1,u2,n,l:integer;
G:Graph;
w:real;
path:array[0..100] of integer;

procedure ReadFileGraph(var a:graph);
var
i,j:integer; filename:string; f:text;
begin
Write('Enter file name:'); readln(filename);
Assign (f,filename); reset(f);
Readln(f,N);
For i:=1 to n do for j:=1 to n do read(f,a[i,j]); close(f);
end;

begin
readfilegraph(G); {читаем из файла граф.}
write('u1 = '); readln(u1); {вводим первую вершину}
write('u2 = '); readln(u2); {...и конечную..}
Deikstr(n,G,u1,u2, L,w,path);
writeln('w=',w:1:2); {выводим минимальный путь (вес)}
writeln('path'); {выводим путь ....}
for i:=1 to l do write(path[i],' - ');
readkey;
end.

В программе,граф считывается из файла. Вот для такого графа:
Прикрепленное изображение
файл должен иметь вид (за машинную бесконечность берется 10000):
Цитата

20
0 3 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
3 0 10000 10000 10000 3 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 0 2 10000 5 1 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 2 0 3 10000 10000 5 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 10000 3 0 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 3 5 10000 10000 0 10000 10000 3 10000 10000 4 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 1 10000 10000 10000 0 10000 2 2 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 10000 5 10000 10000 10000 0 10000 10000 4 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 10000 10000 10000 3 2 10000 0 2 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 10000 10000 10000 10000 2 10000 2 0 3 10000 10000 10000 10000 10000 10000 10000 10000 10000
10000 10000 10000 10000 10000 10000 10000 4 10000 3 0 10000 4 10000 10000 5 10000 10000 10000 10000
10000 10000 10000 10000 10000 4 10000 10000 10000 10000 10000 0 4 10000 10000 10000 10000 10000 10000 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 4 4 0 4 3 10000 10000 10000 10000 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 4 0 10000 10000 3 10000 10000 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 3 10000 0 10000 10000 3 10000 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 5 10000 10000 10000 10000 0 10000 4 7 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 3 10000 10000 0 10000 10000 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 3 4 10000 0 10000 6
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 7 10000 10000 0 10000
10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 10000 6 10000 0

Автор: Altair 2.06.2005 1:56

Эйлеров цикл.

Дадим теперь строгое определение эйлерову циклу и эйлерову графу. Если граф имеет цикл (не обязательно простой), содержащий все ребра графа по одному разу, то такой цикл называется эйлеровым циклом, а граф называется эйлеровым графом. Если граф имеет цепь (не обязательно простую), содержащую все вершины по одному разу, то такая цепь называется эйлеровой цепью, а граф называется полу-эйлеровым графом.
Ясно, что эйлеров цикл содержит не только все ребра по одному разу, но и все вершины графа (возможно, по несколько раз). Очевидно также, что эйлеровым может быть только связный граф.


Программа, строящая Эйлеров цикл, представленна ниже. (граф задается матрицей смежности, причем 0ставим если ребра нет, и один если есть).

Uses CRT;

var
N :integer;
M: array [1..20, 1..20] of boolean ;

Type
list = ^node;
node = record
i: integer;
next: list;
end;
Var
stack1, stack2: list;
v, u, x, i, j: integer;
count: array [1..20] of byte;
procedure readfile;
var
filename:string;
f:text; i,j:integer;
b:byte;
begin
writeln('Введите имя файла:');
readln( filename );
assign(f, filename);
reset(F);
readln(f , n );
for i:=1 to n do for j:=1 to n do begin
read( f , B );
if b=1 then m[i,j]:=true else m[i,j]:=false;
end;
close(F);
end;

Procedure Push(x: integer; var stack: list);
Var
temp: list;
Begin
New(temp);
temp^.i:=x;
temp^.next:=stack;
stack:=temp;
End;
Procedure Pop(var x: integer; var stack: list);
Begin
x:=stack^.i;
stack:=stack^.next
End;
Function Peek(stack: list): integer;
Begin
Peek:=stack^.i
End;
Procedure PrintList(l: list);
Begin
If l=nil then
begin
writeln('Ошибка!');
exit;
end;
write('Эйлеров цикл: ');
While l<>nil do
Begin
Write(l^.i,'-');
l:=l^.next;
End;
End;
Begin
readfile;
for i:=1 to N do
begin
count[i]:=0;
for j:=1 to N do if m[i,j] = True then inc(count[i]);
if (count[i] mod 2)<>0 then
begin
writeln('Нет цикла');
readkey;
halt;
end;
end;
stack1:=nil;
stack2:=nil;
Write('Начальная вершина: '); readln(v);
if (v<=N) then Push(v, stack1);
While stack1<>NIL do
Begin
v:=peek(stack1);
i:=1;
While (i<=n) and not m[v,i] do inc(i);
If i<=n then
Begin
u:=i;
Push(u, stack1);
m[v,u]:=False;
m[u,v]:=False;
End
else
Begin
pop(x,stack1);
push(x,stack2)
End;
End;
PrintList(stack2);
readkey;
End.

Автор: Perfez 20.07.2007 21:07

Топологическая Сортировка Графа

Рассмотрим ациклический направленный граф содержащий N узлов (вершин). Топологической сортировкой узлов (также известной как RPO-нумерация или N-нумерация) ациклического графа называется алгоритм, присваивающий узлам графа номера от 1 до N таким образом, что все предшественники узла с номером M имеют номера меньше M. Граф , как обычно, задаётся смежным массивом. Алгоритм представляет собой простейшую модификацию алгоритма поиска в глубину, также указанной вверху (Смотри пост virt-а).

Внизу представлена реализация Топологической Сортировки:


const
limit=100;
var
a:array [1..limit,1..limit] of longint; {Сам граф, реализуемый в виде смежного массива}
b,c,d:array [1..limit] of longint;
i,l,u,v,n,m,x,y:longint;
Procedure Check; {Процедура проверяющая ацикличность графа}
Begin
If (x<>u) and (y<>v) and (u<>v) and (x<>v) and (y<>u) then Inc(l,2);
If (u=v) and (x<>u) and (y<>u) then Inc(l);
x:=u;
y:=v;
End;
Procedure DFS(u:longint); {Процедура слегка изменённого поиска в глубину}
var
j:longint;
Begin
b[u]:=1;
For j:=1 to c[u] do
If b[a[u,j]]=0 then DFS(a[u,j]);
Inc(l);
d[l]:=u;
End;
Begin
Repeat
ReadLn(n,m); {Задаётся количество вершин и рёбер соответственно}
Until m>n;
For i:=1 to m do
Begin
Read(u,v); {Ввод рёбер}
If i=1 then
Begin
If u<>v then Inc(l,2)
else Inc(l);
x:=u;
y:=v;
End
else Check;
Inc(c[u]);
a[u,c[u]]:=v;
End;
If l<>n then {Проверка на цикличность графа}
Begin
WriteLn('В графе есть цикл!');
End
else
Begin
l:=0;
For i:=1 to n do
If b[i]=0 then DFS(i); {Рекурсия самой сортировки}
For i:=n downto 1 do Write(d[i]:3); {Вывод вершин графа после сортировки}
End;
End.