Optimisation of a Dijkstra Shortest Path Search in Delphi

Question

I'm looking for advices to speed up my implementation of Dijkstra Shortest Path Search on a weighted graph which is a square matrix N x N. The weight on horizontal vertice is called H (resp. V on vertical ones).

A picture is worth a thousand words:

_{(source: free.fr)}

Of course, this is part of a bigger application, but I've extracted the relevant bit here:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

const
 N = 200; //Working on a grid of N x N, here for a quick test, in practice, it's more 10000

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  end;

  TNode = class
  public
    ID, //Number of the Node
    origin, //From which Node did I came?
    weight : integer; //The total weight of the path to Node ID
    done : boolean; //Is the Node already explored?
    constructor Create(myID, myOrigin, myweight: integer);
  end;

var
  Form1: TForm1;

implementation

var
  H, V : array of integer;
{$R *.dfm}

constructor TNode.Create(myID, myOrigin, myweight: integer);
begin
  ID:=MyID;
  origin:=MyOrigin;
  weight:=MyWeight;
end;

{------------------------------------------------------------------------------}

Function GetNodeFromID(ID: integer; NodeList: TList) : TNode; overload;
var
  I: Integer;
  Node: TNode;
begin
  result:=nil;
  for I := 0 to NodeList.count-1 do
  begin
    Node := NodeList[i];
    if Node.ID=ID then
    begin
      result:=Node;
      break;
    end;
  end;
end;

{------------------------------------------------------------------------------}

Function GetNodeOfMiniWeight(NodeList: TList) : TNode; overload;
var
  I, min: Integer;
  Node: TNode;
begin
  result:=nil;
  min :=maxint;
  for I := 0 to NodeList.count-1 do
  begin
    Node := NodeList[i];
    if Node.done then continue;
    if Node.weight < min then
    begin
      result:=Node;
      min := Node.weight;
    end;
  end;
end;

{------------------------------------------------------------------------------}

procedure SearchShortestPath(origin,arrival: integer);
var
  NewWeight: integer;
  NodeList : Tlist;
  NodeFrom, //The Node currently being examined
  NodeTo :TNode; //The Node where it is intented to go
  s : string;
