Indicate minimal path sum

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


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