MathGroup Archive 2009

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

Search the Archive

Re: Shortest Path Problem

  • To: mathgroup at smc.vnet.net
  • Subject: [mg96609] Re: Shortest Path Problem
  • From: DeLouis Dana <dana.del at gmail.com>
  • Date: Tue, 17 Feb 2009 06:25:36 -0500 (EST)

Hi.  Here's another variation that is similar to the op's solution  
that uses the "Nearest" function to find other points that are within  
Sqrt[2] away. (Rounded to 1.5 to make it a real number)

{* All one entry *)

Needs["Combinatorica`"]
n = 10;
Rng = Range[n*n];
grid = RandomInteger[{1, 6}, {n*n}];
pairs = Tuples[Range@n, 2];
Near = Map[Rest[Nearest[pairs -> Automatic, #, {\[Infinity], 1.5}]] &,
     pairs];
m = Table[
    p = Complement[Rng, Near[[j]]];
    p = List /@ p;
    ReplacePart[grid, p -> \[Infinity]], {j, 1, n*n}];
sp = ShortestPath[g = FromAdjacencyMatrix[m, EdgeWeight], 1, n*n];
Print["Distance: ", CostOfPath[g, sp]];
MyGrid = Partition[grid, n];

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, 3 -> Green, 4 -> Blue,
    5 -> Magenta, 6 -> Purple}]


(* End of Entry *)

(* I like the Grid Graph *)


gg = GridGraph[n, n];
pth = Partition[sp, 2, 1];
gg = AddEdges[gg, pth];
ShowGraph[Highlight[gg, {pth}, HighlightedEdgeColors -> Red],
  VertexNumber -> True,
  VertexNumberColor -> Blue,
  EdgeStyle -> Thin,
  ImageSize -> 800]



(* Some other ideas:  I moved the axes around a little to match...*)

ToLines[n_, b_] := {Mod[n, b, 1] - .5, Quotient[n, b, 1] + .5}

MyLine = Line[Map[ToLines[#, n] &, sp]];

MatrixPlot[MyGrid, DataReversed -> {True, False},
  Epilog -> {
    Circle[MyLine[[1, 1]], .3],
    Thick, MyLine,
    Disk[MyLine[[1, -1]], .1]},
  ImageSize -> 800,
  ColorFunction -> ColorData["LightTemperatureMap"]]



= = = =
HTH
Dana DeLouis
Using Ver 7 for Mac




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.
 >



  • Prev by Date: Re: Length of a held expression
  • Next by Date: Re: Re: Mathematica, ARPACK and implicit matrices
  • Previous by thread: Re: Shortest Path Problem
  • Next by thread: Reposted, Reformatted Re: "mapping" functions over lists, again!