Solving a system of diophantine equations from a mathematical competition

There is a problem from the $66th$ Putnam Mathematical Competition, $B2$

Find all positive integers $n,k_1,k_2,...,k_n$ such that $$k_1+\cdots+k_n=5n-4$$ and $$\frac{1}{k_1}+\cdots+\frac{1}{k_n}=1$$

How can I solve this problem with Mathematica?

I tried unsuccessfully something like this:

Reduce[ Sum[ 1/Subscript[k, c], {c, 1, n}] == 1 &&
Sum[ Subscript[k, s], {s, 1, n}] == 5 n - 4,
Flatten[{ n, Table[ Subscript[k, s], {s, 1, n}]}],
Integers]

• using subscripts is not a good idea. You could always just do k[c] Dec 14, 2017 at 17:29

We can find all solutions avoiding computationally expensive searching for examples of solutions ( other answers find all solutions by chance not proving that all solutions are found) if we exploit an inequality between arithmetic and harmonic means of $$n$$ positive numbers: $$\frac{k_1+\dots+k_n}{n} \geq \frac{n}{\frac{1}{k_1}+\dots \frac{1}{k_n}}$$
where $$k_1>0, \dots, k_n>0.\;$$ This inequality ensures that the whole solution space is found.

The system ( version $$\geq$$ 10.1) knows this relation for $$n\leq 4\;$$ ( for $$n>4$$ it is also true however Mathematica fails to decide it), e.g.

Simplify[Mean[#] >= HarmonicMean[#], Min[#] > 0] &[{k1, k2, k3, k4}]

True


It appears that $$n\leq 4\;$$ is sufficient for our purpose, since from the assumptions we have: $$\frac{k_1+\dots+k_n}{n} \geq n$$ because $$\frac{1}{k_1}+\dots \frac{1}{k_n}=1$$. On the other hand $$k_1+\dots+k_n =5n-4$$, therefore we get the following inequality:

Solve[ 5n - 4 >= n^2 && n > 0, n, Integers]

 {{n -> 1}, {n -> 2}, {n -> 3}, {n -> 4}}


There are four possibilities: the first one yields an obvious solution $$n=1$$ and $$k_1=1$$. From the assumptions it is clear that, if $$(k_1, \dots, k_n)$$ is a solution than any permutation $$(k_{\sigma(1)}, \dots, k_{\sigma(n)})$$ is also a solution. Then for the sake of simplicity and a good performance we define a function yielding solutions ordered by $$k_1\leq k_2 \leq \dots \leq k_n$$:

sol[l_List] /; Length[l] > 0 :=
Solve[{ Mean @ l == 5 - 4/Length @ l, HarmonicMean @ l == Length @ l,
LessEqual @@ l, Min @ l > 0}, l, Integers]


we can find all solutions

sol /@ Table[Array[k, m], {m, 4}] // Column

 {{k[1] -> 1}}
{}
{{k[1] -> 2, k[2] -> 3, k[3] -> 6}}
{{k[1] -> 4, k[2] -> 4, k[3] -> 4, k[4] -> 4}}


Reassuming, all possible solutions (up to permutations of $$k_1, \dots ,k_n$$) are: $$n=1,\quad k_1=1$$ $$n=3,\quad k_1=2,\; k_2=3,\; k_3=6$$ $$n=4, \quad k_1=k_2=k_3=k_4=4$$

Since each variable must be at least one then the largest any variable can be is 5n - 4 - (n - 1), i.e., 4n - 3. To avoid permutations of the solution, require the variables to be ordered, i.e., GreaterEqual[k1, k2, ..., kn]

soln[n_Integer?Positive] := Module[
{var = Array[k, n], assume},
assume =
Element[var,
Integers] && (And @@ Thread[4 n - 3 >= var > 0]) && (GreaterEqual @@ var);
Solve[{(Total[var] == (5 n - 4)) && (HarmonicMean[var] == n) && assume},
var, Integers] // Flatten]

DeleteCases[{#, soln[#]} & /@ Range[5], {_, {}}] // Grid[#, Frame -> All] &


This becomes unbearably slow for larger values of n

Here is the one way to do it.

 Manipulate[
Solve[Total@Array[k, n] == 5 n - 4 && Total@(1/Array[k, n]) == 1 &&
And @@ (# > 0 &) /@ Array[k, n], Array[k, n], Integers], {n, 1, 5,
1}]

• Why is $n \leq 5$ ? Dec 14, 2017 at 17:23
• It can be increased.. Dec 14, 2017 at 17:57