Требуется! , [Pascal] описание алгоритмов работы с графами

[Romtek]

Требуется описание алгоритмов для работы с графами.

• Поиск в ширину
• Поиск в глубину
• Вычисление матрицы достижимости
• другие?

Нужно описать алгоритмы и реализовать их в виде процедур, объяснив что просходит и почему.

Планируется разместить их здесь: http://sources.ru/wiki/doku.php?id=pascal:graph

Кто возьмётся?

Сообщение отредактировано: Jin X - 17.11.16, 15:18

[volvo877]

Romtek, в книге "Структуры данных и алгоритмы" (Ахо, Хопрофт, Ульман) теме алгоритмов на графах посвящены 2 главы: 6-я ("Ориентированные графы") и 7-я ("Неориентированные графы"), итого - страницы 183-227 (со схемами, примерами программ, теоретическими обоснованиями, и т.д.) Полнее вряд ли что-то можно себе представить...

Можно, конечно это переконвертировать из DJVU в другой формат и выложить в FAQ-е, но что будем делать с (С)?

[Romtek]

volvo877, держать копию бумажных книг не есть цель FAQ, а собирание наиболее популярных алгоритмов и их реализация на Паскале. Книгу мы не в состоянии заменить, да и нет нужды.

[Вован Каширский]

Матрица достижимости:

procedure AttainAbility (var P :TMatrix; S :TMatrix);
var
  i, j, k :Integer;
  T :TMatrix;
 
  { Булева сумма }
  procedure BSum(var T :TMatrix; A, B :TMatrix);
  var
    i, j :Integer;
  begin
    fillchar(T, sizeof(T), 0);
    for i:=1 to NMax do
      for j:=1 to NMax do
        T[i,j] := A[i,j] or B[i,j];
  end;
 
  { Булево произведение }
  procedure BMult(var T :TMatrix; A, B :TMatrix);
  var
    i, j, k :Integer;
    temp :TMatrix;
  begin
    fillchar(T, sizeof(T), 0);
    for i:=1 to NMax do
      for j:=1 to NMax do
        for k:=1 to NMax do T[i,j] := T[i,j] or (A[i,k] and B[k,j]);
  end;
 
begin
  P := S; BMult(T, S, S);
  for i:=2 to NMax do begin
    BSum(P, P,T); BMult(T, T,S);
  end;
end;

S - матрица смежности
P - матрица достижимости

Типы описаны так:

Const NMax = 4;
Type
  TVector = array[1..NMax] of Boolean;
  TMatrix = array[1..NMax] of TVector;

Сообщение отредактировано: Artful Fox - 28.12.06, 22:06

[Romtek]

Artful Fox, благодарю за код.
А как насчёт пояснения как и почему?.

[Вован Каширский]

Цитата Romtek @ 29.12.06, 14:22

А как насчёт пояснения как и почему?.

Хорошо.

P - искомая матрица достижимости. Известно, что P = A (булева сумма) A^2 (булева сумма) A^3 (булева сумма) .... (булева сумма) A^n, где A - матрица смежности, n - размерность матрицы (число вершин в графе), причем A^2 = A (булево произведение) A, а для общего случая A^r = A (булево произведение) A^r-1.

Булева сумма и произведение пишутся как и для обычных матриц.

[Вован Каширский]

Обход графа в глубину:

  procedure Go (S :TMatrix);
  var
    i :Integer;
    B :array[1..NMax] of Boolean;
 
    procedure GoDown (m :Integer);
    var i :Integer;
    begin
      write(m);
      B[m] := true;
      for i:=1 to NMax do
        if (S[m,i]) and (not B[i]) then GoDown(i);
    end;
 
  begin
    fillchar(B,sizeof(B),0);
    for i:=1 to Nmax do GoDown(i);
  end;

Кстати я заметил, что предыдущий алгоритм нахождения матрицы достижимости можно использовать как для орграфов так и для обычных. Но для обычных можно использовать и следующий алгоритм основанный на обходе в глубину:

