графы, алгоритмы на графах Опции

[virt]

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

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 - 13.01.2009 11:36

[Altair]

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

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

Описание алгоритма:
Над матрицей 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]

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

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]

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

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


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

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

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