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 килобайт ) Кол-во скачиваний: 1591


--------------------
 Оффлайн  Профиль  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 
 К началу страницы 
+ Ответить 

Сообщений в этой теме


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

 





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