begin
  NodeList := Tlist.Create;
  NodeFrom := TNode.Create(origin,MaxInt,0);
  NodeList.Add(NodeFrom);

  while not (NodeFrom.ID = arrival) do //Arrived?
  begin
    //Path toward the top
    if (NodeFrom.ID > N-1) //Already at the top of the grid
    and not(NodeFrom.origin-NodeFrom.ID = N) then //Coming from the top
    begin
      NewWeight:=NodeFrom.weight + H[NodeFrom.ID-N];
      NodeTo := GetNodeFromID(NodeFrom.ID-N, NodeList);
      if NodeTo <> nil then
      begin
        if NodeTo.weight > NewWeight then
        begin
          NodeTo.Origin:=NodeFrom.ID;
          NodeTo.weight:=NewWeight;
        end;
      end
      else
      begin
        NodeTo := TNode.Create(NodeFrom.ID-N,NodeFrom.ID,NewWeight);
        NodeList.Add(NodeTo);
      end;
    end;

    //Path toward the bottom
    if (NodeFrom.ID < N*N-N) //Already at the bottom of the grid
    and not(NodeFrom.Origin- NodeFrom.ID = N) then //Coming from the bottom
    begin
      NewWeight:=NodeFrom.weight + H[NodeFrom.ID];
      NodeTo := GetNodeFromID(NodeFrom.ID+N, NodeList);
      if NodeTo <> nil then
      begin
        if NodeTo.weight > NewWeight then
        begin
          NodeTo.Origin:=NodeFrom.ID;
          NodeTo.weight:=NewWeight;
        end;
      end
      else
      begin
        NodeTo := TNode.Create(NodeFrom.ID+N,NodeFrom.ID,NewWeight);
        NodeList.Add(NodeTo);
      end;
    end;

    //Path toward the right
    if not(NodeFrom.ID mod N = N-1) //Already at the extrem right of the grid
    and not(NodeFrom.Origin - NodeFrom.ID = 1) then  //Coming from the right
    begin
      NewWeight:=NodeFrom.weight + V[NodeFrom.ID];
      NodeTo := GetNodeFromID(NodeFrom.ID+1, NodeList);
      if NodeTo <> nil then
      begin
        if NodeTo.weight > NewWeight then
        begin
          NodeTo.Origin:=NodeFrom.ID;
          NodeTo.weight:=NewWeight;
        end;
      end
      else
      begin
        NodeTo := TNode.Create(NodeFrom.ID+1,NodeFrom.ID,NewWeight);
        NodeList.Add(NodeTo);
      end;
    end;

    //Path toward the left
    if not (NodeFrom.ID mod N = 0) //Already at the extrem right of the grid
    and not(NodeFrom.Origin - NodeFrom.ID = -1) then //Coming from the left
    begin
      NewWeight:=NodeFrom.weight + V[NodeFrom.ID-1];
      NodeTo := GetNodeFromID(NodeFrom.ID-1, NodeList);
      if NodeTo <> nil then
      begin
        if NodeTo.weight > NewWeight then
        begin
          NodeTo.Origin:=NodeFrom.ID;
          NodeTo.weight:=NewWeight;
        end;
      end
      else
      begin
        NodeTo := TNode.Create(NodeFrom.ID-1,NodeFrom.ID,NewWeight);
        NodeList.Add(NodeTo);
      end;
    end;
    NodeFrom.done :=true;
    NodeFrom:=GetNodeOfMiniWeight(NodeList);
  end;

  s:='The shortest path from '
    + inttostr(arrival) + ' to '
    + inttostr(origin) + ' is : ';
  //Get the path
  while (NodeFrom.ID <> origin) do
  begin
    s:= s + inttostr(NodeFrom.ID) + ', ';
    NodeFrom:=GetNodeFromID(NodeFrom.Origin, NodeList);
  end;
  s:= s + inttostr(NodeFrom.ID);
  ShowMessage(s);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SearchShortestPath(Random(N*N),Random(N*N));
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
begin
  //Initialisation
  randomize;
  SetLength(V,N*N);
  SetLength(H,N*N);
  for I := 0 to N*N-1 do
  begin
    V[I]:=random(100);
    H[I]:=random(100);
  end;
end;

end.

The code spend most of the time in the routines: GetNodeFromID and GetNodeOfMiniWeight, and a substantial time to create nodes.

I thought that I could use a binary search, but since it requires the list to be sorted, I think that I'll loose the time in sorting the list. Any advice is welcome.

Answer 1

First of all, use a profiler! For instance, see http://www.delphitools.info/samplingprofiler

Your current code has several weaknesses:

• It leaks memory (TNode/TNodeList instances);
• You may use dynamic arrays of records instead of individual class instances for nodes (with a count stored outside);
• I was not able to recognize your algorithm just by reading the code - so I guess you may enhance the code design.

The pseudo-code of this algorithm is as followed:

for all vertices v,
dist(v) = infinity;
dist(first) = 0;
place all vertices in set toBeChecked;
while toBeChecked is not empty
  {in this version, also stop when shortest path to a specific destination is found}
  select v: min(dist(v)) in toBeChecked;
  remove v from toBeChecked;
  for u in toBeChecked, and path from v to u exists
  {i.e. for unchecked adjacents to v}
  do
    if dist(u) > dist(v) + weight({u,v}),
    then
       dist(u) = dist(v) + weight({u,v});
       set predecessor of u to v
       save minimum distance to u in array "d"
     endif
  enddo
endwhile

Did you try this library from DelphiForFun ? Sounds like something already proven, updated recently, and well written. May be improved (e.g. using an array of bits instead array of boolean), but sounds pretty correct for a start.

