9
$\begingroup$

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.

$\endgroup$
5
  • $\begingroup$ You can use Dynamic Programming $\endgroup$ Oct 25, 2019 at 11:11
  • $\begingroup$ I do not understand, there will always be 100 steps. What do you mean by "shortest"? $\endgroup$
    – yarchik
    Oct 25, 2019 at 11:30
  • $\begingroup$ And again, an obligatory question, are you sure this is the right place to ask? This forum is devoted to the Mathematica software. Nothing in your question indicates that you would like to use it. What have you tried to do so far? $\endgroup$
    – yarchik
    Oct 25, 2019 at 11:33
  • $\begingroup$ Sorry, I mean the smallest sum of the numbers. $\endgroup$
    – xixn525
    Oct 25, 2019 at 12:21
  • $\begingroup$ Wrong forum, it seems. But this could be set up as a graph and handled with a shortest-path algorithm. $\endgroup$ Oct 25, 2019 at 16:23

4 Answers 4

6
$\begingroup$

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]

enter image description here

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

enter image description here

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

enter image description here

Another example:

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

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

enter image description here

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

enter image description here

$\endgroup$
3
  • $\begingroup$ I think the Code you have developed to answer one of my questions few months ago is the answer to the question asked. I presented the problem as a linear programming problem and what you developed was the formalization of the LP problem in Mathematica language. Of course, if "@xixn525" wants the Code, I can make it available for use.Thanks again for the Code. $\endgroup$ Oct 25, 2019 at 14:57
  • $\begingroup$ @TugrulTemel, does not ring a bell. Can you post the link? $\endgroup$
    – kglr
    Oct 25, 2019 at 15:08
  • $\begingroup$ Here is the link for the Code: mathematica.stackexchange.com/questions/183271/… $\endgroup$ Oct 25, 2019 at 15:23
6
$\begingroup$

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. :^)

$\endgroup$
2
  • 1
    $\begingroup$ I think we need Min in this case :) $\endgroup$ Oct 25, 2019 at 14:07
  • 2
    $\begingroup$ @OkkesDulgerci Oops! It made me smile to see this "old friend" of a problem again and I didn't read carefully enough before making a drive-by post. $\endgroup$
    – Mr.Wizard
    Oct 26, 2019 at 2:20
5
$\begingroup$

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

$\endgroup$
2
$\begingroup$

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

enter image description here

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

enter image description here

$\endgroup$

You must log in to answer this question.