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