Answer 2

I've implemented modification of Dijkstra Shortest Path algorithm for sparsed graphs. Your graph is very sparsed (E << V^2). This code uses priority queue based on binary heap, that contains (VerticeNum, DistanceFromSource) pairs as TPoints, ordered by Distance (Point.Y). It reveals loglinear (close to linear) asymptotic behavior. Example for small graph:

Times for i5-4670

N      V          time, ms
100    10^4       ~15
200    4*10^4     ~50-60  //about 8000 for your implementation 
400    1.6*10^5   100
1600   2.5*10^6   1300 
6400   4*10^7     24000
10000  10^8       63000 
//~max size in 32-bit OS due to H,V arrays memory consumption

code:

function SparseDijkstra(Src, Dest: integer): string;
var
  Dist, PredV: array of integer;
  I, j, vert, CurDist, toVert, len: integer;
  q: TBinaryHeap;
  top: TPoint;

  procedure CheckAndChange;
  begin
    if Dist[vert] + len < Dist[toVert] then begin
      Dist[toVert] := Dist[vert] + len;
      PredV[toVert] := vert;
      q.Push(Point(toVert, Dist[toVert]));
      //old pair is still stored but has bad (higher) distance value
    end;
  end;

begin
  SetLength(Dist, N * N);
  SetLength(PredV, N * N);
  for I := 0 to N * N - 1 do
    Dist[I] := maxint;
  Dist[Src] := 0;
  q := TBinaryHeap.Create(N * N);
  q.Cmp := ComparePointsByY;
  q.Push(Point(Src, 0));
  while not q.isempty do begin
    top := q.pop;
    vert := top.X;
    CurDist := top.Y;
    if CurDist > Dist[vert] then
      continue; //out-of-date pair (bad distance value)

    if (vert mod N) <> 0 then begin // step left
      toVert := vert - 1;
      len := H[toVert];
      CheckAndChange;
    end;
    if (vert div N) <> 0 then begin // step up
      toVert := vert - N;
      len := V[toVert];
      CheckAndChange;
    end;
    if (vert mod N) <> N - 1 then begin // step right
      toVert := vert + 1;
      len := H[vert];
      CheckAndChange;
    end;
    if (vert div N) <> N - 1 then begin // step down
      toVert := vert + N;
      len := V[vert];
      CheckAndChange;
    end;
  end;
  q.Free;

  // calculated data may be used with miltiple destination points
  result := '';
  vert := Dest;
  while vert <> Src do begin
    result := Format(', %d', [vert]) + result;
    vert := PredV[vert];
  end;
  result := Format('%d', [vert]) + result;
end;


procedure TForm1.Button2Click(Sender: TObject);
var
  t: Dword;
  I, row, col: integer;
begin
  t := GetTickCount;
  if N < 6 then // visual checker
    for I := 0 to N * N - 1 do begin
      col := I mod N;
      row := I div N;
      Canvas.Font.Color := clBlack;
      Canvas.Font.Style := [fsBold];
      Canvas.TextOut(20 + col * 70, row * 70, inttostr(I));
      Canvas.Font.Style := [];
      Canvas.Font.Color := clRed;
      if col < N - 1 then
        Canvas.TextOut(20 + col * 70 + 30, row * 70, inttostr(H[I]));
      Canvas.Font.Color := clBlue;
      if row < N - 1 then
        Canvas.TextOut(20 + col * 70, row * 70 + 30, inttostr(V[I]));
    end;
  Memo1.Lines.Add(SparseDijkstra({0, n*n-1}random(N * N), random(N * N)));
  Memo1.Lines.Add('time ' + inttostr(GetTickCount - t));
end;

Edit: TQPriorityQueue is class for internal use, but you can try any implementation of heap-based priority queue. For example, this one. You have to change Pointer to TPoint, Word to Integer in this module.

Edit2: I've replaced proprietary queue method names in my procedure by BinaryHeap methods.