The Riddler Express for 03/13/2020 described how \(2^{10} = 1024\) is only 2.4% different than \(10^3 = 1000\). The Express question asked for the next power of 2 that was closer (in terms of percentage) to a power of 10. Using a quick program, finding the next three was easy enough.
x <- 10
y <- 3
for(i in 1:3){
BD <- min(ceiling(log2(10^y[i]))-log2(10^y[i]), log2(10^y[i])-floor(log2(10^y[i])))
Y <- y[i]+1
diff <- min(ceiling(log2(10^Y))-log2(10^Y), log2(10^Y)-floor(log2(10^Y)))
while(diff>BD){
Y <- Y + 1
diff <- min(ceiling(log2(10^Y))-log2(10^Y), log2(10^Y)-floor(log2(10^Y)))
}
x <- c(x, round(log2(10^Y)))
y <- c(y, Y)
}
# The next three powers of 2
x## [1] 10 93 196 485# The next three powers of 10.
y## [1] 3 28 59 146## What are the ratios doing?
x/y## [1] 3.333333 3.321429 3.322034 3.321918When we analyze this a bit further, we see that we are looking for pairs of \(x\) and \(y\) such that \(2^x \approx 10^y\). When we use a log base 2 on both sides, this is the same as finding \(\frac{x}{y} \approx \log_2(10)\).
Consulting the OEIS, and using the sequence 10, 93, 196, and 485 as a search, we can find sequence A073733, which gives us the numerators of convergents to \(\log_2(10)\): 10, 93, 196, 485, 2136, 13301, 28738, 42039, 70777, 254370, 325147, 6107016, 6432163, 44699994, 51132157, 146964308, 198096465, 345060773, 1578339557, 1923400330, 82361153417, 496090320832, 578451474249, 2809896217828, 6198243909905, 21404627947543.
The Riddler Classic revisited a problem from the previous week involving Tiffany’s Barbershop. Cutting hair at Tiffany’s is Tiffany herself, and three other barbers.
The vast population of Riddler City lines up outside of Tiffany’s to get their hair cut and you find yourself last in line. Of this entire population, 25% of them want Tiffany to cut their hair (including you). If they are next in line they will hold out for her, letting patrons behind them that don’t care who cuts their hair cut the line.
We are ultimately after the probability that when we eventually become second in line, that the person in front of us is also holding out for Tiffany.
The following function will take an input that is the population that will line up (citySize), run a simulation until there are only two in line, and return the value of the person next in line, where 0 is someone who doesn’t care who cuts their hair and a 1 is someone who does.
nextInLine <- function(citySize, p = 0.25){ ## citySize is the population, p has
## default value .25 but will be altered later.
# create a line that is one less than the citySize (you will be last)
line <- rep(0,citySize-1)
# randomly sample one less than 25% of the citySize and set these all equal to 1.
line[sample(1:(citySize-1),round(citySize*p)-1)] <- 1
# append a 1 on the end to represent you.
line[citySize] <- 1
# Get a random permuation of barbers 1-4. A 4 will mean that their time is about up.
barbers <- sample(1:4,4)
## Create a loop that mocks the barber situation and will end when the length of the
## line is 2.
while(length(line)>2){
## if the first in line doesn't care OR if the next barber available is Tiffany
## then the line advances normally.
if(line[1]==0 | barbers[1]==4){
## shift the barbers up 1 mod 4.
barbers <- barbers%%4 + 1
## eliminate the first person in line
line <- line[-1]
}
## When the if statement does not occur, this means the next person in line is a 1
## AND the next barber available is not Tiffany. So, we need someone to skip the line.
else{
# First check if there is anyone to skip the line left
if(all(line==1)){
## If there isn't anyone left to skip the line, stop the process and return 1.
return(1)
break
}
else{
## if there is a zero left, rotate the barbers as normal, and let's eliminate
## the first occurance of a zero and shift everyone forward.
barbers <- barbers%%4 + 1
line <- line[-which(line==0)[1]]
}
}
}
## Now that the line is down to length 2, return the first person in line.
return(line[1])
}
## Let's simulate this 20 times using a population of 12, 40, and 100.
set.seed(40)
nx <- c()
for(i in 1:20){nx <- c(nx,nextInLine(12))}
nx## [1] 0 0 1 0 1 0 1 1 1 1 0 0 0 0 0 0 1 1 1 0nx <- c()
for(i in 1:20){nx <- c(nx,nextInLine(40))}
nx## [1] 1 1 1 1 1 1 0 1 1 1 1 1 1 1 0 1 0 1 1 0nx <- c()
for(i in 1:20){nx <- c(nx,nextInLine(100))}
nx## [1] 1 0 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1There seem to be a lot of 1’s. Let’s set up a simulation that will pay attention to the 1’s and then give us an overall proportion of the number of 1’s
nextInLineSim <- function(citySize, numSims, p=0.25){
nx <- c()
for(i in 1:numSims){
nx <- c(nx, nextInLine(citySize, p))
}
return(sum(nx)/length(nx))
}
nextInLineSim(12,1000)## [1] 0.528nextInLineSim(40,1000)## [1] 0.821nextInLineSim(100,1000)## [1] 0.916nextInLineSim(1000,1000)## [1] 0.991This simulation suggests that the probability is converging to 1 as the population of Riddler City becomes “vast.” Indeed, simulating it for a population of 10,000 takes a long time, but results in 100% simulated result after 1000 simulations.
By altering the proportion of those holding out for Tiffany, I seemed to have zeroes in on a potential proportion that will result in a 25% chance that when I arrive at the second spot in line, the next person is a Tiffany holdout.
nextInLineSim(1000,1000,.087)## [1] 0.252nextInLineSim(1000,1000,.087)## [1] 0.255nextInLineSim(1000,1000,.087)## [1] 0.247