## 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 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}