8
$\begingroup$

Described on the page: http://www.mathblog.dk/project-euler-81-find-the-minimal-path-sum-from-the-top-left-to-the-bottom-right-by-moving-right-and-down/

It is an example of the solution indicated in red font.

Solution in the Mathematica looks like this:

grid={
{131,673,234,103,18},
{201,96,342,965,150},
{630,803,746,422,111},
{537,699,497,121,956},
{805,732,524,37,331}
      };

MinPath[i_, j_] := MinPath[i, j] =  (* Memoization *)
grid[[i, j]] + Piecewise[{
{Min[MinPath[i + 1, j], MinPath[i, j + 1]], i < Length[grid] && j < Length[grid[[i]]]},
{MinPath[i + 1, j], i < Length[grid]},
{MinPath[i, j + 1], j < Length[grid[[i]]]}},
0]

$RecursionLimit = 1000;
MinPath[1, 1]

Result: 2427

But how to determine the cells (their position) from which formed the solution? Mark by red font?

131 -> 201 -> 96 -> 342 -> 746 -> 422 -> 121 -> 37 -> 331

Position: {1,1} -> {2,1} -> {2,2} -> {2,3} -> {3,3} -> {3,4} -> {4,4} -> {5,4} -> {5,5}

enter image description here

How to determine the route that went algorithm?

Improve this question
$\endgroup$

5 Answers 5

Reset to default
4
$\begingroup$

With a slight modification of your MinPath function so that it takes a matrix as input

ClearAll[MinPathF, nextF]
MinPathF[mat_][i_, j_] := MinPathF[mat][i, j] = mat[[i, j]] + 
  Piecewise[{{Min[MinPathF[mat][i + 1, j], MinPathF[mat][i, j + 1]], 
          i < Length[mat] && j < Length[mat[[i]]]},
      {MinPathF[mat][i + 1, j], i < Length[mat]}, 
      {MinPathF[mat][i, j + 1], j < Length[mat[[i]]]}}, 0]

you can construct a function to generate the path

nextF[mat_][{i_, j_}] := If[i < Length[mat] && j < Length[mat[[i]]], 
  If[MinPathF[mat][i + 1, j] < MinPathF[mat][i, j + 1], {i + 1, j}, {i, j + 1}], 
  If[i < Length[mat], {i + 1, j}, If[j < Length[mat[[i]]], {i, j + 1}, {}]]]

Examples:

path = Most@NestWhileList[nextF[grid], {1, 1}, ! # === {} &]

{{1, 1}, {2, 1}, {2, 2}, {2, 3}, {3, 3}, {3, 4}, {4, 4}, {5, 4}, {5, 5}}

Grid @ MapAt[Framed[#, FrameStyle -> Directive[Thick, Red], Background -> Red] &, 
       grid, path]

Mathematica graphics

Alternatively,

Grid[grid, Background -> {Automatic, Automatic, Thread[path -> Red]}, 
 ItemStyle -> Directive[Bold, 24], Dividers -> All]

Mathematica graphics

randommat = RandomInteger[{0, 1000}, {10, 12}]; 

Grid@ MapAt[Framed[#, FrameStyle -> Directive[Thick, Red], Background -> Red] &, 
    randommat, Most@NestWhileList[nextF[randommat], {1, 1}, ! # === {} &]]

Mathematica graphics

Improve this answer
$\endgroup$
8
$\begingroup$

I wanted to be able to extract the path from your recursive memoized function, but I couldn't make it happen.

But here is a function to find the minimum path from the upper left to the bottom right corners of an array of numbers,

minimalpathsum[grid_] := 
 Module[{dims, vertcoords, graph, weights, path, indices},
  dims = Dimensions@grid;
  vertcoords = Flatten[Array[{#2, #1} &, dims], 1];
  graph = GridGraph[Reverse@dims,
    DirectedEdges -> True,
    VertexCoordinates -> vertcoords];
  weights = (graph // EdgeList) /. 
    a_ \[DirectedEdge] b_ :> Flatten[grid][[b]];
  graph = GridGraph[Reverse@dims,
    VertexCoordinates -> vertcoords,
    EdgeWeight -> weights,
    DirectedEdges -> True];
  path = FindShortestPath[graph, 1, Times @@ dims];
  indices = Reverse /@ vertcoords[[path]];
  Print[Row[{"indices =", indices}]];
  Print[Row[{"sum =", Total@Extract[grid, indices]}]];
  ArrayPlot[
   ReplacePart[
    ConstantArray[0, Dimensions@grid], indices -> 1], 
   Epilog -> {Red, 
     MapIndexed[Text[Style[#1, 18], Reverse[#2 - 1/2]] &, 
      Reverse[grid], {2}]}, Mesh -> True, ImageSize -> 400]
  ]

You can test it on your array:

minimalpathsum@{{131, 673, 234, 103, 18}, {201, 96, 342, 965, 
   150}, {630, 803, 746, 422, 111}, {537, 699, 497, 121, 956}, {805, 
   732, 524, 37, 331}}

enter image description here

Or on a larger, random array,

grid = RandomInteger[200, {15, 10}];
minimalpathsum@grid

enter image description here

How it works

First we make a GridGraph the same size as the matrix, with the vertices labeled in the same order,

graph = GridGraph[{5, 5}, 
  VertexCoordinates -> Flatten[Reverse@Array[{#2, #1} &, {5, 5}], 1], 
  DirectedEdges -> True, VertexLabels -> "Name"]

enter image description here

Next we assign the edge weights to be the value of the matrix element it ends on,

weights = (graph // EdgeList) /. 
   a_ \[DirectedEdge] b_ :> Flatten[grid][[b]];
graph = GridGraph[{5, 5}, 
  VertexCoordinates -> Flatten[Reverse@Array[{#2, #1} &, {5, 5}], 1], 
  EdgeWeight -> weights, EdgeLabels -> "EdgeWeight", 
  DirectedEdges -> True]

enter image description here

And now we can just use FindShortestPath to get the desired path,

path = FindShortestPath[graph, 1, 25]
(* {1, 6, 7, 8, 13, 14, 19, 24, 25} *)

And extract the matrix elements from the path,

Flatten[grid][[path]]
Total@%
(* {131, 201, 96, 342, 746, 422, 121, 37, 331} *)
(* 2427 *)

An easy way to find the position of these elements in the original array is

First@Position[grid, #] & /@ Flatten[grid][[path]]
(* {{1, 1}, {2, 1}, {2, 2}, {2, 3}, {3, 3}, {3, 4}, {4, 4}, {5,
   4}, {5, 5}} *)

You can show the path with HighlightGraph

HighlightGraph[graph, path, 
 Prolog -> {Red, Thickness[.01], Arrowheads[.05], 
   Arrow /@ Partition[GraphEmbedding[graph][[path]], 2, 1]}]

enter image description here

Improve this answer
$\endgroup$
2
  • $\begingroup$ +1 much much nicer than my monstrosity and thanks for educating me about highlighting! :) $\endgroup$
    – ubpdqn
    Apr 19, 2016 at 11:40
  • $\begingroup$ @ubpdqn Thanks, I'm very new to using Graphs so it's fun to practice. You were able to answer what OP wanted more than I at first (a list of positions in the original matrix) $\endgroup$
    – Jason B.
    Apr 19, 2016 at 13:55
1
$\begingroup$

Just another way (but not desired presentation style):

grid = {{131, 673, 234, 103, 18}, {201, 96, 342, 965, 150}, {630, 803,
     746, 422, 111}, {537, 699, 497, 121, 956}, {805, 732, 524, 37, 
    331}};
dim = Dimensions[grid];
vw = Catenate@
   MapIndexed[ (#2[[2]] - 1) 5 + #2[[1]] -> #1 &, grid, {2}];
s = GridGraph[dim, VertexLabels -> "Name", 
   VertexCoordinates -> 
    Join @@ Table[{j, k}, {j, 1, 5, 1}, {k, 5, 1, -1}], 
   ImageSize -> 400];
gr = GridGraph[dim, 
   VertexCoordinates -> 
    Join @@ Table[{j, k}, {j, 1, 5, 1}, {k, 5, 1, -1}], 
   VertexLabels -> vw, ImageSize -> 400];
a = FindPath[gr, 1, 25, Infinity, All];
an = Total /@ (a /. vw);
min = Min[an];
res = Extract[a, Position[an, min]];
c1 = {s, gr, 
     HighlightGraph[gr, PathGraph[#], GraphHighlightStyle -> "Thick", 
      ImageSize -> 400], #, Total@(# /. vw)} & /@ res;
cand = Pick[a, Sort[#] == # & /@ a];
sum = Total /@ (cand /. vw);
answer = Extract[cand, Position[sum, Min[sum]]];
c2 = {s, gr, 
     HighlightGraph[gr, PathGraph[#], GraphHighlightStyle -> "Thick", 
      ImageSize -> 400], #, Total@(# /. vw)} & /@ answer;
Grid[{c1[[1]], c2[[1]]}, Frame -> All]

The first path is shortest. The desired path (without backtracking) is the second.

enter image description here

Improve this answer
$\endgroup$
1
$\begingroup$

We can also use @Jason B. method to find maximum cost path by just doing 1/grid

weights = (graph // EdgeList) /.a_ \[DirectedEdge] b_ :> Flatten[1/grid][[b]];
graph = GridGraph[dim, VertexCoordinates -> Flatten[Reverse@Array[{#2, #1} &, dim], 1], EdgeWeight -> weights, EdgeLabels -> "EdgeWeight", 
  DirectedEdges -> True]

enter image description here

path = FindShortestPath[graph, 1, 25]
    Flatten[grid][[path]]
    Total@%

{131, 201, 630, 803, 746, 497, 121, 956, 331}

4416

HighlightGraph[graph, path, 
 Prolog -> {Red, Thickness[.01], Arrowheads[.05], 
   Arrow /@ Partition[GraphEmbedding[graph][[path]], 2, 1]}]

enter image description here

Improve this answer
$\endgroup$
0
$\begingroup$

here i am modifying the answer given by @kglr slightly to find both the maximum and the minimum cost path.

pathMatrix[matr_, Oper_: Max] := Module[{sum, nextF, i, j},
With[{dim = Dimensions@matr},
With[{row = First@dim, col = Last@dim},
  maxSum[r_, c_] := maxSum[r, c] = matr[[r, c]] + Which[
       (r < row) && (c < col),
      Oper[ maxSum[r, c + 1], maxSum[r + 1, c]],
      r < row, maxSum[r + 1, c],
      c < col, maxSum[r, c + 1],
      True, 0
      ];

  sum = maxSum[1, 1];

  Set @@ Hold[nextF[{i_, j_}],
    Evaluate@Switch[Oper, Min,

      Which[i < row && j < col, 
       If[maxSum[i + 1, j] < maxSum[i, j + 1], {i + 1, j}, {i, 
         j + 1}],
       i < row, {i + 1, j}, j < col, {i, j + 1}, True, {}],
      Max,

      Which[i < row && j < col, 
       If[maxSum[i + 1, j] > maxSum[i, j + 1], {i + 1, j}, {i, 
         j + 1}],
       i < row, {i + 1, j}, j < col, {i, j + 1}, True, {}]]];
  ];
];
Print@sum;
Most@NestWhileList[nextF, {1, 1}, ! # === {} &]
];

(to find the minimum cost path)

grid = {{131, 673, 234, 103, 18}, {201, 96, 342, 965, 150}, {630, 803,
 746, 422, 111}, {537, 699, 497, 121, 956}, {805, 732, 524, 37, 
331}};

Clear@maxSum;
path = pathMatrix[grid, Min];

Grid[grid, Background -> {Automatic, Automatic, Thread[path -> LightBlue]}, 
ItemStyle -> Directive[Bold, 24], Dividers -> All]

enter image description here

(to find the maximum cost path)

enter image description here

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.