procedure AttainAbility(var P :TMatrix; S :TMatrix);
  var
    B :TVector;
    i :Integer;
 
    procedure GoDown (m :Integer);
    var i :Integer;
    begin
      B[m] := true;
      for i:=1 to NMax do
        if (not B[i]) and S[m,i] then GoDown(i);
    end;
 
  begin
    for i:=1 to NMax do begin
      FillChar(B,SizeOf(B),0);
      GoDown(i);
      P[i] := B;
    end;
  end;

[-=Makc=-]

Немного о графах есть здесь:
http://education.aspu.ru/page.php?id=152

Добавлено 17.01.07, 13:30
поиск в глубину
Поиск в ширину
Каркасы (стягивающие деревья)
Построение стягивающего дерева поиском в глубину
Построение стягивающего дерева поиском в ширину
Построение всех каркасов графа
Построение минимального каркаса методом Краскала: Граф задан списком ребер с указанием их весов
Построение минимального каркаса методом Прима
и Поиск кратчайших путей.
http://education.aspu.ru/page.php?id=152

Добавлено 17.01.07, 13:31
Сборник исходников "Алгоритмы на графах" : есть много всего интересного
http://borisvolfson.h11.ru/programs/graphs.rar

[Romtek]

Без пояснений алгоритмом и в коде нет смысла в данных ссылках, поисковиками все умеют пользоваться.

[Glex]

