Home > Mathematica > Dividing the Spoils

## Dividing the Spoils

I confess to taking an embarrassingly long time to understand thisNew York Times NumberPlay.

Look at the image before clicking the hyperlink. Eventually, I appreciate all of the “gold” segments add to 4/n with first row representing n=2. The other segmentation allows the same partitioning for another n-1 people.

How to partition? What rules? Note partitioning $\frac{4}{n}=\sum^k_{j-1}\frac{1}{x_j}$ is note unique, e.g. 4/5 =1/2 +1/5+1/10 or 4/5=1/2+1/4+1/20…

After some thought, and more play I found an algorithmic way to reproduce the first terms of the sequence presented. This does not guarantee this is the general solution. I certainly have not worked out the choice of what gold bar to colour. I very much look forward to the answer.

The following is my code and an extension of the result.

g[n_, d_] := Module[{num, sc, den, div, sel2,}, If[Numerator[n/d] == 1 || IntegerQ[n/d], Return[{n/d}]]; num = Ceiling[d, n]; sc = num/n; den = sc d; div = Divisors[den]; sel2 = DeleteDuplicates[ Select[Tuples[div, 2], Total@# == num &], #1 == Reverse@#2 &]; If[sel2 == {}, Return[First@ Union[Sort /@ Select[Tuples[div, 4], Total@# == num &]]/den] ]; First@SortBy[sel2, Abs[#[[1]] - #[[2]]] &]/den] 

2 {2}
3 {1/3,1}
4 {1}
5 {1/10,1/5,1/2}
6 {1/3,1/3}
7 {1/14,1/2}
8 {1/2}
9 {1/9,1/3}
10 {1/5,1/5}
11 {1/33,1/3}
12 {1/3}
13 {1/52,1/26,1/4}
14 {1/7,1/7}
15 {1/10,1/6}
16 {1/4}
17 First[{}]/85
18 {1/9,1/9}
19 {1/95,1/5}
20 {1/5}

For 4/17 there are no sums of 2 or 3 with the method used, however: 4/17=1/5+1/85+1/85+1/85…

UPDATE
After feedback from NumberPlay some refinement, to find the smallest partition of 4/n with the largest smallest piece:

 fun[n_, d_, num_, m_] := Module[{lcm, div, sc}, lcm = m LCM[n, d]; div = Tuples[Divisors[lcm], num]; sc = lcm/d; Union[Sort /@ Select[div, Total@# == sc n &]/(lcm)]] gf[n_, d_] := Quiet@If[Numerator[n/d] == 1 || IntegerQ[n/d], {n/d}, If[func[10, n, d, 2] === Last[{}], func[10, n, d, 3], func[10, n, d, 2]]] 
I have not tidied this up or thought sufficiently deeply to show how to limit search space…time does not permit at present but it seems I am on a better track and I look forward to the solution.
 Grid[Table[{j, Style[gf[4, j], 20]}, {j, 2, 20}]] 
2 {2}
3 {1/3,1}
4 {1}
5 {1/10,1/5,1/2}
6 {1/3,1/3}
7 {1/14,1/2}
8 {1/2}
9 {1/9,1/3}
10 {1/5,1/5}
11 {1/33,1/3}
12 {1/3}
13 {1/52,1/26,1/4}
14 {1/7,1/7}
15 {1/10,1/6}
16 {1/4}
17 {1/102,1/17,1/6}
18 {1/9,1/9}
19 {1/95,1/5}
20 {1/5}