[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
Prev by Date:
**Re: Reposted, Reformatted Re: "mapping" functions over lists, again!**
Next by Date:
**New free introductory book on Mathematica programming, and a few**
Previous by thread:
**Re: Shortest Path Problem**
Next by thread:
**Re: Shortest Path Problem**
| |