Euler Project Problem 18

Question

I use Mathematica to implement a function, which output the position path in the triangle required. And the elements are found to be {75, 95, 47, 87, 82, 75, 73, 28, 83, 47, 43, 73, 91, 67, 98}, which totals up to 1064.

I even checked the elements manually and they should be the above list. But the sum of them are told not correct and I cannot understand it why.

Anyone gets any ideas what went wrong?

The problem is here.

My function used to find the path is defined in WL as below:

maxpath[datf_] := Block[{i = 1, j = 1, list = {1}, dat = datf},
  While[i < Length[dat], 
    If[#[[2, j]] > #[[2, j + 1]], AppendTo[list, j], 
       j++ && AppendTo[list, j]] &@dat; dat = RotateLeft[dat]; i++
   ];
  {Range[Length[dat]], list}//Transpose
 ]

The structure of "datf" is a triangular list:

{{75}, {95, 64}, {17, 47, 82}, {18, 35, 87, 10}, {20, 04, 82, 47, 
  65}, {19, 01, 23, 75, 03, 34}, {88, 02, 77, 73, 07, 63, 67}, {99, 
  65, 04, 28, 06, 16, 70, 92}, {41, 41, 26, 56, 83, 40, 80, 70, 
  33}, {41, 48, 72, 33, 47, 32, 37, 16, 94, 29}, {53, 71, 44, 65, 25, 
  43, 91, 52, 97, 51, 14}, {70, 11, 33, 28, 77, 73, 17, 78, 39, 68, 
  17, 57}, {91, 71, 52, 38, 17, 14, 91, 43, 58, 50, 27, 29, 48}, {63, 
  66, 04, 68, 89, 53, 67, 30, 73, 16, 69, 87, 40, 31}, {04, 62, 98, 
  27, 23, 09, 70, 98, 73, 93, 38, 53, 60, 04, 23}}

Answer 1

Anyone gets any ideas what went wrong?

The issue with this algorithm is that the tree is visited from the root to the leaves, and several paths are dismissed at once based on the values at a given level, without knowing the values at deeper levels.

Specifically, there is no way to ensure that a deleted path does not contain numbers with higher values that will yield in the end a greater total.

ubpdqn has provided a nice Grid in his answer that shows this point. If you look at the graph {3, 2} therein, the path sums up to 1068, so a greater value than yours, but it has selected the value 64 at the second step, while yours selected 95.

As a simple example, consider the values:

datf2 = {{1}, {1, 0}, {1, 1, 10}}

The path of maximum sum is {1, 0, 10}. Using your algorithm, one gets:

maxpath[datf2];
Extract[datf2, %]
(* {1, 1, 1} *)

All paths starting with {1, 0, ...} were dismissed at the second step.

Answer 2

This does not answer the reason for the failure of the code. I think this requires more information. However, this is a brute force approach:

Importing

is = ImportString["75
   95 64
   17 47 82
   18 35 87 10
   20 04 82 47 65
   19 01 23 75 03 34
   88 02 77 73 07 63 67
   99 65 04 28 06 16 70 92
   41 41 26 56 83 40 80 70 33
   41 48 72 33 47 32 37 16 94 29
   53 71 44 65 25 43 91 52 97 51 14
   70 11 33 28 77 73 17 78 39 68 17 57
   91 71 52 38 17 14 91 43 58 50 27 29 48
   63 66 04 68 89 53 67 30 73 16 69 87 40 31
   04 62 98 27 23 09 70 98 73 93 38 53 60 04 23", "List"];
ist = ToExpression /@ ({{is[[1]]}}~Join~(StringSplit /@ is[[2 ;;]]));

Creating graph and evaluating paths:

grp = Flatten[
   Table[{{i, j} -> {i + 1, j}, {i, j} -> {i + 1, j + 1}}, {i, 
     14}, {j, i}]];
gv = Graph[grp, VertexWeight -> (Flatten[ist])];
rules = Thread[VertexList[gv] -> Range[120]]
gvm = Graph[grp /. rules, 
  VertexLabels -> 
   Thread[Range[
      120] -> (Placed[Style[#, 10], Center] & /@ Flatten[ist])], 
  VertexWeight -> Flatten[ist], VertexSize -> 0, ImageSize -> 500, 
  EdgeStyle -> White]
fun[v_] := PropertyValue[{gvm, v}, VertexWeight];
func[v_] := Module[{paths = FindPath[gvm, 1, v, {14}, All], tot, pck},
  tot = Total /@ Map[fun, paths, {2}];
  pck = {Max[tot], Extract[paths, Position[tot, Max[tot]]]}
  ]
vis[v_] := 
 With[{path = func[v], ru = Thread[Range[120] -> Flatten[ist]]},
  Column[{HighlightGraph[gvm, PathGraph[path[[2, 1]]], 
     Epilog -> {Red, Thickness[.005], Arrowheads[.02], 
       Arrow /@ Partition[GraphEmbedding[gvm][[path[[2, 1]]]], 2, 1]}],
    Row[{StringJoin[Riffle[ToString /@ (path[[2, 1]] /. ru), "+"]], 
      "=", path[[1]]}]
    }, Alignment -> Center]]

So:

Grid[Partition[vis /@ Range[106, 120], 3], Frame -> All]

As a 'reality check' and given OP putative answer:

 check[v_] := Module[{paths = FindPath[gvm, 1, v, {14}, All], tot, pck},
  tot = Map[fun, paths, {2}];
  SortBy[Thread[{tot, Total /@ tot}], Last]
  ]
    Length@check[113]
    Grid[check[113][[-2 ;; -1]]]

So 3432 paths were tested and the OP putative solution is not largest for given source and target.

I apologize for any errors. Perhaps it can be a comparator for OP answers.