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.