Re: Shortest Path Problem

*To*: mathgroup at smc.vnet.net*Subject*: [mg96683] Re: Shortest Path Problem*From*: Antonio <aneves at gmail.com>*Date*: Fri, 20 Feb 2009 05:48:11 -0500 (EST)*References*: <gn622n$iet$1@smc.vnet.net> <200902161157.GAA03525@smc.vnet.net>

Yes there is a big difference in Timing hanks for the tip. As for the unnecessary matrix, I decided to leave them just o better illustrate the problem, in the final optimized code, hopefully there will be only one. I will try to explain my problem to you and hope that you can help solve it. Is it possible to have a copy of your dissertation? The problem I have is a board game. The map in which the pieces move is made out of a grid of squares just like a chess board (with coordinates "x" and "y"). You have the possibility of moving in 8 directions: up, down, left, right, and diagonals. But our pieces on this board has movement points that are deducted from the square that the "piece would move into". The weights ranges from 1 to 6. As an example, Let us suppose that our piece is standing on a square of weight w1 and to the right there is a square o weight w2, if our piece moves to that square it would cost him w2 off his movement points, and if it goes back it would deduce w1. Anyhow this big (x,y grid) 250x250, i've wrote it as a matrix in the current problem as MyGrid. And how to efficiently translate this into a Graph, taking care of the limited arcs at the border and vertices of MyGrid is the task. After this is complete I would like to move my piece on the board, Wolfram enhanced, (hehehe) from an arbitrary point in the board (x1,y1) to (x2,y2) with the least movement cost for my piece. I hope I helped in making the problem clearer. Regards, Antonio On Feb 16, 10:40 pm, DrMajorBob <btre... at austin.rr.com> wrote: > Many things can be done to optimize speed and memory. For instance, compa= re > > Timing[PossiblePositions = Tuples[Range[n], 2]; > NearestNeighbours = > Table[Intersection[{{i - 1, j - 1}, {i - 1, j}, {i - 1, j + 1}, {i= , > j - 1}, {i, j + 1}, {i + 1, j - 1}, {i + 1, j}, {i + 1, j = + 1}}, > PossiblePositions], {i, n}, {j, n}];] > > {0.786135, Null} > > with > > Timing[nearest = > DeleteCases[ > Table[{{i - 1, j - 1}, {i - 1, j}, {i - 1, j + 1}, {i, j - 1},= {i, > j + 1}, {i + 1, j - 1}, {i + 1, j}, {i + 1, j + 1}}, {= i, > n}, {j, n}], {0, _} | {_, 0} | {51, _} | {_, 51}, Infinity= ];] > > {0.033157, Null} > > nearest == NearestNeighbours > > True > > (Big difference in Timing, don't you think?) > > On the memory side of things, these matrices are probably unnecessary: = > NodesPosition, PossiblePositions, and WeightPositions. > > Too much of BuildWeightMatrix consists of infinite-weighted arcs: > > Count[BuildWeightMatrix, Infinity, {2}] > > 6230596 > > The major bottleneck you mentioned is in creating, then eliminating, thos= e > arcs... more than 6 million of them. > > If n=250, not 50, I suppose you'd have about THIS many: > > 50*50*% > > 15576490000 > > Using EdgeWeight in FromAdjacencyMatrix confirms my earlier suspicion tha= t > MyGrid lists arcs, NOT nodes. > > If you really want to reach n=250, explain the problem to me. > > I solved MUCH larger shortest-path problems for my dissertation, more tha= n > 20 years ago... when computers were SLOW. > > Bobby > > > > On Mon, 16 Feb 2009 05:57:53 -0600, Antonio <ane... at gmail.com> wrote: > > Thank you all, I finally understood and got the problem done. Here is > > the code I used, > > > << Combinatorica` > > n = 50; > > (* Define my nxn Random Map *) > > MyGrid = Table[RandomInteger[{1, 6}], {i, 1, n}, {j, 1, n}]; > > (* Number of points on the map corrsponds to the number of nodes *) > > Nodes = Flatten[MyGrid]; > > NodesPosition = Range[Length[Nodes]]; > > PossiblePossitions = Tuples[Range[n], 2]; > > NearestNeighbours = > > Table[Intersection[{{i - 1, j - 1}, {i - 1, j}, {i - 1, j + 1}, {i, > > j - 1}, {i, j + 1}, {i + 1, j - 1}, {i + 1, j}, {i + 1, j += 1}}, > > PossiblePossitions], {i, n}, {j, n}]; > > WeightValues = > > Flatten[Apply[MyGrid[[#1, #2]] &, NearestNeighbours, {3}], 1]; > > WeightPositions = > > Flatten[Apply[n*(#1 - 1) + #2 &, NearestNeighbours, {3}], 1]; > > BuildWeightMatrix = > > Table[If[MemberQ[WeightPositions[[i]], j], > > WeightValues[[i, > > Position[WeightPositions[[i]], j][[1, 1]]]], \[Infinity]], = {i, > > n^2}, {j, n^2}]; > > sp = ShortestPath[FromAdjacencyMatrix[BuildWeightMatrix, EdgeWeight], > > 1, n^2]; > > MatrixForm[MyGrid] > > (*MatrixForm[BuildWeightMatrix*) > > sp > > Print["Movement cost is ", Total[Flatten[MyGrid][[Drop[sp, 1]]]]] > > MatrixPlot[MyGrid, > > Epilog -> {Thick, > > Line[{n - Mod[sp, n, 1] + 0.5, > > Quotient[sp - Mod[sp, n, 1], n] + 0.5}\[Transpose]]}, > > ColorRules -> {1 -> Red, 2 -> Orange, 2 -> Yellow, 3 -> Green, > > 4 -> Blue, 5 -> Magenta, 6 -> Purple}] > > > Some of the code proposed crashed the kernel and in this one the > > bottle neck is in the IF conditional inside the table > > (BuildWeightMatrix) and the ShortestPath command. This here is for > > n=50, and actually I would like to solve something bigger like n=25= 0. > > So if you guys can make the code more efficient, please let me know. > > > Regards, > > Antonio > > > On 14 Feb, 10:15, DeLouis Dana <dana.... at gmail.com> wrote: > >> > (up,down,left,right and the 4 diagonals) > > >> > So all directions are possible but they > >> > are asymetrical in the sense that they have diferent weights if g= oin= > > g > >> > foward or backward. > >> > All I know is that I have to use the Combinatorica package > > >> Hi. Here are some commands you may find helpful. > >> This is not complete because the diagonals are not complete. > >> I'm not sure what an efficient method for the diagonals would be just > >> yet. > >> I'm using Mathematica ver 7. > > >> Because the diagonals are not complete, I made it a simple graph by > >> removing the double path (combined path 2-3, and 3-2) > > >> This is just a 5 * 5 grid. > >> Hopefully, this will give you some ideas to work with. > > >> Needs["Combinatorica`"] > > >> n = 5; > >> g = GridGraph[n, n]; > >> g = SetEdgeWeights[g, RandomInteger[{1, 5}, M[g]]]; > > >> diag = Table[ > >> s = (r - 1)*n + c; > >> {{s, s + n + 1}, {s, s + n - 1}, {s, s - n + 1}, {s, > >> s - n - 1}}, {r, 2, n - 1}, {c, 2, n - 1}]; > > >> diag = Flatten[diag, 2] // Sort; > > >> g = AddEdges[g, diag]; > > >> g = SetEdgeWeights[g, diag, RandomInteger[{1, 5}, Length[diag]]]; > > >> g = MakeSimple[g]; > > >> pth = Partition[ShortestPath[g, 1, n*n], 2, 1]; > > >> g = SetEdgeLabels[g, GetEdgeWeights[g]]; > > >> ShowGraph[ > >> Highlight[g, {pth}, > >> HighlightedEdgeColors -> Red], > >> VertexNumber -> True, > >> VertexNumberColor -> Blue] > > >> = = = > >> HTH > >> Dana DeLouis > > >> Antonio wrote: > > >> > Dear Mathematica Users, > > >> > I am not familiar with Graph theory and hope that some Mathematic= a > >> > users might help me. I am having a Shortest path problem that I h= ope > >> > 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= sa= > > y > >> > MyGrid[[10, 10]] to point B MyGrid[[1, 1]]. For every point insid= e > >> > 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 lo= ng = > > >> as > >> > if going from (2,4) to (2,3). So all directions are possible but = the= > > y > >> > are asymetrical in the sense that they have diferent weights if g= oin= > > g > >> > 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 th= e > >> > 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. > > -- > DrMajor... at longhorns.com

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

**Re: Re: Help with Mathematica 7.0**

**What is "Depth of Atomic Objects" ?**

**Re: Re: Shortest Path Problem**

**Re: Shortest Path Problem**