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}

Advertisements
Categories: Mathematica
  1. No comments yet.
  1. No trackbacks yet.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: