This Riddler Classic on 06/19/2020 was submitted by Dean Ballard.
King Auric adored his most prized possession: a set of perfect spheres of solid gold. There was one of each size, with diameters of 1 centimeter, 2 centimeters, 3 centimeters, and so on. Their brilliant beauty brought joy to his heart. After many years, he felt the time had finally come to pass the golden spheres down to the next generation — his three children.
He decided it was best to give each child precisely one-third of the total gold by weight, but he had a difficult time determining just how to do that. After some trial and error, he managed to divide his spheres into three groups of equal weight. He was further amused when he realized that his collection contained the minimum number of spheres needed for this division. How many golden spheres did King Auric have?
Extra credit: How many spheres would the king have needed to be able to divide his collection among other numbers of children: two, four, five, six or even more?
We’ll assume that weight is uniformly distributed over the volume of the sphere, which has the formula \(\frac43 \pi r^3\). The radii of the spheres are 1/2, 1, 3/2, 2, etc. so that the volumes are \(\frac{\pi}{6}, \frac{4\pi}{3}, \frac{9\pi}{2}\), etc. Rewriting the volumes in the following way will help with the analysis:
\[ \frac{\pi}{6}(1)^3, \frac{\pi}{6}(2)^3, \frac{\pi}{6}(3)^3, \frac{\pi}{6}(4)^3, \ldots \]
Ignoring the constant \(\frac{\pi}{6}\) we want to find out how to divide up a sum of a finite number of cubes equally among three individuals.
My initial goal is to write a function that will take both a set of numbers, S, and a some number, N, as inputs, and return a subset of those numbers that add up to the number N. For example, if I input the set (1,2,3,4,5) and 13, the function should return the subset (1,3,4,5).
With the idea that this function will call itself (recursion), there will be a few minor functions that will help this process.
## This function takes a set and an number as input and returns TRUE if either
## the number itself is in the set, or a subset of two numbers sum up to that
## number.
OneOrTwo <- function(Set, N){
Set <- Set[Set<=N]
if(N %in% Set || sum(((N-Set) %in% Set))>=2){return(TRUE)}
else{return(FALSE)}
}
## This function will then return the subset of just one number or two numbers
## when the above function is TRUE.
OneOrTwoSet <- function(Set, N){
Set <- Set[Set<=N]
if(N %in% Set){
return(N)
}
else if(sum((N-Set)%in% Set)>=2){
tempSet <- Set[(N-Set) %in% Set]
## This next part is so that it returns only two values that are not
## equal to each other.
return(c(tempSet[1], N-tempSet[1]))
}
else return("Error")
}
## This function will be used to find a stopping point of checks for efficiency
LastCheck <- function(Set, N){
Set <- sort(Set[Set<=N], decreasing = TRUE)
j <- 0
L <- length(Set)
while(sum(Set[(j+1):L])>N){
j <- j+1
}
return(j)
}With those functions, I built the recursive function to find subsets of sets of numbers.
findSubset <- function(Set, N){
tempSet <- sort(Set[Set<=N], decreasing = TRUE)
## Return the entire set if it sums to N
if(sum(tempSet)==N){return(tempSet)}
## Return an error if it sums to something less than N.
if(sum(tempSet)<N){return("Nope")}
else{
if(OneOrTwo(tempSet, N)){
return(OneOrTwoSet(tempSet, N))
}
else{
L <- LastCheck(tempSet, N)
k <-1
FOUND <- FALSE
while(!FOUND & k<=L){
deepSet <- findSubset(tempSet[-(1:k)], N-tempSet[k])
if(any(deepSet=="Nope")){
k <- k+1
}
else{
finalSet <- c(tempSet[k],deepSet)
FOUND = TRUE
}
}
if(FOUND){return(finalSet)}
else{return("Nope")}
}
}
}
## Test this out
findSubset(c(1,2,3,4,5), 13)## [1] 5 4 3 1findSubset((1:26)^3,sum((1:26)^3)/3)## [1] 17576 15625 6859 512 343 125 27Finally, we would like to use this function in a search for the smallest number needed to divide up cubes evenly.
## For efficiency, let's only explore interger values for which the sum of the
## cubes up to that point is divisible by the number of ways you want to divide
## it.
nextk <- function(nP, currentk){
## iterate up to the next k
k <- currentk + 1
## check if the conditions are satisfied
while(sum((1:(k-1))^3) < (nP-1)*k^3 | sum((1:k)^3)%%nP != 0){
k <- k+1
}
return(k)
}
## Let's search for all partitions and put them in a list.
findPartition <- function(nP=3){
## Find a starting point
k <- nextk(nP,nP)
PartFound <- FALSE
while(!PartFound){
## Empty list of partitions
Part <- vector(mode = "list", length = nP)
## Initial cubed set of numbers
CubeSet <- (1:k)^3
## The sum we want to get to.
S <- sum(CubeSet)/nP
if(any(findSubset(CubeSet,S)=="Nope")){
k <- nextk(nP,k)
next
}
else{
addSet <- findSubset(CubeSet, S)
newSet <- setdiff(CubeSet,addSet)
l <- 0
while(length(addSet)>0 & all(addSet!="Nope")){
Part[[l+1]] <- addSet
addSet <- findSubset(newSet, S)
newSet <- setdiff(newSet, addSet)
l <- l+1
}
if(l == nP){
PartFound <- TRUE
}
else{
k <- nextk(nP,k)
}
}
}
return(Part)
}
(Part2 <- findPartition(2))## [[1]]
## [1] 1728 729 512 64 8 1
##
## [[2]]
## [1] 1331 1000 343 216 125 27(Part3 <- findPartition(3))## [[1]]
## [1] 17576 15625 6859 512 343 125 27
##
## [[2]]
## [1] 13824 12167 5832 4096 2744 1331 1000 64 8 1
##
## [[3]]
## [1] 10648 9261 8000 4913 3375 2197 1728 729 216## check if sums all equal
lapply(Part2, sum)## [[1]]
## [1] 3042
##
## [[2]]
## [1] 3042lapply(Part3, sum)## [[1]]
## [1] 41067
##
## [[2]]
## [1] 41067
##
## [[3]]
## [1] 41067For dividing among two daughters, it looks like we only need 12 spheres, each daugher getting 6 spheres!
For dividing among three daughters, it looks like 26 spheres would work.
I have built these functions non-exhaustively with the weekend time constraint, so I’m not sure if they are optimal (as in the minimum number of spheres needed). However, I’m hopeful that it works for the small numbers needed for this problem.
To address the extra credit, we’ll explore a few more!
Part4 <- findPartition(4)
Part4[[1]][1]^(1/3)## [1] 24Part5 <- findPartition(5)
Part5[[1]][1]^(1/3)## [1] 24Part6 <- findPartition(6)
Part6[[1]][1]^(1/3)## [1] 56Part7 <- findPartition(7)
Part7[[1]][1]^(1/3)## [1] 48Part8 <- findPartition(8)
Part8[[1]][1]^(1/3)## [1] 56Although these numbers work for splitting up spheres in equal parts for 4, 5, 6, 7, and 8, I want to emphasize that these may not be the minimum value needed. Indeed, plugging the sequence 1, 12, 26, 24, 24, 56, 48, 56 into the OEIS does not return any resuls, which makes me think one of these numbers is incorrect.
OR, we have a new sequence to suggest!!