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>

**Re: Reposted, Reformatted Re: "mapping" functions over lists, again!**

**New free introductory book on Mathematica programming, and a few**

**Re: Shortest Path Problem**

**Re: Shortest Path Problem**