A few weeks ago I was watching the excellent Numberphile video on the game of Frog Jumping:
Watch it here if you haven’t already.
The video talks about the frog-jumping puzzle. Imagine a line of lily pads:
Lilypad[p:{x_,y_},s_]:=Scale[FilledCurve[BSplineCurve[(#+p)&/@{{0,0.25},{0,1},{1,1},{1,-0.75},{-1,-0.75},{-1,1},{0,1},{0,0.25}}]],s,p]
Graphics[{EdgeForm[{Thick, Black}], FaceForm[RGBColor[0, 0.5, 0]], Lilypad[{#, 0}, 0.3] & /@ Range[5]}]
the puzzle start with one frog on each lilypad, which I will denote with 1’s above the lilypad:
Graphics[{EdgeForm[{Thick,Black}],FaceForm[RGBColor[0,0.5,0]],{Lilypad[{#,0},0.3],Text[Style[1,14],{#,1}]}&/@Range[5]}]
The goals of the puzzle is to land all the frogs on to the same lily pad. But there are rules: if there are n frogs on a certain lily pad these frogs can only jump n distance (either to the left or right). And all the frogs (from a certain lily pad) have to jump at once. And lastly, they can’t jump onto an empty lily pad; once it is emptied, it can’t be returned to.
I can now make one jump which will look like this:
VisualizeSequence[state_Association,height_]:=KeyValueMap[Text[#2,{#1,height}]&,state]
VisualizeSequences[states_List,enabled_]:=Module[{diff,startx,endx,y,arrows},
diff=Partition[states,2,1];
diff=Merge[#,Identity]&/@diff;
startx=First[Keys[Select[#,Length[#]==1&]]]&/@diff;
endx=First[Keys[Select[#,Length[#]==2\[And]Unequal@@#&]]]&/@diff;
y=Range[Length[states]-1];
arrows=MapThread[{{#1,#3},{#2,#3+1}}&,{startx,endx,y}];
arrows={#1+0.2Normalize[#2-#1],#2-0.2Normalize[#2-#1]}&@@@arrows;
Graphics[{
{Darker@Red,Arrow/@arrows},
MapIndexed[VisualizeSequence[#1,First[#2]]&,states],
{EdgeForm[{Thick,Black}],FaceForm[RGBColor[0,0.5,0]],Lilypad[{#,0},0.3]&/@enabled},
Arrow[{{Min[enabled]-1,1},{Min[enabled]-1,Length[states]}}],
Text["Time",{Min[enabled]-1.5,(Min[enabled]-1+Length[states])/2},{0,0},{0,1}]
},
ImageSize->50(Max[enabled]-Min[enabled]+1.5)
]
]
states = {<|1 -> 1, 2 -> 1, 3 -> 1, 4 -> 1, 5 -> 1|>, <|2 -> 2, 3 -> 1, 4 -> 1, 5 -> 1|>};
VisualizeSequences[states, Range[5]]
I can make another step now:
states={<|1->1,2->1,3->1,4->1,5->1|>,<|2->2,3->1,4->1,5->1|>,<|3->1,4->3,5->1|>};
VisualizeSequences[states,Range[5]]
And to finish it off:
states={<|1->1,2->1,3->1,4->1,5->1|>,<|2->2,3->1,4->1,5->1|>,<|3->1,4->3,5->1|>,<|4->4,5->1|>,<|4->5|>};
VisualizeSequences[states,Range[5]]
Solving the puzzle
The puzzle that was posed in the video is about the following arrangement:
Graphics[{EdgeForm[{Thick,Black}],FaceForm[RGBColor[0,0.5,0]],{Lilypad[{#,0},0.3],Text[Style[1,14],{#,1}]}&/@{1,3,4,5,7,8,9,11},Text[Style["\[Ellipsis]",14],{6,0}],Text[Style["\[Ellipsis]",14],{6,1}],Text[Style["n",14],{6,-1.5}],Arrowheads[{-0.05,0.05}],Arrow[{{1,-1},{11,-1}}]},PlotRangePadding->Scaled[.1],ImageSize->400]
Where we have places 1 through n, where lily pad 2 and n-1 are gone; so we have n-2 active lily pads. Is this solveable for any n? We can write a simple solver now:
FrogSequences[state_] := Catch[PossibleFrogStates[state, {state}]]
PossibleFrogStates[state_, history_: {}] := Module[{futures},
futures = Catenate[PossibleFrogStatesHelper[state, #] & /@ Keys[state]];
Do[
If[Length[f] == 1,
Throw[Append[history, f]]
,
PossibleFrogStates[f, Append[history, f]]
]
,
{f, futures}
]
]
PossibleFrogStatesHelper[state_, key_] := Module[{val, newpos, tmp},
val = state[key];
newpos = {key - val, key + val};
newpos = Intersection[newpos, Keys[state]];
Table[
tmp = state;
KeyDropFrom[tmp, key];
tmp[np] += val;
tmp
, {np, newpos}
]
]
Which we can try out by first trying to solve the above puzzle:
solution=FrogSequences[Association[#->1&/@Range[5]]]
VisualizeSequences[solution,Range[5]]
giving:
So now let’s iterate over n (starting at 4) and stop until we find one that is solvable:
solution = Catch@Do[
enabled = Delete[Range[n], {{2}, {-2}}];
frogs = Association[# -> 1 & /@ enabled];
sol = FrogSequences[frogs];
If[sol =!= Null, Print[n, " = solvable!"]; Throw[sol]]
,
{n, 4, 20}
];
VisualizeSequences[solution, enabled]
running the code finds that n = 12 is solvable:
if you like this posts and you have another Numberphile video that needs the Wolfram Language treatment, let me know. Check also out the other Numberphile inspired post I did:
