a riddle at the end of its tether

February 23, 2017
By

(This article was first published on R – Xi'an's Og, and kindly contributed to R-bloggers)

A simply worded riddle this week on The Riddler, about four ropes having non-uniform and unknown burning rates, the only constraint being they all burn completely in one hour. With the help of a lighter (or even a single match), what are the possible units of time one can measure by burning them?

While I had worked out a range of possible times for each of the ropes to complete its combustion, I went for a simulation based confirmation. The starting point is that a new fire can only be started when a burning rope ends up burning. Which only happens for a finite number of possibilities. I found 24 of them, consisting of

> total*prec
[1]  0.000 0.5000 0.750 0.875 0.9375 1.000 1.125 1.1875 1.25 1.3125
[11] 1.375 1.4375 1.500 1.625 1.7500 1.875 2.000 2.1250 2.25 2.5000
[21] 2.750 3.0000 3.500 4.000

i.e., some combinations of 1, 2⁻¹, …, 2⁻⁴, with the comment that those times cannot all be obtained within a single arson experiment.

The simulation experiment consists in producing a random sequence of fire starts based on this principle. To reproduce the non-uniform burning rate I chose a Beta cdf although it has absolutely no relevance on the solution:

#safer beta quantile
myqbeta <-function(x,a,b){
 x=(x>0)*(x<1)*x+(x>=1)
 return(qbeta(x,a,b))}
#burning rate, by side of the rope
fuse <- function(t,side){
 (side==1)*pbeta(t,2.0,1.7)+(side==2)*pbeta(1-t,2.0,1.7)}
#time since start when at x
infuse <- function(x,side){
 (side==1)*myqbeta(x,2.0,1.7)+(side==2)*(1-myqbeta(x,2.0,1.7))}

then I defined R functions for proceeding on the time line and choosing starting points for new fires

#start a new burn
light <- function(ropes,burns){
 #check some are left
 if (max(ropes[,2]-ropes[,1])==0) return(burns)
 #pick number of new fires
 howmany=sample(0:sum((ropes[,2]-ropes[,1]==1)),1)
 if (howmany>0){
    whichropes=sample(rep((1:N)[ropes[,2]-ropes[,1]==1],2),howmany)
    burns[whichropes,1]=TRUE}
    #ropes[whichropes,1]=fuse(prec,1)}
  #pick second end fire-start
  howmany=sample(0:sum(burns[,1]&!burns[,2]),1)
  if (howmany>0){
    whichropes=sample(rep((1:N)[burns[,1]&!burns[,2]],2),howmany)
    burns[whichropes,2]=TRUE}
    #ropes[whichropes,2]=fuse(prec,2)}
  burns
}
#move fire along by one time step
shakem whichones=(1:N)[burns[,1]]
ropes[whichones,1]=fuse(infuse(ropes[whichones,1],1)+prec,1)
whichones=(1:N)[burns[,2]]
ropes[whichones,2]=fuse(infuse(ropes[whichones,2],2)+prec,2)
#eliminate burnt
whichones=(1:N)[ropes[,2]<=ropes[,1]]
ropes[whichones,2]=ropes[whichones,1]
burns[whichones,1]=burns[whichones,2]=FALSE
list(ropes=ropes,burns=burns)
}
#completely burned ropes
burnt <-function(ropes){
  (1:N)[ropes[,2]==ropes[,1]]}

which can then be used repeatedly to record times at which a rope ends up burning, using a time discretisation of 1/2⁵ (which has no impact when compared with a finer discretisation):

N=4
prec=1/2^(N+1)
ropes=cbind(rep(0,N),rep(1,N))
burns=cbind(rep(FALSE,N),rep(FALSE,N))
exhausted=NULL
#start with at least one rope
events=0
while (max(burns)==0)
  burns=light(ropes,burns)
for (t in 1:(N/prec)){
 update=shakem(ropes,burns)
 ropes=update$ropes
 burns=update$burns
 if (length(setdiff(burnt(ropes),exhausted))>0){
  #one fire ended
  events=c(events,t)
  exhausted=burnt(ropes)
  #new firestart
  burns=light(ropes,burns)
  }

Filed under: R, Statistics Tagged: mathematical puzzle, R, The Riddler

To leave a comment for the author, please follow the link and comment on their blog: R – Xi'an's Og.

R-bloggers.com offers daily e-mail updates about R news and tutorials on topics such as: Data science, Big Data, R jobs, visualization (ggplot2, Boxplots, maps, animation), programming (RStudio, Sweave, LaTeX, SQL, Eclipse, git, hadoop, Web Scraping) statistics (regression, PCA, time series, trading) and more...



If you got this far, why not subscribe for updates from the site? Choose your flavor: e-mail, twitter, RSS, or facebook...

Comments are closed.

Search R-bloggers


Sponsors

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)