Indicate minimal path sum

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} How to determine the route that went algorithm?

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] Alternatively,

Grid[grid, Background -> {Automatic, Automatic, Thread[path -> Red]},
ItemStyle -> Directive[Bold, 24], Dividers -> All] randommat = RandomInteger[{0, 1000}, {10, 12}];

Grid@ MapAt[Framed[#, FrameStyle -> Directive[Thick, Red], Background -> Red] &,
randommat, Most@NestWhileList[nextF[randommat], {1, 1}, ! # === {} &]] 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}} Or on a larger, random array,

grid = RandomInteger[200, {15, 10}];
minimalpathsum@grid 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"] 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] 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]}] • +1 much much nicer than my monstrosity and thanks for educating me about highlighting! :) – ubpdqn Apr 19 '16 at 11:40
• @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) – Jason B. Apr 19 '16 at 13:55

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[] - 1) 5 + #2[] -> #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[], c2[]}, Frame -> All]

The first path is shortest. The desired path (without backtracking) is the second. 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] 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]}] 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] (to find the maximum cost path) 