Алгоритмы Йена, Дейкстри, Флойда, Форда , поиск кратчайших путей в графах, реализации

[Dewei]

Есть у кого готовые реализации на Pascal? )

http://alglib.sources.ru/graphs/ - тут сами алгоритмы

[Морской Ёж]

Алгоритм Йена я не знаю. другие могу реальзовать. Начнем с самого простого. Флойда.
Пусть у тебя есть матрица смежности графа a[i,j] и n-кол-во ребер. тогда:

...
for k := 1 to n do
  for i := 1 to n do
    for j := 1 to n do
      if a[i,j]>a[i,k]+a[k,j] then a[i,j]:=a[i,k]+a[k,j];
...

Теперь форд беллман

type
  trebro=record
    a,b,r:longint;
var
  a:array[1..m] of trebro; //список ребер графа
  d:array[1..n] of longint; //расстояние до n-й вершины.
//m-кол-во ребер; n-кол-во вершин.
...
  fillchar(d,sizeof(d),бесконечность); //:)
  d[q]:=0;//расстояние до начальной вершины
  for i := 1 to n-1 do
    for j := 1 to m do
      if d[a[j].b]>d[a[j].a]+a[j].r then d[a[j].b]:=d[a[j].a]+a[j].r;
...

теперь дейкстра.

var
  a:array[1..n,1..n] of longint;//матрица смежности (-1 нет ребра)
  b:array[1..100,a..100]of boolean;//список просмотренных вершин
  d:array[1..n] of longint;//расстояния
...
  fillchar(b,sizeof(b),0);
  fillchar(d,sizeof(d),бесконечность); //:)
  d[q]=0;//расстояние до начальной вершины
  for i:=1 to n do
    begin
       m:=1000;
       for j:=1 to n do
     if ((d[j]<=m)and(not b[j])) then
       begin
         m:=d[j];
             v:=j;
       end;
       b[v]:=true;
       for j:=1 to n do
     if ((a[v,j]<>-1)and(not b[j])and
        (d[v]+a[v,j]<d[j])) then d[j]:=d[v]+a[v,j];
    end;

если надо могу еще выложить хип дейкстру.

[Mr.Dmitry]

Я дико извиняюсь что поднимаю эту тему, но в правилах я не видел что можно поднимать старые темы )
У меня таже проблема, нужно найти кратчайшие пути между всеми вершинами графа. Применил алгоритм Флойда в своем проекте.

procedure TMain.N19Click(Sender: TObject);
var
 k,i,j,n:integer;
begin
n:=0;
for I := 0 to length(CGYMatrix)-1 do
for j := 0 to length(CGYMatrix)-1 do
begin
  if CGYMatrix[i,j]<>0 then
   inc(n);
end;
n:=round(n/2);
form3.memo1.Clear;
form3.Memo1.Lines.Add('Кратчайший путь по алгоритму Флойда:');
for k := 1 to n do
for i := 1 to n do
for j := 1 to n do
if CGYMatrix[i,j]>CGYMatrix[i,k]+CGYMatrix[k,j] then
memo1.Lines.Add(inttostr(CGYMatrix[i,k]+CGYMatrix[k,j]));
end;

CGYMatrix - Матрица смежности
n:=round(n/2); - нахожу количество ребер в графе.

