How to find the numbers $a$, $b$, $c$, $d$ so that the equation has four distinct integral solutions?

Question

I want to find the numbers $a$, $b$, $c$, $d$ so that the equation $$x^4 + a x^3 + b x^2 + c x + d=0,$$ where $d = \dfrac{c^2}{a^2}$ has four distinct integral solutions.

With Maple, I found some equations like this picture. I don't know how to start with Mathematica.

Answer 1

Let p, q, r and s be the roots, so that the polynomial can be factored as:

poly = (x-p)(x-q)(x-r)(x-s);

One requirement is that $d=\frac{c^2}{a^2}$, which means:

eqn = Coefficient[poly, x, 1]^2 == Coefficient[poly, x, 0] Coefficient[poly, x, 3]^2
cond = Coefficient[poly, x, 3] != 0

(-p q r - p q s - p r s - q r s)^2 == p q r (-p - q - r - s)^2 s

-p - q - r - s != 0

The other requirement is that each root is distinct. Putting these together, we can use FindInstance:

sol = FindInstance[
    eqn && -10 < p < q < r < s < 10 && p + q + r + s != 0,
    {p, q, r, s},
    Integers,
    10
]

{{p -> -8, q -> -6, r -> -4, s -> -3}, {p -> -3, q -> -2, r -> 6, s -> 9}, {p -> -2, q -> -1, r -> 4, s -> 8}, {p -> -9, q -> -6, r -> 2, s -> 3}, {p -> -9, q -> -6, r -> 4, s -> 6}, {p -> -9, q -> -3, r -> 2, s -> 6}, {p -> -6, q -> -4, r -> 6, s -> 9}, {p -> -9, q -> -2, r -> 3, s -> 6}, {p -> -3, q -> -1, r -> 3, s -> 9}, {p -> -8, q -> -4, r -> 3, s -> 6}}

The corresponding polynomials are then:

Expand[poly /. sol] //Column //TeXForm

$\begin{array}{l} x^4+21 x^3+158 x^2+504 x+576 \\ x^4-10 x^3-15 x^2+180 x+324 \\ x^4-9 x^3-2 x^2+72 x+64 \\ x^4+10 x^3-15 x^2-180 x+324 \\ x^4+5 x^3-72 x^2-180 x+1296 \\ x^4+4 x^3-57 x^2-72 x+324 \\ x^4-5 x^3-72 x^2+180 x+1296 \\ x^4+2 x^3-63 x^2+36 x+324 \\ x^4-8 x^3-18 x^2+72 x+81 \\ x^4+3 x^3-58 x^2-72 x+576 \\ \end{array}$

Addendum

The OP requested all solutions with conditions given on the coefficients $a$, $b$, $c$ and $d$.

To answer the new question, let's first simplify eqn as in @JM's answer:

eqn2 = FullSimplify[eqn]

(q r - p s) (-p r + q s) (p q - r s) == 0

Now, suppose one of the roots is zero. Without loss of generality, take $p=0$:

eqn2 /. p -> 0

-q^2 r^2 s^2 == 0

The only way the above equation can be satisfied is if one of $q$, $r$ or $s$ is also zero. But then, the roots would not be distinct. So, the combination:

(q r-p s) (-p r+q s) (p q-r s)==0 && p < q < r < s

implies that none of the variables are 0. Another way of seeing this is with:

Reduce[eqn2 && p < q < r < s && p q r s == 0, Integers]

False

Now, let's examine the conditions in your comment for a and d:

-20 <= a <= 50
-20 <= b <= 50
-20 <= c <= 150
-20 <= d <= 150

or:

condA = -50 <= SymmetricPolynomial[1, {p, q, r, s}] <= 20
condB = -20 <= SymmetricPolynomial[2, {p, q, r, s}] <= 50
condC = -150 <= SymmetricPolynomial[3, {p, q, r, s}] <= 20
condD = -20 <= SymmetricPolynomial[4, {p, q, r, s}] <= 150

-50 <= p + q + r + s <= 20

-20 <= p q + p r + q r + p s + q s + r s <= 50

-150 <= p q r + p q s + p r s + q r s <= 20

-20 <= p q r s <= 150

The natural attempt would be to use Solve with the above conditions. However, Solve is unable to make progress within a reasonable amount of time:

TimeConstrained[
    Solve[
        eqn2 && condA && condB && condC && condD && p < q < r < s,
        {p, q, r, s},
        Integers
    ],
    250
]

$Aborted

Restricting the range over which $p$, $q$, $r$ and $s$ can vary, and reducing the number of conditions that must be satisfied helps. For instance:

Solve[
    eqn2 && condA && condD && -3 < p < q < r < s < 3,
    {p, q, r, s},
    Integers
]

{{p -> -2, q -> -1, r -> 1, s -> 2}}

The conditions condB and condC can be imposed afterwards, but the range must be large enough to encompass all possible solutions. Examining condA and condD (and realizing that none of the roots are 0) suggests that the smallest possible value for p is -52, and the largest possible value for s is 25. Let's verify:

Reduce[p < -52 && q < r < s && condA && condD && q r s != 0, {p, q, r, s}, Integers]
Reduce[s > 25 && p < q < r && condA && condD && p q r != 0, {p, q, r, s}, Integers]

False

False

Hence, we can perform the following Solve:

sol = Solve[
    eqn2 && condA && condD && -53 < p < q < r < s < 26,
    {p, q, r, s},
    Integers
];
Length[sol]

67

Imposing condB and condC (and $a \neq 0$):

final = Cases[sol, v_ /; (condB && condC && p+q+r+s != 0 /. v)];

yields the following polynomials:

Expand[(x-p)(x-q)(x-r)(x-s) /. final] //Column //TeXForm

$\begin{array}{l} x^4+12 x^3+47 x^2+72 x+36 \\ x^4+3 x^3-8 x^2-12 x+16 \\ x^4-5 x^3-20 x^2+60 x+144 \\ x^4-4 x^3-17 x^2+24 x+36 \\ x^4-8 x^3-18 x^2+72 x+81 \\ x^4-12 x^3-13 x^2+144 x+144 \\ x^4-3 x^3-8 x^2+12 x+16 \\ x^4-6 x^3-7 x^2+36 x+36 \\ x^4-9 x^3-2 x^2+72 x+64 \\ x^4-12 x^3+7 x^2+120 x+100 \\ \end{array}$

Answer 2

Call the distinct integers $p,q,r,s$. Then find an instance in which $$x^4+a x^3 +bx^2 +cx+d = (x-p)(x-q)(x-r)(x-s) .$$

f = (x - p) (x - q) (x - r) (x - s);
Collect[f, x]
d = Coefficient[f, x, 0];
c = Coefficient[f, x, 1];
a = Coefficient[f, x, 3];
soln = First@FindInstance[
   {d == c^2/a^2, p != q != r != s},
   {p, q, r, s}]
f /. soln // Expand

(*
{p -> 8, q -> -6, r -> -12, s -> 9}
5184 + 72 x - 162 x^2 + x^3 + x^4
*)

Another solution can be found:

skip = {p, q, r, s} /. soln
sol2 = First@FindInstance[
   {d == c^2/a^2, p != q != r != s, Not[MemberQ[skip, p]]},
   {p, q, r, s}, Integers]
f/.sol2//Expand

(*
{p -> -1, q -> -2, r -> -4, s -> -8}
64 + 120 x + 70 x^2 + 15 x^3 + x^4
*)

Answer 3

(I am not at a computer with Mathematica, so I will have to defer explanation for another time.)

With[{n = 20, (* number of instances *), bound = 10,
           seed = 10 (* seed the PRNG *)},
          (x - p) (x - q) (x - r) (x - s) /.
          FindInstance[(p q - r s) (q s - p r) (q r - p s) == 0 &&
                                   -bound < p < q < r < s < bound, {p, q, r, s},
                                    Integers, n, RandomSeeding -> seed]]

should return n solutions; change seed to see other solutions, or increase n for more solutions.

Answer 4

FindInstance can be slow, and it is not known a priori how many solutions are possible. I tried a different approach. It is fast compared to FindInstance and Solve. I think it gives all the solutions, but is inelegant because of all the duplicates to delete.

Roots $\{p,q,r,s\}$ of a quartic multiply together to give the integer polynomial coefficient $d$, which is required to equal $c^2/a^2>0$. Given square $d$, find factorisations into 4 factors with MultiplicativePartitionsMrW from @Mr.Wizard, then test for $c^2/a^2=d$.

MultiplicativePartitionsMrW[n_, 1, ___] := {{n}}

MultiplicativePartitionsMrW[n_, k_, x_: 2] := 
   Join @@ Table[
      If[q < x, {}, 
         Apply[{q, ##} &, 
            MultiplicativePartitionsMrW[n/q, k - 1, q], {1}]],
       {q, Take[#, Ceiling[Length[#]/k]] &[Divisors[n]]}]

We want all factorisations having 4 parts, found with 4 factors $\ge 2$, or by prepending $\{1\}$ to the solution with 3 factors $\ge 2$, or prepending $\{1,1\}$ to solutions with 2 factors $\ge 2$.

pqrs[d_] := 
   Join[
      MultiplicativePartitionsMrW[d, 4], 
      Map[Join[{1}, #] &, MultiplicativePartitionsMrW[d, 3]],
      Map[Join[{1, 1}, #] &, MultiplicativePartitionsMrW[d, 2]]
   ]

There are 8 combinations of signs of $\{p,q,r,s\}$ giving positive $d$.

signs[{p_, q_, r_, s_}] :=
   {{p, q, r, s}, {-p, -q, r, s}, {-p, q, -r, s}, {-p, q, r, -s},
    {p, -q, -r, s}, {p, -q, r, -s}, {p, q, -r, -s}, {-p, -q, -r, -s}}

Given roots $\{p,q,r,s\}$ corresponding to $d=p*q*r*s$, return coefficients $\{1,a,b,c,d\}$ if $a\ne 0$ and $d=c^2/a^2$.

abcd[{p_, q_, r_, s_}] :=
   With[{a = -p - q - r - s, c = -q r (p + s) - p s (q + r)},
      If[a != 0 && a^2 p q r s == c^2,
        {1, a, q (p + r + s) + p (r + s) + r s, c, p q r s}, {}]
   ]

Given square $d$, find solutions, if any, for coefficients $\{1,a,b,c,d\}$ with QuarticSolution[d].

QuarticSolution[d_] :=
   DeleteCases[
      DeleteDuplicates[Map[abcd,
         Select[
            Flatten[Map[signs, pqrs[d]], 1],
            Length[#] === Length[DeleteDuplicates[#]] &]
      ]],
   {}]

For example,

QuarticSolution[16]

{{1, -3, -8, 12, 16}, {1, 3, -8, -12, 16}}

These are the 10 solutions with the additional constraints on the coefficients. Timing is 8ms.

With[{maxd = 150},
   Flatten[Table[
      Select[
         QuarticSolution[d],
         -20 <= #[[2]] <= 50 && -20 <= #[[3]] <= 50 &&
         -20 <= #[[4]] <= 150 && -20 <= #[[5]] <= maxd &],
      {d, Range[Sqrt[maxd]]^2}], 1]
]

{{1, -3, -8, 12, 16},{1, 3, -8, -12, 16}, {1, -6, -7, 36, 36}, {1, -4, -17, 24, 36}, {1, 12, 47, 72, 36}, {1, -9, -2, 72, 64}, {1, -8, -18, 72, 81}, {1, -12, 7, 120, 100}, {1, -5, -20, 60, 144}, {1, -12, -13, 144, 144}}