# How to generate optimal solution and order the rest

This is a decimal maze, you start with 100 points and you must choose the path that gives you the highest score. Rule: You should not go twice for the same point and the same segment.

My question: Is it possible to make Mathematica go through the figure and give me correct answers ordered from highest to lowest?

So that something like this

and this and so on

• Have you tried anything? Commented May 29, 2018 at 3:32
• I really do not know how to start, I understand little mathematics, but I know that it can do great things, this is a game for my brother who is a primary school math teacher Commented May 29, 2018 at 3:37

First, let's define the edges of this graph:

start = 100;
edgedefinition = {{edge[start, a], mul[0.9]},
{edge[start, b], sub[0.009]},
{edge[start, c], div[0.6]},
{edge[a, b], div[0.09]},
{edge[c, d], mul[1.2]},
{edge[a, e], div[2.01]},
{edge[b, e], mul[1.9]},
{edge[c, e], div[0.4]},
{edge[e, f], sub[12]},
{edge[c, f], mul[0.99]},
{edge[a, g], mul[1.89]},
{edge[e, g], mul[0.5]},
{edge[g, h], sub[-1.7]},
{edge[e, h], mul[1.99]},
{edge[f, h], div[1.4]},
{edge[h, i], div[0.87]},
{edge[f, i], sub[0.8]},
{edge[i, j], mul[1.09]},
{edge[f, j], div[0.8]},
{edge[d, j], div[0.5]},
{edge[g, meta], div[1.2]},
{edge[h, meta], mul[0.97]},
{edge[i, meta], mul[1.01]},
{edge[j, meta], div[0.7]}};
edges = Sort[UndirectedEdge @@ #[[1]]] & /@ edgedefinition;


This should be all of them, but there's every possibility that I missed one. The vertices are labelled alphabetically from the upper left to the lower right, aside from the top one (100) and the bottom one (meta).

Second, let's define some helper functions which will be used later:

toEdges[l_] := Inner[UndirectedEdge, l[[1 ;; -2]], l[[2 ;; -1]], List];
getOperation[e_] :=
edgedefinition[[Position[edges, Sort[e]][[1, 1]], 2]];
constructPath[l_] := Prepend[getOperation /@ toEdges[l], l[[1]]];


toEdges transfers a list of vertices to a list of edges between them, getOperation is used to find the operation associated with a given edge (e.g. so that we can turn 100 <-> a into mul[0.9]), and constructPath turns a series of vertices into the path's starting point and the list of operations it under goes (e.g. constructPath[{100, d, j, meta}] becomes {100, add[0.7], div[0.5], div[0.7]}).

Thus, constructPath turns the vertices into the path of operations that this undergoes. I have taken care to ensure that the operations above are listed consistently as add, sub, mul, or div according to the figure in your question. constructPath gives us a useful format to describe what's going on, but we need one more function to evaluate it to a usable number for sorting:

evaluatePath[{x_}] := x;
evaluatePath[{x_, add[y_], z___}] := evaluatePath[{x + y, z}];
evaluatePath[{x_, sub[y_], z___}] := evaluatePath[{x - y, z}];
evaluatePath[{x_, mul[y_], z___}] := evaluatePath[{x y, z}];
evaluatePath[{x_, div[y_], z___}] := evaluatePath[{x/y, z}];


This is probably not the fastest way to implement this function, but it is one of the most readable and it's sufficiently fast for this problem. In short, given a list containing a number (x_), an operation (f[y_]), and possibly extra (z_), turn it into a shorter list {f[x,y], z} and evaluate again. If the list contains only one element, return that element instead.

Now, let's find every possible path from 100 to meta:

allpaths = FindPath[Graph[edges], start, meta, 15, 100000];


And confirm how many such paths exist:

Length[allpaths]


1641

You can show to yourself that no more paths exist by noting that there aren't enough vertices to have paths of length 15 or longer. FindPath does not revisit vertices, so there shouldn't be any issues with that. Similarly, since it does not revisit vertices, it is guaranteed to never revisit any edge.

Then evaluate all of these paths while maintaining a copy of the original path:

unorderedresults =
Table[{p, evaluatePath[constructPath[p]]}, {p, allpaths}];


And then sort them:

orderedresults = SortBy[unorderedresults, #[[2]] &]


This is the sorting from lowest to highest, you can use -#[[2]] & or Reverse to find the other ordering. Somewhat unsurprisingly, the lowest-scoring path starts with the $\times 0.9$ edge and the highest-scoring path starts with the $\div 0.6$ edge.

• thank you, evaluating the code, anything I tell you, for work reasons I can not answer before.. edit :my version of mathematica is 10.4, what do you have? I get errors Commented May 30, 2018 at 0:17
• I have no errors on 10.1, 11.2, or 11.3. What errors are you getting? Commented May 30, 2018 at 1:43
• do not !! , there are no errors, try to edit and do not leave me, it works perfect two things 1) Could you explain this line? * allpaths = FindPath [Graph [edges], 100, meta, 15, 100000]; changing 100 for another smaller number jumps some error, * the 100000 that means? * I tried to normalize the numerical output with N [a, n] but it does not work 2) it would be possible to obtain a graph of each solution thanks first Commented May 30, 2018 at 1:54
• 100 is the name of the starting node. You'll have to change the starting node in edgedefinition too. The 100000 is the maximum number of paths to find. I don't know what you're trying to normalize, so I'm not sure I can help you with that. Graphing each solution on the graph is really complicated, since organize the graph to match the one you have in your question is really tricky. You could graph the distribution of the solutions though with ListLinePlot[orderedresults[[1;;-1,2]]] though, I think. Commented May 30, 2018 at 2:20
• I understood your explanation, excellent When I make that mistake on purpose I figure out the form, there is some way to take advantage of this, to graph the solutions the normalizae thing is best understood with the second part of the image ( _dropbox.com/s/cxpkf9fvqdrowce_/duda.png?dl=0) Commented May 30, 2018 at 3:21