Message Boards Message Boards

[Numberphile] - Frog Jumping - Solving the puzzle

enter image description here

A few weeks ago I was watching the excellent Numberphile video on the game of Frog Jumping:

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

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]

enter image description here

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:

enter image description here

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:

enter image description here

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:

POSTED BY: Sander Huisman
4 Replies

enter image description here - Congratulations! This post is now a Staff Pick! Thank you for your wonderful contributions. Please, keep them coming!

POSTED BY: Moderation Team

Hi Sander, Well.. Numperphile has a great video https://www.youtube.com/watch?v=1MtEUErz7Gg on Sandpiles. A nice setup to generate images with customizable piles sizes and placements?

Also another very different thing. Could we make timelapse photo's like Michael Wesely with Mathematica? http://www.artnet.com/artists/michael-wesely/

POSTED BY: l van Veen

These timelapse photos are just a long term exposure right? So that would be adding up photos, or if they are already properly exposed, take the mean of a sequence of photos.

I have not yet seen the Sandpile video; I'll have a look...

POSTED BY: Sander Huisman
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract