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

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

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

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


Знаток
****

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

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


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

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;


Сообщение отредактировано: volvo -


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


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


Ищущий истину
******

Группа: Пользователи
Сообщений: 4 825
Пол: Мужской
Реальное имя: Олег

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


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

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

Описание алгоритма:
Над матрицей 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 - матрица, сохраняющая маршруты.


--------------------
Помогая друг другу, мы справимся с любыми трудностями!
"Не опускать крылья!" (С)
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3


Ищущий истину
******

Группа: Пользователи
Сообщений: 4 825
Пол: Мужской
Реальное имя: Олег

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


Поиск кратчайшего пути. Алгоритм Дейкстры
Процедура
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


--------------------
Помогая друг другу, мы справимся с любыми трудностями!
"Не опускать крылья!" (С)
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


Ищущий истину
******

Группа: Пользователи
Сообщений: 4 825
Пол: Мужской
Реальное имя: Олег

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


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

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


Программа, строящая Эйлеров цикл, представленна ниже. (граф задается матрицей смежности, причем 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.


--------------------
Помогая друг другу, мы справимся с любыми трудностями!
"Не опускать крылья!" (С)
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #5


Бывалый
***

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

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


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

Рассмотрим ациклический направленный граф содержащий 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.



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

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

 




- Текстовая версия 19.01.2018 18:03
Хостинг предоставлен компанией "Веб Сервис Центр" при поддержке компании "ДокЛаб"