Services & ResourcesWolfram ForumsMathGroup Archive

[Date Index] [Thread Index] [Author Index]

Re: Shortest Path Problem

• To: mathgroup at smc.vnet.net
• Subject: [mg96355] Re: [mg96293] Shortest Path Problem
• From: Daniel Lichtblau <danl at wolfram.com>
• Date: Thu, 12 Feb 2009 06:36:07 -0500 (EST)
• References: <200902111018.FAA16939@smc.vnet.net>

Antonio wrote:
> Dear Mathematica Users,
> 
> I am not familiar with Graph theory and hope that some Mathematica
> users might help me. I am having a Shortest path problem that I hope
> to solve using Mathematica.
> 
> My input is a Grid defind as,
> 
> MyGrid = Table[RandomInteger[{1, 5}], {i, 1, 10}, {j, 1, 10}]
> 
> in this 10x10 grid i'd like the shortest path from point A, let's say
> MyGrid[[10, 10]] to point B MyGrid[[1, 1]]. For every point inside
> this square grid I have 8 possible directions or lines
> (up,down,left,right and the 4 diagonals). The weight of each step is
> given inside the MyGrid cell, i.e. let MyGrid[[2, 3]]=1 and MyGrid[[2,
> 4]]=3
> So in going from coordinate (2,3) to (2,4) it takes 3 times as long as
> if going from (2,4) to (2,3). So all directions are possible but they
> are asymetrical in the sense that they have diferent weights if going
> foward or backward.
> 
> I tried reading Mathematica help but it is very poor with no examples.
> All I know is that I have to use the Combinatorica package and the
> ShortestPath[] command, but as a start I have no idea in how to create
> a Graph needed as input to this command from MyGrid.
> 
> Thanks in advanced.


There are probably a few good ways to do this. Specifics will depend on 
whether you want just the distances or also the routes. the code below 
finds only the distances. Well, at least, I think that's what it finds. 
It also makes the tacit assumption that your grid is square rather than 
an arbitrary rectangle. One could modify to work around such restrictions.

The first thing is to set up a graph, that is, a set of edges. If 
vertices are indexed v[j,k] then we have edges from each v[j,k] to 
neighbors v[j',k'] where j' is within 1 of j and likewise for k' vs k, 
and also they are within bounds. The code below purports to set up an 
edge matrix, with a weighted edge value given by the destination value 
in your original grid. Disconnected vertix pairs get an edge with a 
value that is too large to affect the eventual outcome (I want to use 
only explicit integer values, so I can use Compile later).

I should mention that this edge matrix I am creating is dense, whereas 
we really only need a sparse form since number of neighbors per vertex 
is at most 8. But...the end result will be a dense "graph" of the same 
dimension as the edge matrix, so we do not lose anything by this except 
perhaps the ability to use fast Mathematica functionality built into 
handling of SparseArray objects. Okay, that might be losing alot, but, 
undaunted, we proceed anyway.

gridToGraph[grid_] :=
  Module[{vertices, nver, dim, max = Max[grid], infin, weight, row,
    col, rj, ck, source, dest},
   vertices = Flatten[Array[v, Dimensions[grid]]];
   dim = Length[grid];
   nver = Length[vertices];
   infin = nver*max + 1;
   edges = Table[infin, {nver}, {nver}];
   Do[ver = vertices[[i]];
    {row, col} = {ver[[1]], ver[[2]]};
    weight = grid[[row, col]];
    dest = dim*(row - 1) + col;
    Do[
     rj = row + j;
     ck = col + k;
     If[1 <= rj <= dim && 1 <= ck <= dim && (j != 0 || k != 0),
      source = dim*(rj - 1) + ck;
      edges[[source, dest]] = weight
      ],
     {j, -1, 1}, {k, -1, 1}],
    {i, nver}];
   edges]

Here is a simple example, using a 4x4 grid.

In[68]:= myGrid = Table[RandomInteger[{1, 5}], {i, 1, 4}, {j, 1, 4}]
Out[68]= {{2, 2, 2, 2}, {2, 3, 1, 5}, {5, 4, 2, 1}, {1, 3, 1, 1}}

Here is the corresponding edge matrix. Notice it is 16x16, because we 
have 4x4=16 vertices. It's not too hard to figure out which edges 
correspond to which vertex pairs.

