# Find a certain path through a matrix

I would like to get a functional solution and nice display form for the following problem:

1. Example data

list =
{
{0, 1, 4, 8, 9, 1},
{0, 1, 4, 3, 3, 3},
{0, 8, 6, 1, 3, 2},
{0, 3, 1, 2, 3, 1},
{0, 2, 9, 2, 7, 3},
{0, 2, 1, 7, 2, 3}
};


2. Rules

2. Traversing the first matrix row from left to right, we search the first minimum (1 at position 2), mark it red and put it in a bag.
3. We continue with the 2nd row and find its first minimum not yet taken, which is 3 (1 is already in the bag).
4. The lowest new number in the third row is 2.
5. Arriving at the 4th row we find that all its distinct numbers are already in the bag. Therefore we mark the 0.
6. Zero is the only element which can be marked more than once, which can be seen in the last row.

3. Expected result

4. Final display

The final display should also show the path, not just the red elements like in the above matrix. It could be for example a GridGraph like shown in kglr's answer to

How to find the shortest path going through some specified vertices

But I would also welcome other display forms.

• Is this really a graph theory problem?
– yode
Oct 23, 2023 at 9:10
• No - I added the tag because of the possible display forms (Point 4 of the question).
– eldo
Oct 23, 2023 at 9:19

Update 2: An alternative method using Fold:

step = Append[#, Min @ Complement[#2, #] /. Infinity -> 0] &;

unseenMins = Fold[step] @ Prepend[{}] @ #[[All, 2 ;;]] &;

unseenMinPositions = MapThread[{#, First @ #2 @ #3} &] @
{Range @ Length @ #, Map[PositionIndex] @ #, unseenMins @ #} &;

unseenMinPositions @ list

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


highlightPositions =  Module[{$$x = {}}, MapIndexed[Flatten @ {#2[[1]], 1 + #} &]@ Map[FirstPosition[#, Last[AppendTo[$$x, Min @ DeleteCases[Alternatives @@ $x] @ #]], {0}] &] @ #[[All, 2 ;;]]] &; MapAt[Style[#, Red, Bold] &, list, highlightPositions @ list] // MatrixForm  positions = highlightPositions @ list; gridgraph = GridGraph[Dimensions @ list, VertexSize -> Large, VertexLabelStyle -> 14, VertexLabels -> Thread[Range[Times @@ Dimensions[list]] -> Map[Placed[#, Center] &] @ Apply[Join] @ Map[Reverse] @ Transpose @ list]] PathGraph[positions, VertexCoordinates -> ({#, 1 + Dimensions[list][[2]] - #2} & @@@ Reverse /@ positions), EdgeStyle -> Thick, VertexSize -> Large, VertexStyle -> Red, VertexLabelStyle -> Directive[White, 16], VertexLabels -> (Thread[# -> (Placed[#, Center] & /@ Extract[list, #])] & @ positions), Prolog -> First[Show @ gridgraph]]  Update: An alternative approach using NearestNeighborGraph and FindShortestPath: vertexlist = Tuples @ Range @ Dimensions @ list; vcoords = Thread[Map[Reverse] @ vertexlist -> SortBy[{First @ #, -Last @ #} &] @ vertexlist]; positions = highlightPositions @ list; nng = NearestNeighborGraph[vertexlist, VertexCoordinates -> vcoords, VertexSize -> Large, VertexStyle -> {v : Alternatives @@ positions -> Red}, VertexLabelStyle -> {v : Alternatives @@ positions -> Directive[16, White, Bold]}, VertexLabels -> {v_ :> Placed[list[[## & @@ v]], Center]}]  Highlight shortest paths between pairs in positions: HighlightGraph[nng, MapThread[Style[EdgeList[PathGraph@FindShortestPath[nng, ## & @@ #]], #2, AbsoluteThickness[5]] &] @ {Partition[positions, 2, 1], Take[ GraphComputationGraphInformationDump$AutomaticColorList,
-1 + Length@positions]}]


• +1 , but it seems that the black vertex labels are not correct. For example, the first row should read 0, 1, 4, 8, 9, 1
– eldo
Oct 23, 2023 at 15:57
• @eldo, fixed the labels.
– kglr
Oct 23, 2023 at 16:18
• It seems that tuples isn't defined: vcoords = Thread[Map[Reverse] @ vertexlist -> SortBy[{First @ #, -Last @ #} &] @ tuples];
– eldo
Oct 23, 2023 at 17:21
• thank you @eldo. It should be vertexlist. Updated with the correction.
– kglr
Oct 23, 2023 at 17:23

One way to do it:

bag = {}; dim = Dimensions[list][[1]];
{++i, Splice@FirstPosition[#1, #2]} &
, {list,
Last[AppendTo[bag, Min[Complement[#, bag]]] & /@
list[[All, 2 ;;]]] /. Infinity -> 0}];
ReplaceAt[list, x_ :> Style[x, Red],  positions] // MatrixForm
(* Output *)


(* Path *)
gg = GridGraph[{dim, dim}];
path = DirectedEdge @@@
Partition[dim (#[[1]] - 1) + #[[2]] & /@ positions , 2, 1];

res = Graph[Join[gg // EdgeList, path]
, VertexLabels -> Thread[Range[dim^2] -> (Rotate[#, 90 °] & /@
Flatten[ReplaceAt[list, x_ :> Style[x, Red],  positions]])]
AbsoluteOptions[gg, VertexCoordinates][[1, 2]]]
, VertexLabels -> Automatic
, EdgeStyle -> Gray];

Rotate[Rasterize[
HighlightGraph[res, path, GraphHighlightStyle -> "Dotted"],
ImageResolution -> 300], -90 °]
(* Output *)


There are good ways to visualize presented so far. This answer just gives an alternative way to get the path, trying to be more efficient for very large lists:

path[list_] := Module[{bag = CreateDataStructure["HashSet"], n},
Reap[
Do[n = TakeSmallest[
Select[row, e |-> ! bag["MemberQ", e] || e == 0],
UpTo[2]][[-1]];
Sow[n]; bag["Insert", n]
, {row, list}]
][[2, 1]]]

path[list]
(* {1,3,2,0,7,0} *)


Using FoldPairList:

list = {{0, 1, 4, 8, 9, 1}, {0, 1, 4, 3, 3, 3}, {0, 8, 6, 1, 3,
2}, {0, 3, 1, 2, 3, 1}, {0, 2, 9, 2, 7, 3}, {0, 2, 1, 7, 2, 3}};

fplist = FoldPairList[{Min@Rest@First@#,
DeleteCases[Rest@#, Min@Rest@First@#, {2}]} &, list,
ConstantArray[1, Length@list]] /. ∞ -> 0


{1, 3, 2, 0, 7, 0}

pos = Transpose[{Range@Length@list,
MapThread[Sequence @@ FirstPosition[#1, #2] &, {list, fplist}]}]


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

Visualization:

MapAt[Style[#1, Red, 16, Bold] &, list, pos] // MatrixForm