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.

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

4 Answers 4

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

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

$\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} *)
$\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

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.