In[69]:= edgemat = gridToGraph[myGrid]
Out[69]= {
  {81, 2, 81, 81, 2, 3, 81, 81, 81, 81, 81, 81, 81, 81, 81, 81},
  {2, 81, 2, 81, 2, 3, 1, 81, 81, 81, 81, 81, 81, 81, 81, 81}, {81, 2,
   81, 2, 81, 3, 1, 5, 81, 81, 81, 81, 81, 81, 81, 81}, {81, 81, 2, 81,
    81, 81, 1, 5, 81, 81, 81, 81, 81, 81, 81, 81}, {2, 2, 81, 81, 81,
   3, 81, 81, 5, 4, 81, 81, 81, 81, 81, 81}, {2, 2, 2, 81, 2, 81, 1,
   81, 5, 4, 2, 81, 81, 81, 81, 81}, {81, 2, 2, 2, 81, 3, 81, 5, 81, 4,
    2, 1, 81, 81, 81, 81}, {81, 81, 2, 2, 81, 81, 1, 81, 81, 81, 2, 1,
   81, 81, 81, 81}, {81, 81, 81, 81, 2, 3, 81, 81, 81, 4, 81, 81, 1, 3,
    81, 81}, {81, 81, 81, 81, 2, 3, 1, 81, 5, 81, 2, 81, 1, 3, 1,
   81}, {81, 81, 81, 81, 81, 3, 1, 5, 81, 4, 81, 1, 81, 3, 1, 1}, {81,
   81, 81, 81, 81, 81, 1, 5, 81, 81, 2, 81, 81, 81, 1, 1}, {81, 81, 81,
    81, 81, 81, 81, 81, 5, 4, 81, 81, 81, 3, 81, 81}, {81, 81, 81, 81,
   81, 81, 81, 81, 5, 4, 2, 81, 1, 81, 1, 81}, {81, 81, 81, 81, 81, 81,
    81, 81, 81, 4, 2, 1, 81, 3, 81, 1}, {81, 81, 81, 81, 81, 81, 81,
   81, 81, 81, 2, 1, 81, 81, 1, 81}}

I now adapt some code for the Floyd-Warshall algorithm, to find all 
distances between vertices. The last time I used this, in October 2005, 
it was not appropriate for the task at hand. I am cautiously optimistic 
that it is better employed this time.

FloydWarshallC = Compile[{{graph, _Integer, 2}}, Module[
     {dist = graph, i1, i2, n = Length[graph], max = Max[graph]},
     Do[dist[[j, j]] = 1, {j, n}];
     Do[dist[[i, j]] =
        Min[dist[[i, j]], dist[[i, k]] + dist[[k, j]]];, {k, n}, {i,
       n}, {j, n}];
     dist]];

Now we obtain the matrix of directed distances.

In[70]:= FloydWarshallC[edgemat]
Out[70]= {{1, 2, 4, 5, 2, 3, 3, 8, 7, 6, 5, 4, 7, 8, 5, 5}, {2, 1, 2,
   3, 2, 3, 1, 6, 7, 5, 3, 2, 6, 6, 3, 3}, {4, 2, 1, 2, 4, 3, 1, 5, 8,
   5, 3, 2, 6, 6, 3, 3}, {5, 3, 2, 1, 5, 4, 1, 5, 9, 5, 3, 2, 6, 6, 3,
   3}, {2, 2, 4, 5, 1, 3, 3, 8, 5, 4, 5, 4, 5, 7, 5, 5}, {2, 2, 2, 3,
   2, 1, 1, 6, 5, 4, 2, 2, 5, 5, 3, 3}, {4, 2, 2, 2, 4, 3, 1, 5, 8, 4,
   2, 1, 5, 5, 2, 2}, {5, 3, 2, 2, 5, 4, 1, 1, 9, 5, 2, 1, 6, 5, 2,
   2}, {4, 4, 5, 6, 2, 3, 4, 9, 1, 4, 5, 5, 1, 3, 4, 5}, {4, 3, 3, 3,
   2, 3, 1, 6, 5, 1, 2, 2, 1, 3, 1, 2}, {5, 3, 3, 3, 5, 3, 1, 5, 8, 4,
   1, 1, 4, 3, 1, 1}, {5, 3, 3, 3, 5, 4, 1, 5, 9, 5, 2, 1, 5, 4, 1,
   1}, {8, 7, 7, 7, 6, 7, 5, 10, 5, 4, 5, 5, 1, 3, 4, 5}, {7, 5, 5, 5,
   6, 5, 3, 7, 5, 4, 2, 2, 1, 1, 1, 2}, {6, 4, 4, 4, 6, 5, 2, 6, 8, 4,
   2, 1, 4, 3, 1, 1}, {6, 4, 4, 4, 6, 5, 2, 6, 9, 5, 2, 1, 5, 4, 1, 1}}

So there we have the resulting matrix of directed distances between 
pairs of vertices. Apologies if it turns out there is a much simpler way 
of going about this.

Daniel Lichtblau
Wolfram Research

• References:
  • Shortest Path Problem
    • From: Antonio <aneves@gmail.com>