Форум на Исходниках.RU https://forum.sources.ru Форум на Исходниках.RU Форум на Исходниках.RU https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1546816 Mon, 30 Apr 2007 04:37:42 +0000 Требуется! https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1546816 Дейкстра с бинарным деревом (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.




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

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

    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)



Итак, у меня есть ещё десяток алгоритмов, пока попытаюсь найти время на пояснение этих :rolleyes:]]> Glex Все языки: Статьи, заготовки в FAQ https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1424191 Tue, 23 Jan 2007 06:13:30 +0000 Требуется&#33; https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1424191 пояснений алгоритмом и в коде нет смысла в данных ссылках, поисковиками все умеют пользоваться.]]> Romtek Все языки: Статьи, заготовки в FAQ https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1417316 Wed, 17 Jan 2007 13:27:24 +0000 Требуется&#33; https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1417316 http://education.aspu.ru/page.php?id=152

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

Добавлено
Сборник исходников "Алгоритмы на графах" : есть много всего интересного
http://borisvolfson.h11.ru/programs/graphs.rar]]> -=Makc=- Все языки: Статьи, заготовки в FAQ https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1400087 Wed, 03 Jan 2007 19:03:58 +0000 Требуется&#33; https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1400087
      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;
]]> SkyStar Все языки: Статьи, заготовки в FAQ https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1395855 Fri, 29 Dec 2006 14:53:59 +0000 Требуется&#33; https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1395855 Цитата Romtek @
А как насчёт пояснения как и почему?.

Хорошо.

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

Булева сумма и произведение пишутся как и для обычных матриц.]]> Artful Fox Все языки: Статьи, заготовки в FAQ https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1395839 Fri, 29 Dec 2006 14:22:12 +0000 Требуется&#33; https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1395839 Artful Fox, благодарю за код. ;)
А как насчёт пояснения как и почему?.]]> Romtek Все языки: Статьи, заготовки в FAQ https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1395205 Thu, 28 Dec 2006 22:04:00 +0000 Требуется&#33; https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1395205 Матрица достижимости:
    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 Все языки: Статьи, заготовки в FAQ https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1387612 Fri, 22 Dec 2006 18:12:34 +0000 Требуется&#33; https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1387612 volvo877, держать копию бумажных книг не есть цель FAQ, а собирание наиболее популярных алгоритмов и их реализация на Паскале. Книгу мы не в состоянии заменить, да и нет нужды.]]> Romtek Все языки: Статьи, заготовки в FAQ https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1386867 Fri, 22 Dec 2006 10:28:02 +0000 Требуется&#33; https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1386867 Romtek, в книге "Структуры данных и алгоритмы" (Ахо, Хопрофт, Ульман) теме алгоритмов на графах посвящены 2 главы: 6-я ("Ориентированные графы") и 7-я ("Неориентированные графы"), итого - страницы 183-227 (со схемами, примерами программ, теоретическими обоснованиями, и т.д.) Полнее вряд ли что-то можно себе представить...

Можно, конечно это переконвертировать из DJVU в другой формат и выложить в FAQ-е, но что будем делать с (С)?]]> volvo877 Все языки: Статьи, заготовки в FAQ https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1385637 Thu, 21 Dec 2006 14:08:00 +0000 Требуется&#33; https://forum.sources.ru/index.php?showtopic=165597&view=findpost&p=1385637
  • Поиск в ширину
  • Поиск в глубину
  • Вычисление матрицы достижимости
  • другие?

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

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

Кто возьмётся? ;)]]> Romtek Все языки: Статьи, заготовки в FAQ