Finding all solutions to coupled algebraic equations without exhaustive enumeration

Question

A Cambridge University mathematics interview question states:

Find all $a,b,c,d,e,f \in \mathbb{N}$ such that

$$a + b + c = d \cdot e \cdot f$$

and

$$d + e + f = a \cdot b \cdot c$$

(There are a number of similar questions on this site, but none that concentrate on finding all solutions, particularly when permutations expand the solution search space.)

It is easy and fast to find one solution:

FindInstance[
            {a + b + c == d e f, 
             d + e + f == a b c, 
             {a, b, c, d, e, f} > 0},
 {a, b, c, d, e, f}, Integers]

(* {{a -> 2, b -> 3, c -> 1, d -> 2, e -> 3, f -> 1}} *)

Of course this solution (and others, below) can be permuted to find additional (equivalent) solutions.

The full solution set, however, is:

$\{ (3,2,1), (3,2,1) \}, \{ (1,1,6), (2,2,2) \}, \{ (1,1,8), (1,2,5) \}, \{ (1,1,7), (1,3,3) \}$ (and, of course, permutations).

I have been unable to algorithmically find all these solutions. I've tried using Solve, Reduce, and the obvious alterations to FindInstance:

FindInstance[
            {a + b + c == d e f, 
             d + e + f == a b c},
            {a, b, c, d, e, f}, Integers,4]

which yields one additional solution, but not all four.

I've tried to reduce the solution search space by constraining (without loss of generality) the permutations of each subset of variables:

FindInstance[
            {a + b + c == d e f, 
             d + e + f == a b c, 
             a >= b >= c > 0, 
             d >= e >= f > 0, (a != d) \[Or] (b != e) \[Or] (c != f)},
 {a, b, c, d, e, f}, Integers]

One can also impose the fact that not all terms $\{a,b,c \}$ or $\{ d,e,f \}$ can be greater than 2.

The best I've found is:

FindInstance[
 {a + b + c == d e f,
  d + e + f == a b c,
  {a, b, c, d, e, f} > 0,
  a >= b >= 2 >= c > 0,
  d >= e >= f > 0,
  a != f ,
  a b  > 4 ,
  c == 1},
 {a, b, c, d, e, f}, Integers, 4]

There are yet other constraints, but none have yielded all the solutions.

I am explicitly NOT interested in any method that relies on exhaustive enumeration and testing, as might be implemented in Python or other languages without symbol manipulation. Such methods scale poorly with number of equations, variables, upper limits, and so on. After all, how do you know ahead of time that your numerical search need not go to, say, $10^{10}$ for each variable?! And how can such simulation ever show that there is NO solution? Or the total number of solutions that do exist? The "human intelligence" in the attached link at the top is the kind of "smarts" I want to implement and exploit in Mathematica.

How can I compute all the solutions (up to permutation) using symbol manipulation?

Answer 1

You can find solutions with FindInstance and a little detour.

Regard the two onesided equations as polynoms in a and determine the parameters {b,c,d,e,f} where they both have the same roots.

eqs = {a + b + c == d e f, d + e + f == a b c};
vars = {a, b, c, d, e, f};

resa = Resultant[a + b + c - d e f, -a b c + d + e + f, a]

(*   d + e + f + b c (b + c - d e f)   *)

fi = FindInstance[
      Join[{0 == resa}, {1 <= b <= c, 1 <= d <= e <= f}], {b, c, d, e, f},
      Integers, 10]

(*   FindInstance::fwsol: Warning: FindInstance found only 6 instance(s), but it was not able to prove 10 instances do not exist. >>

{{b -> 1, c -> 1, d -> 1, e -> 2, f -> 5}, {b -> 1, c -> 1, d -> 1, 
 e -> 3, f -> 3}, {b -> 1, c -> 1, d -> 2, e -> 2, f -> 2}, {b -> 1, 
 c -> 2, d -> 1, e -> 1, f -> 8}, {b -> 1, c -> 2, d -> 1, e -> 2, 
 f -> 3}, {b -> 2, c -> 2, d -> 1, e -> 1, f -> 6}}   *)

eqs /. fi

ss = Union@
     Flatten[{{a, b, c, d, e, f} /. First@Solve[#, a]} & /@ eqs /. fi, 2];

thx = Thread[vars -> #] & /@ ss

(*   {{a -> 2, b -> 2, c -> 2, d -> 1, e -> 1, f -> 6}, 
      {a -> 3, b -> 1, c -> 2, d -> 1, e -> 2, f -> 3}, 
      {a -> 5, b -> 1, c -> 2, d -> 1, e -> 1, f -> 8}, 
      {a -> 6, b -> 1, c -> 1, d -> 2, e -> 2, f -> 2}, 
      {a -> 7, b -> 1, c -> 1, d -> 1, e -> 3, f -> 3}, 
      {a -> 8, b -> 1, c -> 1, d -> 1, e -> 2, f -> 5}}   *)

eqs /. thx

(*   {{True, True}, {True, True}, {True, True}, {True, True}, {True, 
       True}, {True, True}}   *)

Two of these solutions are permutations. this is no proof whether this are all solutions.

Answer 2

This code using Do returns

DeleteDuplicates[ With[{M = 9}, 
   Reap@Do[If[a + b + c == d e f && d + e + f == a b c, 
      Sow[{{a, b, c}, {d, e, f}}]],
       {a, 1, M}, {b, a, M}, {c, b, M},
       {d, 1, M}, {e, d, M}, {f, e, M}]][[2, 1]],
#1 == Reverse@#2 &]

almost immediately. The similar version using FindInstance

DeleteDuplicates[With[{M = 9},
  {{a, b, c}, {d, e, f}} /. FindInstance[
    a + b + c == d e f && d + e + f == a b c && 
    0 < a <= b <= c <= M && 0 < d <= e <= f <= M,
      {a, b, c, d, e, f}, Integers, 10]],
#1 == Reverse@#2 &]

takes over two minutes. I find that sometimes using Do beats FindInstance depending on the specific problem.

---

In this case, it seems that FindInstance has trouble with two equations and solving one of them is indicated as in the answer of Akku14. The following code uses FindInstance with this insight. Start with the two equations.

{eq1, eq2} = {a + b + c == d e f, d + e + f == a b c};

Solve for the variable c using equation 1 to get

solc = Solve[eq1, c][[1, 1]]
(* c -> -a - b + d e f *)

and substitute it into equation 2 to get

eq3 = eq2 /. solc
(* d + e + f == a b (-a - b + d e f) *) 

Finding solutions of this equation (ignoring a warning about not being able to prove more solutions exist) using FindInstance takes almost a minute

find = FindInstance[{eq3, 0 < a <= b, 0 < d <= e <= f},
       {a, b, d, e, f}, Integers, 9] // Quiet
(* {{a -> 1, b -> 1, d -> 1, e -> 2, f -> 5},
    {a -> 1, b -> 1, d -> 1, e -> 3, f -> 3},
    {a -> 1, b -> 1, d -> 2, e -> 2, f -> 2}, 
    {a -> 1, b -> 2, d -> 1, e -> 1, f -> 8},
    {a -> 1, b -> 2, d -> 1, e -> 2, f -> 3},
    {a -> 2, b -> 2, d -> 1, e -> 1, f -> 6}} *)

Apply the solution rules, restore missing values of c and reshape into solution pairs

solpairs = {{a, b, c}, {d, e, f}} /. solc /. find
(* {{{1, 1, 8}, {1, 2, 5}}, {{1, 1, 7}, {1, 3, 3}},
{{1, 1, 6}, {2, 2, 2}}, {{1, 2, 5}, {1, 1, 8}},
{{1, 2, 3}, {1, 2, 3}}, {{2, 2, 2}, {1, 1, 6}}} *)

Finally, eliminate duplicates from swapping {a,b,c} and {d,e,f}

DeleteDuplicates[sort1st, #1 == Reverse@#2 &]
(* {{{1, 1, 8}, {1, 2, 5}}, {{1, 1, 7}, {1, 3, 3}},
    {{1, 1, 6}, {2, 2, 2}}, {{1, 2, 3}, {1, 2, 3}}} *)

to get the four solutions (up to permutations).