100 row numbers to find the shortest path

Question

I got a question that I have 100 rows of the number, as in the picture that continuous to 100 rows. There is a sequence by starting from the top, and then for each integer walk to the left or right value in the row beneath. That is if we start from the top, then 40 can only be followed by 95 or 55, 95 can only be followed by 72 or 86 and so on. And I need to find the shortest path from the top to the bottom(from the first row to 100 rows). I am thinking of plotting a graph from number 1 to 5050(cause there are in total 5050 numbers.) But how can I put weight on it later on? If I calculate weights one by one that will take ages... Is there an easier way to figure this out?

This is the picture for the first nine rows:

Thank you very much.

Answer 1

Ok LinearProgramming was not the right way to go. Start from the bottom and add the minimum of each pair to the number above the pair and repeat this until reaching the top.

rows = {{40}, {95, 55}, {72, 86, 74}, {66, 13, 8, 98}, {81, 50, 82, 44, 2},
                       {25, 72, 4, 21, 7, 15}, {53, 39, 39, 31, 97, 86, 61}};
minSums = Reverse[FoldList[(Min /@ Partition[#, 2, 1]) + #2 &, Reverse[rows]]];

Now just follow the optimal path through the sums from top to bottom:

which = FoldList[If[Less @@ #2[[{#, # + 1}]], #, # + 1] &, 1, Rest[minSums]];
MapAt[Style[#, Red] &, rows, Transpose[{Range[Length[rows]], which}]] // Column[#, Alignment -> Center] &

---

With LinearProgramming:

rows = {{40}, {95, 55}, {72, 86, 74}, {66, 13, 8, 98},
   {81, 50, 82, 44, 2}, {25, 72, 4, 21, 7, 15}, {53, 39, 39, 31, 97, 86, 61}};
c = Catenate[rows];

(* Constrain exactly one number picked pr row *)
m1 = SparseArray[Join @@ MapIndexed[{First[#2], #} -> 1 &,
      TakeList[Range[Length[c]], Length /@ rows], {2}]];
b1 = ConstantArray[{1, 0}, Length[m1]];

(* Constrain that a follow up number to a chosen number must be picked *)
m2 = SparseArray[Join @@ MapIndexed[MapThread[{#, #2} -> #3 &,
       {ConstantArray[First[#2], 3], #, {1, -1, -1}}] &,
     Catenate[MapThread[Prepend, {Partition[#2, 2, 1], #}] & @@@
       Partition[TakeList[Range[Length[c]], Length /@ rows], 2, 1]]]];
b2 = ConstantArray[{0, -1}, Length[m2]];

m = Join[m1, m2];
b = Join[b1, b2];
lu = ConstantArray[{0, 1}, Length[c]];

TakeList[LinearProgramming[c, m, b, lu, Integers], Length /@ rows] // Column[#, Alignment -> Center] &

Answer 2

I stole path highlighter function from @Coolwater and used @kglr numbers.

$\begin{array}{c} \{81\} \\ \{15,1\} \\ \{68,4,66\} \\ \{24,98,69,75\} \\ \{16,25,5,91,84\} \\ \{71,2,31,49,26,45\} \\ \{74,70,57,48,29,69,27\} \\ \{69,11,87,77,44,34,45,87\} \\ \{94,19,39,30,76,31,18,55,5\} \\ \end{array}$

  SeedRandom@1;
n = 10;
s = s0 = TakeList[RandomInteger[{1, 100}, n (n + 1)/2], Range@n];
minSum = Table[s[[i, j]] = s[[i, j]] + Min[s[[i + 1, j]], s[[i + 1, j + 1]]], {i, 
    Length@s - 1, 1, -1}, {j, 1, i}];

{{101, 26, 42, 33, 94, 49, 53, 99, 57}, {95, 37, 120, 110, 93, 83, 98, 144}, {111, 107, 167, 141, 112, 152, 125}, {178, 109, 172, 161, 138, 170}, {125, 134, 166, 229, 222}, {149, 232, 235, 297}, {217, 236, 301}, {232, 237}, {313}}

solution=Last@minSum

{313}

path = FoldList[If[Less @@ #2[[{#1, #1 + 1}]], #1, #1 + 1] &, 1, 
   Rest@Reverse@Prepend[minSum, Last@s0]];
MapAt[Style[#, Red] &, s0, Transpose[{Range@Length@s0, path}]] // 
 Column[#, Alignment -> Center] &

Using the first 7 rows of OP's list:

ClearAll["Global`*"]
SeedRandom@1;
n = 10;
s = s0 = {{40}, {95, 55}, {72, 86, 74}, {66, 13, 8, 98}, {81, 50, 82, 
     44, 2}, {25, 72, 4, 21, 7, 15}, {53, 39, 39, 31, 97, 86, 61}};
minSum = Table[s[[i, j]] = s[[i, j]] + Min[s[[i + 1, j]], s[[i + 1, j + 1]]], {i, 
    Length@s - 1, 1, -1}, {j, 1, i}];

{{64, 111, 35, 52, 93, 76}, {145, 85, 117, 96, 78}, {151, 98, 104, 176}, {170, 184, 178}, {265, 233}, {273}}

 Last@minSum

{273}

path = FoldList[If[Less @@ #2[[{#1, #1 + 1}]], #1, #1 + 1] &, 1, 
   Rest@Reverse@Prepend[minSum, Last@s0]];
MapAt[Style[#, Red] &, s0, Transpose[{Range@Length@s0, path}]] // 
 Column[#, Alignment -> Center] &

Answer 3

Using the first 7 rows of OP's list:

n = 7;
list = {40, 95, 55, 72, 86, 74, 66, 13, 8, 98, 81, 50, 82, 44, 2, 25, 72, 4, 
 21, 7, 15, 53, 39, 39, 31, 97, 86, 61} ;

Column[TakeList[list, Range @ n], Alignment -> Center]

We can use the function layeredGraph (from this answer) to construct a tree with the desired structure.

ClearAll[sa, layeredGraph]
sa = Module[{k = 1, n = #}, SparseArray[Join @@ 
  (Thread[{#, Range[n - # + 1, n + # - 1, 2]}] & /@ Range[n]) :> (k++)]] &;

layeredGraph = Module[{m = sa[#], edges},
    edges = DirectedEdge @@@ DeleteDuplicates[Sort /@ Flatten[Thread /@ 
       ComponentMeasurements[Normal[m], "Neighbors"]]];
    Graph[edges, ##2, VertexCoordinates -> m["NonzeroPositions"]]] &;

Using list as vertex labels and vertex weights:

vweights0 = AssociationThread[Range[(n+1)n/2], list];
g0 = layeredGraph[n, PlotTheme -> "IndexLabeled", ImageSize -> 300];
SetProperty[g0, VertexLabels -> {v_ :> Placed[vweights0[v], Center]}]

We construct a new graph g1 by

(i) adding a source vertex (vertex 0) with vertex weight 0 and sink vertex (vertex n(n+1)/2) with weight 1

(ii) adding new edges connecting the new vertex 0 to vertex 1, and edges connecting the sink vertices of g0 to the new sink vertex (n(n+1)/2).

(iii) For a directed edge a -> b use the vertex weight of b as the edgeweight of the edge a -> b.

vweights = AssociationThread[Range[0, 1 + (n + 1) n/2], 
   Join[{0}, list, {1}]];

newedges = Prepend[Thread[Range[1 + (n - 1) n/2, (n + 1) n/2] ->
    (1 + (n + 1) n/2)], 0 -> 1];
vc = Thread[Range[0, (1 + (n + 1) n/2)] -> 
    Append[Prepend[sa[n]["NonzeroPositions"], {-1, n}], {n + 3, n}]];

g1 = SetProperty[EdgeAdd[g0, newedges], 
    {VertexLabels -> {v_ :> Placed[vweights[v], Center]}, 
     VertexCoordinates -> vc, EdgeWeight -> {e_ :> vweights[e[[2]]]}}];

Finally, we use the function FindShortestPath to find the shortest path from vertex 0 to vertex 1 + n(n+1)/2 in g1:

shortestpath = FindShortestPath[g1, 0, n (n + 1)/2]

{0, 1, 3, 6, 9, 14, 19, 25, 29}

Total[vweights /@ shortestpath] - 1

273

Row[{g1, HighlightGraph[g1, Subgraph[g1, shortestpath]]}, Spacer[5]]

Another example:

SeedRandom[1]
n = 10;
list = RandomInteger[{1, 100}, (n + 1) n/2];

Column[TakeList[list, Range[n]], Alignment -> Center]

shortestpath =  FindShortestPath[g1, 0, 1 + n (n + 1)/2]

{0, 1, 2, 4, 7, 11, 17, 23, 30, 38, 47, 56}

Total[vweights /@ shortestpath] - 1

313

Row[{g1, HighlightGraph[g1, Subgraph[g1, shortestpath]]}, Spacer[5]]

Answer 4

This one takes me back to my Project Euler days. Here are my solutions from over twelve years ago.

(The Fold syntax wasn't officially introduced until v10, but I was using it privately at the time.)

table //. {x___, a_, b_} :> {x, a + Max /@ Partition[b, 2, 1]}

Fold[Max /@ Partition[#, 2, 1] + #2 &, Reverse @ table]

_{Damn, I'm getting old. :^)}