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}}
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]}]
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}, ! # === {} &]]