Дейкстра с бинарным деревом (heap'ом) в НГ
Способ представления графа: списки смежности

program DijkstraViaHeap_01;
const
  FIN  = 'dijkstra.in';
  FOUT  = 'dijkstra.out';
  NMAX = 30000;
  INF  = high(integer) div 2 - 1;
type
  PEdge = ^TEdge;
  TVertex = record
    num: integer;
    key: integer;
    end;
  THeap = class
    a: array of TVertex;
    index_by_num: array of integer;
    length: integer;
    function LChild(const k: integer): integer;
    function RChild(const k: integer): integer;
    function Parent(const k: integer): integer;
    procedure Add(var v: TVertex); overload;
    procedure Add(const num, key: integer); overload;
    procedure Swap(const i, j: integer);
    procedure Update(const num: integer; const new_key: integer);
    function ExtractMin(): TVertex;
    constructor Create(const allocSize: integer); overload;
    constructor Create(const allocSize: integer; const keys: array of integer); overload;
    end;
  TEdge = record
    v: integer;
    w: integer;
    next: PEdge;
    end;
 
procedure THeap.Add(const num, key: integer);
var v: TVertex;
begin
  v.num := num;
  v.key := key;
  add(v);
end;
 
constructor THeap.Create(const allocSize: integer);
var i: integer;
begin
  length := 0;
  setlength(a, allocSize);
  setlength(index_by_num, allocSize);
  for i := 0 to allocSize - 1 do index_by_num[i] := -1;
end;
 
constructor THeap.Create(const allocSize: integer; const keys: array of integer);
var i: integer;
    v: TVertex;
begin
  length := 0;
  setlength(a, allocSize);
  setlength(index_by_num, allocSize);
  for i := 0 to allocSize - 1 do index_by_num[i] := -1;
  for i := 0 to allocSize - 1 do begin
     v.num := i + 1;
     v.key := keys[i];
     add(v);
    end;
end;
 
function THeap.LChild(const k: integer): integer;
begin
  result := 2 * k + 1;
end;
 
function THeap.RChild(const k: integer): integer;
begin
  result := 2 * (k + 1);
end;
 
function THeap.Parent(const k: integer): integer;
begin
  if k = 0 then result := -1
  else result := (k - 1) div 2;
end;
 
procedure THeap.Swap(const i, j: integer);
var t: TVertex;
begin
  index_by_num[a[i].num - 1] := j;
  index_by_num[a[j].num - 1] := i;
 
  t    := a[i];
  a[i] := a[j];
  a[j] := t;
end;
 
procedure THeap.Add(var v: TVertex);
var k, p: integer;
begin
  inc(length);
  k := length - 1;
  a[k] := v;
  index_by_num[v.num - 1] := k;
  p := parent(k);
  while (p <> -1) and (a[p].key > a[k].key) do begin
    swap(p, k);
    k := p;    
    p := parent(k);
    end;
end;
 
function THeap.ExtractMin(): TVertex;
var new_key: integer;
begin
  result := a[0];
  swap(0, length - 1);
  dec(length);
  index_by_num[result.num - 1] := -1;
  new_key := a[0].key;
  a[0].key := result.key;
  update(a[0].num, new_key);
end;
 
procedure THeap.Update(const num: integer; const new_key: integer);
var k, p, c1, c2: integer;
begin
  k := index_by_num[num - 1];
  if (k = -1) or (k > length - 1) then exit;
  if new_key < a[k].key then begin
    a[k].key := new_key;
    p := parent(k);
    while (p <> -1) and (a[p].key > a[k].key) do begin
      swap(p, k);
      k := p;
      p := parent(k);
      end;
    end
  else begin
    a[k].key := new_key;
    while true do begin
      c1 := lchild(k);
      c2 := rchild(k);
      p := k;
      if (c1 < length) and (a[c1].key < a[p].key) then p := c1;
      if (c2 < length) and (a[c2].key < a[p].key) then p := c2;
      if p = k then break;
      swap(p, k);
      k := p;
      end;
    end;
end;
 
procedure addEdge(var l: PEdge; const v, w: integer);
var t: PEdge;
begin
  new(t);
  t.next := l;
  t.v := v;
  t.w := w;
  l := t;
end;
 
var
  n, m: integer;
  e: array[1..NMAX] of PEdge;
 
procedure Dijkstra(const s, t: integer);
var i: integer;
    min: integer;
    cur: PEdge;
    heap: THeap;
    dist: array[1..NMAX] of integer;
    prev: array[1..NMAX] of integer;
begin
  for i := 1 to n do begin
    dist[i] := INF;
    prev[i] := -1;
    end;
  prev[s] := 0;
  dist[s] := 0;
  heap := THeap.Create(n, dist);
  while heap.length > 0 do begin
    min := heap.ExtractMin().num;
    cur := e[min];
    while cur <> nil do begin
      if dist[cur.v] > dist[min] + cur.w then begin
        prev[cur.v] := min;
        dist[cur.v] := dist[min] + cur.w;
        heap.update(cur.v, dist[cur.v]);
        end;
      cur := cur.next;
      end;
    end;
  for i := 1 to n - 1 do write(dist[i], ' ');
  writeln(dist[n]);
end;
 
var i, u, v, w: integer;
begin
  AssignFile(input, FIN);   reset(input);
  AssignFile(output, FOUT); rewrite(output);
  read(n, m);
  for i := 1 to m do begin
    read(u, v, w);
    addEdge(e[u], v, w);
    addEdge(e[v], u, w);
    end;
  Dijkstra(1, 0);
  close(input);
  close(output);
end.

Время работы O(v * log(v) + e * log(e)), где v и t кол-во вершин и рёбер соответственно.
Красивое подробное пояснение с картинками http://ru.wikipedia.org/wiki/Алгоритм_Дейкстры

Дейсктра на массиве и ОГ
Способ представления графа: списки смежности

program DijkstraViaArray_01;
{$Q+} {$R+}
{/$DEFINE FILE_IO}
 
uses
  SysUtils;
 
const
  NMAX = 1000;
  INF   = high(Integer) div 2 - 1;
  INF64 = 100000000000000;
 
type
  PEdge = ^TEdge;
  TEdge = record
    v: integer;
    w: integer;
    next: PEdge;
    end;
 
  procedure addEdge(var l: PEdge; const v: integer; const w: integer);
  var t: PEdge;
  begin
    new(t);
    t.next := l;
    t.v := v;
    t.w := w;
    l := t;
  end;
 
var
  n, m: integer;
  s, t: integer;
 
 
procedure solve(s, t: integer);
var i: integer;
    dist: array[0..NMAX] of int64;
    prev: array[1..NMAX] of integer;
    used: array[1..NMAX] of byte;
    e: array[1..NMAX] of PEdge;
 
    path: string;
    path_length: integer;
    u, v, w: integer;
    min: integer;
    cur: PEdge;
begin
  for i := 1 to NMAX do begin
    e[i] := nil;
    dist[i] := INF64;
    prev[i] := -1;
    used[i] := 0;
    end;
 
  for i := 1 to m do begin
    read(u, v, w);
    if (u = v) then continue;
    addEdge(e[u], v, w);
    end;
 
  dist[s] := 0;
  prev[s] := 0;
  used[s] := 1;
  dist[0] := INF64;
  fillchar(used, sizeof(used), 0);
  while true do begin
 
    min := 0;
    for i := 1 to n do begin
      if (used[i] = 0) and (dist[i] < dist[min])
        then min := i;
      end;
    if min = 0 then break;
 
    used[min] := 1;
 
    cur := e[min];
    while cur <> nil do begin
      if (Int64(dist[cur.v] - dist[min]) - Int64(cur.w) > 0) then begin
        prev[cur.v] := min;
        dist[cur.v] := Int64(dist[min]) + Int64(cur.w);
        end;
      cur := cur.next;
      end;
 
    end;
 
  if dist[t] = INF64 then begin
    writeln('-1');
    exit;
    end;
 
  write(dist[t], ' ');
  path := '';
  path_length := 0;
  while t <> 0 do begin
    path := inttostr(t) + ' ' + path;
    t := prev[t];
    inc(path_length);
    end;
  if path_length <> 0 then
    setlength(path, length(path) - 1);
  Writeln(path_length);
  writeln(path);
end;
 
begin
  {$IFDEF FILE_IO}
  assign(input, 'dijkstra.in'); reset(input);
  assign(output, 'dijkstra.out'); rewrite(output);
  {$ENDIF}
 
  read(n, m);
  read(s, t);
  solve(s, t);
end.

Дейсктры в ОГ и в НГ ничем не отличаются друг от друга в реализации.
Хотелось бы переделать объяснение работы (или хотя бы взять его из Кормена), но времени как всегда нет..

Добавлено 30.04.07, 04:46
Поиск в ширину на списках смежности

program BFS_01;
uses Contnrs;
const
  FIN  = 'breadth.in';
  FOUT = 'breadth.out';
  NMAX = 30000;
  INF  = high(integer) div 2 - 1;
type
  PEdge = ^TEdge;
  TEdge = record
    v: integer;
    next: PEdge;
    end;
 
procedure addEdge(var l: PEdge; const v: integer);
var t: PEdge;
begin
  new(t);
  t.next := l;
  t.v := v;
  l := t;
end;
 
var
  e: array[1..NMAX] of PEdge;
  m: integer;
  n: integer;
 
procedure BFS(const s, f: integer);
var i: integer;
    t: PInteger;
    cur: PEdge;
    min: integer;
    queue: TQueue;
    dist: array[1..NMAX] of integer;
    prev: array[1..NMAX] of integer;
begin
  for i := 1 to n do begin
    dist[i] := INF;
    prev[i] := -1;
    end;
 
  prev[s] := 0;
  dist[s] := 0;
 
  queue := TQueue.Create;
  new(t);
  t^ := s;
  queue.Push(t);
 
  while queue.Count > 0 do begin
    t := queue.Pop;
    cur := e[t^];
    min := t^;
 
    while cur <> nil do begin
      if dist[cur.v] > dist[min] then begin
        prev[cur.v] := min;
        dist[cur.v] := dist[min] + 1;
        new(t);
        t^ := cur.v;
        queue.Push(t);
        end;
      cur := cur.next;
      end;
 
    end;
 
  for i := 1 to n - 1 do write(dist[i], ' ');
  writeln(dist[n]);
end;
 
var i, u, v: integer;
begin
  AssignFile(input, FIN);   reset(input);
  AssignFile(output, FOUT); rewrite(output);
  read(n, m);
  for i := 1 to m do begin
    read(u, v);
    addEdge(e[u], v);
    addEdge(e[v], u);
    end;
  BFS(1, 0);
  close(input);
  close(output);
end.

O(v + e)

Rem. Здесь использована стандартная Дельфийская очередь, не используйте её никогда, т. к. она медленная!


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

program Floyd;
const
  FIN  = 'floyd.in';
  FOUT = 'floyd.out';
  INF = high(integer) div 2 - 1;
  NMAX = 300;
 
var A: array[1..NMAX, 1..NMAX] of integer;
    i, j, k, w, n, u, v, m: integer;
begin
  AssignFile(input, FIN);   reset(input);
  AssignFile(output, FOUT); rewrite(output);
  read(n, m);
 
  for i := 1 to n do begin
    for j := 1 to n do begin
      A[i, j] := INF;
      end;
    A[i, i] := 0;
    end;
 
 
  for i := 1 to m do begin
    read(u, v, w);
    A[u, v] := w;
    end;
 
  // Ищем расстояния от всех вершин до всех
  for k := 1 to n do begin
    for i := 1 to n do begin
      for j := 1 to n do begin
        if A[i, j] > A[i, k] + A[k, j] then
          A[i, j] := A[i, k] + A[k, j];
        end;
      end;
    end;
 
  // Проверяем наличие циклов отрицательного веса
  for i := 1 to n do begin
    for j := 1 to n do begin
      if A[i, j] = INF then write('-1 ')
      else write(A[i, j], ' ');
      end;
    writeln;
    end;
 
  close(input);
  close(output);
end.

O(v^3)

Алгоритм Форда-Беллмана

Просто V-1 раз релаксируем все рёбра, на каждом шаге найдены все кратчайшие пути из i рёбер

program Ford_Bellman1;
const
  FIN  = 'fordbell.in';
  FOUT = 'fordbell.out';
  NMAX = 200;
  INF  = high(integer) div 2 - 1;
 
type
  PEdge = ^TEdge;
  TEdge = record
    u, v, w: integer;
    next: PEdge;
    end;
 
procedure addEdge(var l: PEdge; const u, v, w: integer);
var t: PEdge;
begin
  new(t);
  t.next := l;
  t.u := u;
  t.v := v;
  t.w := w;
  l := t;
end;
 
var
  n: integer;
  m: integer;
  e: PEdge;
 
procedure Ford_Bellman(const s, t: integer);
var i, k: integer;
    cur: PEdge;
    dist: array[1..NMAX] of integer;
    prev: array[1..NMAX] of integer;
begin
  for i := 1 to n do begin
    dist[i] := INF;
    prev[i] := -1;
    end;
 
  prev[s] := 0;
  dist[s] := 0;
 
  for k := 1 to n - 1 do begin
    cur := e;
    for i := 1 to m do begin
      if dist[cur.v] > dist[cur.u] + cur.w then begin
        dist[cur.v] := dist[cur.u] + cur.w;
        prev[cur.v] := cur.u;
        end;
      cur := cur.next;
      end;
    end;
 
  for i := 1 to n - 1 do write(dist[i], ' ');
  writeln(dist[n]);
end;
 
var i, u, v, w: integer;
begin
  AssignFile(input, FIN);   reset(input);
  AssignFile(output, FOUT); rewrite(output);
  read(n, m);
 
  for i := 1 to m do begin
    read(u, v, w);
    addEdge(e, u, v, w);
    end;
 
  Ford_Bellman(1, 0);
 
  close(input);
  close(output);
end.

O(v * e)



Итак, у меня есть ещё десяток алгоритмов, пока попытаюсь найти время на пояснение этих