При выполнение кода, в memo выходится куча 0 в столбик ((

Сообщение отредактировано: Mr.Dmitry - 10.09.15, 18:01

[MBo]

В первых циклах нумерация с нуля, а во вторых- с единицы?
И почему циклы до n, если это не размер матрицы, а количество ненулевых элементов?

[Федосеев Павел]

И это

for k := 1 to n do
for i := 1 to n do
for j := 1 to n do
if CGYMatrix[i,j]>CGYMatrix[i,k]+CGYMatrix[k,j] then
memo1.Lines.Add(inttostr(CGYMatrix[i,k]+CGYMatrix[k,j]));

лишь подобие алгоритма Флойда, даже если n - размер матрицы.

Одно из многочисленных описаний алгоритма.

Сообщение отредактировано: Федосеев Павел - 11.09.15, 05:56

[Mr.Dmitry]

Цитата Федосеев Павел @ 11.09.15, 05:54

И это

for k := 1 to n do
for i := 1 to n do
for j := 1 to n do
if CGYMatrix[i,j]>CGYMatrix[i,k]+CGYMatrix[k,j] then
memo1.Lines.Add(inttostr(CGYMatrix[i,k]+CGYMatrix[k,j]));

лишь подобие алгоритма Флойда, даже если n - размер матрицы.

Одно из многочисленных описаний алгоритма.

Спасибо за ссылочку. А нет подобных ссылок на алгоритм Беллмана и Дейкстра?

По ссылки приведенные примеры на C. А по мимо того что я плохо знаю этот язык так там еще все через вектора... нет ли ссылки на эти же алгоритмы в delphi? )

Сообщение отредактировано: Mr.Dmitry - 11.09.15, 15:56

[Федосеев Павел]

На другом форуме полгода назад в вашей теме я приводил реализацию на Pascal алгоритма Флойда-Уоршелла.

{Реализация алгоритма Флойда-Уоршелла}
program FloydWarshall;
const
  n = 5; {количество вершин графа}
  INFINITY = MaxInt;
type
  TRow = array [0..n - 1] of integer;
  TVertex = array [0..n - 1] of TRow;
const
  Vertex1: TVertex =
    (
    (0, 0, 5, 0, 0),
    (7, 0, 0, 0, 10),
    (0, 7, 0, 0, 0),
    (0, 0, 6, 0, 4),
    (0, 0, 1, 0, 0)
    );
  Vertex2: TVertex =
    (
    (0, 3, 2, 0, 0),
    (0, 0, 0, 4, 0),
    (0, 0, 0, 6, 0),
    (0, 0, 0, 0, 2),
    (0, 0, 0, 0, 0)
    );
  procedure FloydWarshall(v: TVertex; n: integer; var d, p: TVertex);
  var
    i, j, k: integer;
  begin
    {
    матрицу веса дуги преобразуем в требуемый для алгоритма вид
    - если i=j, то d[i, j]:=0
    - если из i в j нет ребра, то d[i, j]:=INFINITY (бесконечности)
    - иначе d[i, j] равно весу ребра из i в j
    подготовим матрицу для восстановления пути p
    }
    d := v;
    for i := 0 to pred(n) do
      for j := 0 to pred(n) do
      begin
        if d[i, j] = 0 then
          d[i, j] := INFINITY;
        if i = j then
          d[i, j] := 0;
        p[i, j] := j;
      end;
    for k := 0 to pred(n) do
    begin
      for i := 0 to pred(n) do
      begin
        for j := 0 to pred(n) do
        begin
          if (d[i, k] <> INFINITY) and (d[k, j] <> INFINITY) then
          begin
            if (d[i, j] > d[i, k] + d[k, j]) then
            begin
              d[i, j] := d[i, k] + d[k, j];
              p[i, j] := p[i, k];
            end;
          end;
        end;
      end;
    end;
  end;
  procedure RestorePath(const D, P: TVertex; n: integer; A, B: integer);
  var
    k: integer;
  begin
    if A >= n then
    begin
      writeln('The vertex A is out of range.');
      exit;
    end;
    if B >= n then
    begin
      writeln('The vertex B is out of range.');
      exit;
    end;
    if D[A, B] = INFINITY then
    begin
      writeln('There is not a path from vertex ', A, ' to vertex ', B, '.');
      exit;
    end;
    Write('The path from vertex ', A, ' to vertex ', B, ' is: <');
    Write(A: 4);
    k := A;
    while k <> B do
    begin
      k := p[k, B];
      Write(k: 4);
    end;
    writeln('>');
  end;
  procedure ShowMatrix(const M: TVertex; n: integer);
  var
    i, j: integer;
  begin
    for i := 0 to pred(n) do
    begin
      for j := 0 to pred(n) do
      begin
        if M[i, j] <> INFINITY then
          Write(M[i, j]: 4)
        else
          Write('inf': 4);
      end;
      writeln;
    end;
  end;
  procedure TestAlgoFW(const Vertex: TVertex; n: integer);
  var
    D, P: TVertex;
  begin
    FloydWarshall(Vertex, n, D, P);
    writeln('Vertex matrix:');
    ShowMatrix(Vertex, n);
    writeln('Distance matrix:');
    ShowMatrix(D, n);
    writeln('Path matrix:');
    ShowMatrix(P, n);
    RestorePath(D, P, n, 3, 1);
    RestorePath(D, P, n, 0, 3);
    RestorePath(D, P, n, 3, 3);
  end;
begin
  TestAlgoFW(Vertex1, n);
  TestAlgoFW(Vertex2, n);
end.

Здесь единственное допущение - мне было лень в константных матрицах набирать INFINITY, и я набрал 0, а потом в программе заменил все 0 на INFINITY.

Сообщение отредактировано: Федосеев Павел - 11.09.15, 16:32