6
$\begingroup$

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

  1. We start with a rectangular matrix with left-prepended zeros
  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

enter image description here

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.

Improve this question
$\endgroup$
2
  • 1
    $\begingroup$ Is this really a graph theory problem? $\endgroup$ Commented Oct 23, 2023 at 9:10
  • $\begingroup$ No - I added the tag because of the possible display forms (Point 4 of the question). $\endgroup$ Commented Oct 23, 2023 at 9:19

4 Answers 4

Reset to default
8
$\begingroup$

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}}

Original answer:

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

enter image description here

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

enter image description here

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]}]

enter image description here

Highlight shortest paths between pairs in positions:

HighlightGraph[nng, MapThread[Style[EdgeList[PathGraph@FindShortestPath[nng, ## & @@ #]], #2, AbsoluteThickness[5]] &] @ {Partition[positions, 2, 1], Take[ GraphComputation`GraphInformationDump`$AutomaticColorList, -1 + Length@positions]}]

enter image description here

Improve this answer
$\endgroup$
4
  • 1
    $\begingroup$ +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 $\endgroup$ Commented Oct 23, 2023 at 15:57
  • $\begingroup$ @eldo, fixed the labels. $\endgroup$ Commented Oct 23, 2023 at 16:18
  • $\begingroup$ It seems that tuples isn't defined: vcoords = Thread[Map[Reverse] @ vertexlist -> SortBy[{First @ #, -Last @ #} &] @ tuples]; $\endgroup$ Commented Oct 23, 2023 at 17:21
  • $\begingroup$ thank you @eldo. It should be vertexlist. Updated with the correction. $\endgroup$ Commented Oct 23, 2023 at 17:23
5
$\begingroup$

One way to do it:

bag = {}; dim = Dimensions[list][[1]]; positions = MapThread[i = 0; {++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 *)

enter image description here

(* 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]])] , VertexCoordinates -> Thread[VertexList@gg -> AbsoluteOptions[gg, VertexCoordinates][[1, 2]]] , VertexLabels -> Automatic , EdgeStyle -> Gray]; Rotate[Rasterize[ HighlightGraph[res, path, GraphHighlightStyle -> "Dotted"], ImageResolution -> 300], -90 °] (* Output *)

enter image description here

Improve this answer
$\endgroup$
3
$\begingroup$

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} *)
Improve this answer
$\endgroup$
1
$\begingroup$

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

enter image description here

Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.