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?

$\endgroup$
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

$\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

$\endgroup$
  • $\begingroup$ +1 much much nicer than my monstrosity and thanks for educating me about highlighting! :) $\endgroup$ – ubpdqn Apr 19 '16 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 '16 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

$\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

$\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

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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