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

[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 15:36

[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.