4

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]
Artes
  • 57,212
  • 12
  • 157
  • 245
vito
  • 8,958
  • 1
  • 25
  • 67

3 Answers3

9

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$$

Artes
  • 57,212
  • 12
  • 157
  • 245
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] &

enter image description here

This becomes unbearably slow for larger values of n

Bob Hanlon
  • 157,611
  • 7
  • 77
  • 198
3

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}]
OkkesDulgerci
  • 10,716
  • 1
  • 19
  • 38