MathGroup Archive 2009

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

Search the Archive

Re: Re: Shortest Path Problem

  • To: mathgroup at smc.vnet.net
  • Subject: [mg96585] Re: [mg96554] Re: Shortest Path Problem
  • From: DrMajorBob <btreat1 at austin.rr.com>
  • Date: Mon, 16 Feb 2009 16:40:36 -0500 (EST)
  • References: <gn622n$iet$1@smc.vnet.net> <200902161157.GAA03525@smc.vnet.net>
  • Reply-to: drmajorbob at longhorns.com

Many things can be done to optimize speed and memory. For instance, compare

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, those  
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 that  
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 than  
20 years ago... when computers were SLOW.

Bobby

On Mon, 16 Feb 2009 05:57:53 -0600, Antonio <aneves 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=250.
> 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 goin=
> 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 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 sa=
> y
>>  > 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 the=
> y
>>  > are asymetrical in the sense that they have diferent weights if goin=
> 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 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.
>>  >
>
>



-- 
DrMajorBob at longhorns.com


  • Prev by Date: Re: Length of a held expression
  • Next by Date: Re: Howto change TraditionalForm Output
  • Previous by thread: Re: Shortest Path Problem
  • Next by thread: Re: Shortest Path Problem