Riddler: Can You Roll The Perfect Bowl?

[This article was first published on Posts | Joshua Cook, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.

FiveThirtyEight’s Riddler Express

link

At the recent World Indoor Bowls Championships in Great Yarmouth,
England, one of the rolls by Nick Brett went viral. Here it is in all
its glory:

In order for Nick’s green bowl to split the two red bowls, he needed
expert precision in both the speed of the roll and its final angle of
approach.

Suppose you were standing in Nick’s shoes, and you wanted to split two
of your opponent’s bowls. Let’s simplify the math a little, and say
that each bowl is a sphere with a radius of 1. Let’s further suppose
that your opponent’s two red bowls are separated by a distance of 3 —
that is, the centers of the red bowls are separated by a distance of
5. Define phi as the angle between the path your bowl is on and the
line connecting your opponent’s bowls.

For example, here’s how you could split your opponent’s bowls when phi
is 75 degrees:

What is the minimum value of phi that will allow your bowl to split
your opponents’ bowls without hitting them?

Plan

I will approximate the solution to this puzzle by simulating the game
from many different angles. Thankfully, because the game is vertically
and horizontally symmetric, I only need to simulate the green ball
reaching the middle point between the red balls and only need to see if
it collides with the top red ball.

Setup

knitr::opts_chunk$set(echo = TRUE, comment = "#>", cache = TRUE)
library(glue)
library(clisymbols)
library(ggforce)
library(gganimate)
library(tidyverse)
theme_set(theme_minimal())
# Some standard colors used throughout
green <- "#54c761"
red <- "#c75454"
purple <- "#a06bdb"
light_grey <- "grey70"
grey <- "grey40"
set.seed(0)

Simulate a single pass

I split the code into two pieces. The first simulates a bowl with a
given angle, and the second decides on the angle to narrow down the
approximation. The following functions take care of the first part:
simulating a bowl.

A single simulation can be run by calling run_bowl_simulation() with
an angle (in degrees). The function works by changing the hypotenuse,
starting with h_start = 5 and decreasing it to 0 by step_size steps
(the steps are held in the numeric vector h_vals). The actual position
of the ball is calculated from the length of the hypotenuse and angle
with a bit of trigonometry in make_green_ball(). For each hypotenuse
value, the green ball is positioned and then tested to see if it
collides with the red ball (set at ((x,y) = (0,2.5)) as per the
riddle) using the function did_balls_collide(). This information is
recorded by building a single data frame with the data for each step of
the simulation. The data frame is returned at the end of the simulation.

# Run a simulation of the bowling game.
run_bowl_simulation <- function(angle,
step_size = 0.1,
red_ball_loc = list(x = 0, y = 2.5)) {
h_start <- 5
h_vals <- seq(h_start, 0, by = -step_size)
angle <- angle * (pi / 180)
all_ball_pos <- NULL
for (h in h_vals) {
green_ball <- make_green_ball(h, angle)
collision <- did_balls_collide(green_ball, red_ball_loc, radius = 1)
all_ball_pos <- bind_rows(
all_ball_pos,
tibble(h = h,
x = green_ball$x,
y = green_ball$y,
collision = collision)
)
}
return(all_ball_pos)
}

# Make a green ball location from the x-position and angle.
make_green_ball <- function(h, angle) {
x <- -1 * h * cos(pi/2 - angle)
y <- h * sin(pi/2 - angle)
list(x = x, y = y)
}

# Decide wether the two balls of radius `r` collided.
did_balls_collide <- function(ball1, ball2, radius) {
d <- sqrt((ball1$x - ball2$x)^2 + (ball1$y - ball2$y)^2)
return(d <= 2*radius)
}

Below are the results from running the simulation at angles between 90
degrees (horizontal) and 0 degrees (vertical) at 10 degree increments.
Each line is an individual simulation, and each point is a round of the
simulation. A red ball is positioned as per the riddle, and the purple
points indicate where the green ball would collide with the red ball.
These example simulations show that the run_bowl_simulation() function
is working as expected.

map(seq(90, 0, -10), run_bowl_simulation, step_size = 0.1) %>%
map2(seq(90, 0, -10), ~ .x %>% add_column(angle = .y)) %>%
bind_rows() %>%
mutate(collision = ifelse(collision, "collision", "safe")) %>%
ggplot() +
geom_point(aes(x, y, color = collision), size = 2) +
geom_circle(aes(x0 = x0, y0 = y0, r = r),
data = tibble(x0 = 0, y0 = 2.5, r = 1),
color = red, fill = red, alpha = 0.5) +
scale_color_manual(values = c(purple, light_grey)) +
coord_fixed() +
theme(
legend.position = c(0.15, 0.9),
legend.title = element_blank()
) +
labs(x = "x", y = "y",
title = "Example paths of the green ball",
subtitle = "For the angles between 0 and 90 at 10 degree intervals.")

Find the smallest angle

The second part of the code is to find the smallest (narrowest) angle at
which there is no collision. Instead of trying every angle between 90
degrees and 0 degrees at some very small increment, I approach this
problem a bit more efficiently. I built an algorithm than starts at 90
degrees and takes large steps until there is an angle that causes a
collision. It then takes a step back an tries again with a progressively
smaller step, until it no longer collides. This continues with the step
size getting smaller and smaller. The algorithm stops when the step size
is small enough for a good approximation and the angle does not cause a
collision. The code chunk below carries out this process, printing the
information for each pass.

The purpose of the angle and previous_angle parameters are fairly
obvious. The angle_delta parameter is the value by which the angle is
reduced at each step. epsilon is used to reduce angle_delta when
there are collisions at an angle. Finally, min_angle_delta is one of
the stopping criteria: when angle_delta gets below this value, the
algorithm is sufficiently close to the correct answer and it stops
trying new angles. Thus, this parameter determines the precision of the
algorithm.
It is set relatively high for now, because this first pass
is just a demonstration and prints out the results of each iteration.

For efficiency, the while loop uses a memoised version of
run_bowl_simulation() because when the balls collide, the previous
step is tried again. Therefore, memoising the function saves some time
instead of running the simulation from the same angle multiple times.

# The starting angle.
angle <- 90
previous_angle <- angle
# The "learning rate" paramerters.
angle_delta <- 10
epsilon <- 0.5
min_angle_delta <- 0.01
# Start with TRUE, though it doesn't matter.
collision <- TRUE
memo_bowl_sim <- memoise::memoise(run_bowl_simulation)
while (angle_delta >= min_angle_delta | collision) {
# Run the bowling simulation with the current angle.
sim_res <- memo_bowl_sim(angle = angle, step_size = 0.1)
# Were there any collisions?
collision <- any(sim_res$collision)
# Print results
msg <- "collision: {ifelse(collision, symbol$cross, symbol$tick)}" %>%
paste("{collision},") %>%
paste("angle: {round(angle, 4)},") %>%
paste("angle_delta: {round(angle_delta, 4)}")
print(glue(msg))
if (!collision) {
# Reduce the angle if there is no collision.
previous_angle <- angle
angle <- angle - angle_delta
} else {
# Revert to the previous angle and reduce delta if there is a collision.
angle_delta <- epsilon * angle_delta
angle <- previous_angle
}
}

#> collision: ✔ FALSE, angle: 90, angle_delta: 10
#> collision: ✔ FALSE, angle: 80, angle_delta: 10
#> collision: ✔ FALSE, angle: 70, angle_delta: 10
#> collision: ✔ FALSE, angle: 60, angle_delta: 10
#> collision: ✖ TRUE, angle: 50, angle_delta: 10
#> collision: ✔ FALSE, angle: 60, angle_delta: 5
#> collision: ✔ FALSE, angle: 55, angle_delta: 5
#> collision: ✖ TRUE, angle: 50, angle_delta: 5
#> collision: ✔ FALSE, angle: 55, angle_delta: 2.5
#> collision: ✖ TRUE, angle: 52.5, angle_delta: 2.5
#> collision: ✔ FALSE, angle: 55, angle_delta: 1.25
#> collision: ✔ FALSE, angle: 53.75, angle_delta: 1.25
#> collision: ✖ TRUE, angle: 52.5, angle_delta: 1.25
#> collision: ✔ FALSE, angle: 53.75, angle_delta: 0.625
#> collision: ✖ TRUE, angle: 53.125, angle_delta: 0.625
#> collision: ✔ FALSE, angle: 53.75, angle_delta: 0.3125
#> collision: ✔ FALSE, angle: 53.4375, angle_delta: 0.3125
#> collision: ✖ TRUE, angle: 53.125, angle_delta: 0.3125
#> collision: ✔ FALSE, angle: 53.4375, angle_delta: 0.1562
#> collision: ✔ FALSE, angle: 53.2812, angle_delta: 0.1562
#> collision: ✖ TRUE, angle: 53.125, angle_delta: 0.1562
#> collision: ✔ FALSE, angle: 53.2812, angle_delta: 0.0781
#> collision: ✔ FALSE, angle: 53.2031, angle_delta: 0.0781
#> collision: ✖ TRUE, angle: 53.125, angle_delta: 0.0781
#> collision: ✔ FALSE, angle: 53.2031, angle_delta: 0.0391
#> collision: ✔ FALSE, angle: 53.1641, angle_delta: 0.0391
#> collision: ✖ TRUE, angle: 53.125, angle_delta: 0.0391
#> collision: ✔ FALSE, angle: 53.1641, angle_delta: 0.0195
#> collision: ✔ FALSE, angle: 53.1445, angle_delta: 0.0195
#> collision: ✖ TRUE, angle: 53.125, angle_delta: 0.0195
#> collision: ✔ FALSE, angle: 53.1445, angle_delta: 0.0098

From the print-out above, we can see how the algorithm jumps back an
forth, narrowing in on a solution around 53 degrees.

With that successful proof-of-concept, the following code runs the
algorithm with a smaller min_angle_delta = 1e-5 to achieve greater
precision. Instead of printing out the results of each iteration, the
simulation results and parameters are saved to sim_results_tracker and
sim_parameters_tracker, respectively, and are inspected below.

angle <- 90
previous_angle <- angle
angle_delta <- 10
epsilon <- 0.7
min_angle_delta <- 1e-5
collision <- TRUE
sim_results_tracker <- tibble()
sim_parameters_tracker <- tibble()
memo_bowl_sim <- memoise::memoise(run_bowl_simulation)
while (angle_delta >= min_angle_delta | collision) {
sim_res <- memo_bowl_sim(angle = angle, step_size = 0.01)
collision <- any(sim_res$collision)
sim_results_tracker <- bind_rows(sim_results_tracker,
sim_res %>% add_column(angle = angle))
sim_parameters_tracker <- bind_rows(sim_parameters_tracker,
tibble(angle, angle_delta,
collision, epsilon))
if (!collision) {
previous_angle <- angle
angle <- angle - angle_delta
} else {
angle_delta <- epsilon * angle_delta
angle <- previous_angle
}
}

The simulation took 89 steps. The plot below shows the angle and
angle_delta at each step, colored by whether there was a collision or
not.

sim_parameters_tracker %>%
mutate(row_idx = row_number()) %>%
pivot_longer(-c(row_idx, epsilon, collision)) %>%
ggplot(aes(x = row_idx, y = value)) +
facet_wrap(~ name, nrow = 2, scales = "free") +
geom_point(aes(color = collision), size = 0.9) +
scale_color_manual(values = c(light_grey, purple)) +
labs(x = "iteration number",
y = "value",
title = "Simulation parameters")

The following plot shows each of the paths tried, again, coloring the
locations of collisions in purple.

sim_results_tracker %>%
mutate(collision = ifelse(collision, "collision", "safe")) %>%
ggplot() +
geom_point(aes(x = x, y = y, color = collision),
size = 0.1) +
scale_color_manual(values = c(collision = purple,
safe = light_grey)) +
coord_fixed() +
theme(legend.position = "none") +
labs(x = "x",
y = "y",
title = "Paths of the green ball",
subtitle = "Points marked in purple were collisions with the red ball.")

Finally, we can find the approximated angle by taking the smallest angle
tried in the rounds of simulation that did not have any collisions.

smallest_angle <- sim_parameters_tracker %>%
filter(collision == FALSE) %>%
top_n(1, wt = -angle) %>%
pull(angle) %>%
unique()

The algorithm approximates the solution to be: 53.1301 degrees (0.9273
in radians).

The simulation with this angle is shown in an animated plot below.

final_result <- sim_results_tracker %>%
filter(angle == smallest_angle) %>%
mutate(row_idx = row_number()) %>%
filter(row_idx == 1)
bind_rows(
final_result,
final_result %>%
mutate(x = -1 * x, y = -1 * y)
) %>%
mutate(row_idx = row_number()) %>%
ggplot() +
geom_point(aes(x = x, y = y),
color = green, size = 2) +
geom_circle(aes(x0 = x, y0 = y, r = 1),
fill = green, alpha = 0.2, size = 0) +
geom_point(aes(x, y),
data = tibble(x = 0, y = 2.5),
color = red, size = 2) +
geom_circle(aes(x0 = x, y0 = y, r = r),
data = tibble(x = 0, y = 2.5, r = 1),
fill = red, alpha = 0.2, size = 0) +
geom_point(aes(x, y),
data = tibble(x = 0, y = -2.5),
color = red, size = 2) +
geom_circle(aes(x0 = x, y0 = y, r = r),
data = tibble(x = 0, y = -2.5, r = 1),
fill = red, alpha = 0.2, size = 0) +
coord_fixed() +
labs(
x = "x",
y = "y",
title = glue(
"The tightest angle of the perfect bowl: {round(smallest_angle, 3)} deg."
)) +
transition_states(row_idx, transition_length = 2,
state_length = 0, wrap = FALSE) +
ease_aes("sine-in-out")


Acknowledgements

Repetitive tasks were sped up using the
‘memoise’ package for
memoization. Plotting was accomplished using
‘ggplot2’,
‘ggforce’, and
‘gganimate’.

To leave a comment for the author, please follow the link and comment on their blog: Posts | Joshua Cook.

R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.

Never miss an update!
Subscribe to R-bloggers to receive
e-mails with the latest R posts.
(You will not see this message again.)

Click here to close (This popup will not appear again)