6
$\begingroup$

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.
enter image description here

$\endgroup$
  • $\begingroup$ Look up the FindInstance function. $\endgroup$ – user6014 Oct 13 '18 at 17:06
  • 1
    $\begingroup$ My idea was FindInstance as well which works for easier problems: eq = a x^3 + b x^2 + c x; stance[Equal @@@ Flatten@Solve[eq == 0, x], {x, a, b, c}, Integers, 3]. However, for the example of the OP that doesn't work since the general solution contains complex terms. Does anyone know a general answer to such problems? $\endgroup$ – halirutan Oct 13 '18 at 17:32
7
$\begingroup$

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

$\endgroup$
  • $\begingroup$ How can I find all equations, for example, -20 <=a<=50, -20 <=b<=50, -20 <=c<=150, -20 <=d<=150? $\endgroup$ – minhthien_2016 Oct 14 '18 at 9:20
  • $\begingroup$ Yes, the symmetric polynomials (i.e. Vieta) were how I arrived at the main equation in my solution (via pen and paper). Nice to see the expansion of the idea! $\endgroup$ – J. M.'s technical difficulties Oct 14 '18 at 16:42
  • $\begingroup$ Thank you very much. $\endgroup$ – minhthien_2016 Oct 15 '18 at 0:18
3
$\begingroup$

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
*)
$\endgroup$
3
$\begingroup$

(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.

$\endgroup$
  • $\begingroup$ How can I find all equations, for example, -20 <=a<=50, -20 <=b<=50, -20 <=c<=150, -20 <=d<=150? $\endgroup$ – minhthien_2016 Oct 14 '18 at 9:19
  • $\begingroup$ Why did you not put that restriction in your question? $\endgroup$ – J. M.'s technical difficulties Oct 14 '18 at 9:23
  • $\begingroup$ I am sory about this. Can I edit my question? $\endgroup$ – minhthien_2016 Oct 14 '18 at 9:29
3
$\begingroup$

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

$\endgroup$
  • $\begingroup$ I can not get the results. $\endgroup$ – minhthien_2016 Oct 17 '18 at 12:36
  • $\begingroup$ Sorry, there was a missing comma in the definition for pqrs, now fixed. $\endgroup$ – KennyColnago Oct 19 '18 at 17:27
  • $\begingroup$ Thank you very much. I got the results. $\endgroup$ – minhthien_2016 Oct 20 '18 at 6:30
  • $\begingroup$ I got 99 equations about 8 seconds. $\endgroup$ – minhthien_2016 Oct 21 '18 at 13:47

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.