16
$\begingroup$

I need to find an explicit expression in radicals for the real root of the quintic equation

1152921504606846976 + 99923616732282880 x + 3740744716124160 x^2 - 2794496983040 x^3 + 2257838080 x^4 + x^5 == 0

I tried to use Radicals.nb from here. SolvableQ says the equation is solvable in radicals, but SolveQuintic returns $Failed for some reason. Could you please help me to find an explicit solution, and suggest how to fix this apparent bug in SolveQuintic?

The quintic equation is not completely random, its real root is actually the value of

With[{q = -Exp[-π √47]}, QPochhammer[q, q^2]^24/q]]

and should have an explicit representation in radicals.

$\endgroup$
5
  • $\begingroup$ Were you at least able to perform a Tschirnhaus transformation on it? $\endgroup$ Dec 15, 2016 at 1:49
  • $\begingroup$ I tried to perform it using function from TschirnhausTransformation.nb, but it looks Mathematica chokes on too large expressions. $\endgroup$ Dec 15, 2016 at 3:36
  • $\begingroup$ Could try code from this Wolfram Communiity post. $\endgroup$ Dec 15, 2016 at 22:44
  • $\begingroup$ @DanielLichtblau Isn't that post about radical denesting? How do I apply it to solving quintics? $\endgroup$ Dec 15, 2016 at 22:58
  • $\begingroup$ Yes, it is about denesting. I guess I had a hope that it might be able to go from min poly to radical expression. $\endgroup$ Dec 16, 2016 at 18:35

2 Answers 2

13
$\begingroup$

I wrote this function based on Daniel Lazard's paper Solving Quintics by Radicals:

QuinticToRadicals[root_Root] := 
  Block[{a, b, c, d, e, f, h, p, q, r, s, t, u, v, w, x, z, g, F, A, 
    B, G, H, L, M, P, Q, R, S},
   If[!TrueQ[Element[root, Algebraics]], Return[root]];
   With[{m = MinimalPolynomial[root, z]},
    If[!PolynomialQ[m, z] || Exponent[m, z] != 5, 
     Return[root]];
    {f, e, d, c, b, a} = CoefficientList[m, z]];
   p = (5 a c - 2 b^2)/(5 a^2);
   q = (25 a^2 d - 15 a b c + 4 b^3)/(25 a^3);
   r = (125 a^3 e - 50 a^2 b d + 15 a b^2 c - 3 b^4)/(125 a^4);
   s = (3125 a^4 f - 625 a^3 b e + 125 a^2 b^2 d - 25 a b^3 c + 4 b^5)/(3125 a^5);
   G = Select[Solve[{(p^2 + 12 r + 4 t) Discriminant[z^5 + p z^3 + q z^2 + r z + s, z] 
     == (2 t^3 + 8 t^2 r + (2 p q^2 - 6 p^2 r + 24 r^2 - 50 q s) t - 2 q^4 + 
         13 p q^2 r - 16 (p^2 - 4 r) r^2 - 5 q (3 p^2 + 40 r) s + 
         125 p s^2)^2, 
     4 r^2 + 2 q (p q + 5 s + 2 u) + 5 x == 
      t^2 + 2 p^2 (3 r + t) + 2 p v, 
     3 p^4 (2 r + t) + 5 p s (50 s + 9 u) + 
       3 q^2 (18 p r + 5 p t + 4 v) + 
       q (-20 s (7 r + 3 t) + 6 r u + p w) + 
       2 (40 r^3 + 16 r^2 t + t^3 + 25 s w + 10 r x) == 
      14 q^4 + 28 p r v + 
       p^2 (52 r^2 + 36 r t + q (3 p q + 41 s + 3 u) - 3 p v + 3 x), 
     q^4 (30 r - 4 t) + t^4 + p^4 (22 r^2 - 6 q s + 4 r t) + 
       q^2 (50 s^2 - 155 s u - 29 r v) + 
       p^3 (-4 q^2 (4 r + t) + 9 s u + 4 r v) + 
       p (q^3 (-132 s + 8 u) - 5 s (110 r s - 5 s t + 28 r u) + 
          16 r^2 v + q (105 s v + 8 r w) - 
          3 q^2 (14 r^2 + 5 r t - 3 x)) + 
       p^2 (4 q^4 - 68 r^3 + 16 r^2 t + 
          q (404 r s + 79 s t - 17 r u) - 4 q^2 v - 15 s w - 
          19 r x) == 
      16 r^4 + 3 q^3 w + 20 r s (4 q t + 5 w) + 
       4 r^2 (5 q s - 17 q u - 15 x) + 25 s (5 s v + 9 q x), 
     625 s^3 (10 s + u) + q^5 (858 s + 20 u) + 
       p^5 (198 s^2 + 5 q^2 (5 r + t) - 15 r v) + 
       q^2 (5 s (2140 r s + 365 s t + 43 r u) - 12 r^2 v) + 
       q^4 (-34 r^2 - 43 r t + 22 x) + 
       8 r^2 (120 r^3 + 64 r^2 t + 25 s w + 30 r x) + 
       p^3 (q^3 (181 s - 5 u) + s (-810 r s + 355 s t - 147 r u) + 
          168 r^2 v - q (212 s v + 11 r w) - 
          q^2 (22 r (13 r + 5 t) + 5 x)) + 
       p^4 (-5 q^4 + q (-491 r s - 200 s t + 15 r u) + 5 q^2 v + 
          18 s w + r (4 r (91 r + 50 t) + 15 x)) + 
       p^2 (5 q^4 (19 r + 3 t) + 
          2 q r (2060 r s + 864 s t - 45 r u) + 325 s^2 v + 
          q^2 (3005 s^2 + 351 s u - 83 r v) + 3 q^3 w + 290 q s x - 
          2 r (544 r^3 + 216 r^2 t + 265 s w + 76 r x)) == 
      15 p^6 r (2 r + t) + 2 (t^5 + 750 r s^2 v) + 
       q^3 (620 s v + 41 r w) + 
       q (2640 r^2 s t + 8 r^3 (780 s - 19 u) + 2375 s^2 w + 
          700 r s x) + 
       p (12 q^6 + 20 r s (-45 r s + 10 s t + 21 r u) + 
          q^3 (4095 r s + 752 s t + 43 r u) - 10 q^4 v + 176 r^3 v + 
          5 q s (635 s (5 s + u) - 312 r v) - 124 q r^2 w + 
          1375 s^2 x - q^2 (612 r^3 + 220 r^2 t + 110 s w - 27 r x)), 
     Element[t, Rationals]}, {t, u, v, w, x}], FreeQ[ConditionalExpression], 1];
   If[G == {}, Return[root], G /. Rule -> Set];
   g = -3 p^2 (-v + q^2) + 20 v r - 50 u s + 125 s^2 + 
     3 q^2 (-7 r + t) + p^3 (4 r + 3 t) + 
     p (16 r^2 - q (u - 40 s) + 12 r t);
   h = 366 v q^3 - 402 q^5 - 748 u q^2 r + 440 w r^2 - 448 q r^3 - 
     12 p^5 s - 275 w q s + 2100 v r s - 1925 q^2 r s - 4875 u s^2 - 
     1875 s^3 + x (-65 p^2 q - 550 q r + 875 p s) + 524 q r^2 t - 
     1040 q^2 s t + p^4 q (158 r + 85 t) + 
     p^3 (85 v q - 85 q^3 + 4 u r - 1462 r s - 418 s t) + 
     p (41 w q^2 - 298 v q r - 56 u r^2 + 5 q s (419 u + 35 s) + 
        10 r s (290 r + 159 t) + q^3 (896 r + 419 t)) - 
     p^2 (58 w r + 520 v s + q (73 u q - 142 r^2 + 159 q s + 440 r t));
   F = Sqrt[
    5 (40 x p - 120 w q + p^2 (-24 v + 40 q^2) + 100 v r + 
       332 q^2 r - 300 u s + 125 s^2 + p^3 (-80 r - 24 t) + 24 q^2 t +
        p (88 u q + 160 r^2 - 480 q s + 100 r t))]; 
   A = Sqrt[5/2 (g + h/F)]; 
   B = 1/(A F)
      5 (42 q^5 + 12 p^5 s + 3 p^4 q (14 r + 5 t) + 
       q^2 (550 r s + 515 s t - 182 r u) - 6 q^3 v + 
       p^3 (-15 q^3 + 492 r s + 213 s t - 4 r u + 15 q v) - 
       50 s (25 s^2 - 60 s u + 22 r v) - 40 r^2 w + 650 q s w + 
       p^2 (-3 q^2 (52 s + 9 u) + 195 s v - 22 r w + 
          q (358 r^2 + 50 r t - 35 x)) - 
       8 q r (29 r^2 + 23 r t + 25 x) + 
       p (q^3 (-246 r + t) + 5 q s (565 s - 54 u) - 
          4 r (350 r s + 235 s t - 24 r u) + 68 q r v + 19 q^2 w - 
          250 s x));
   H = -1750 w q + p^2 (-600 v + 500 q^2) + 2500 v r - 7500 u s + 
     3125 s^2 + q^2 (-700 r - 1150 t) + p^3 (-2000 r - 600 t) + 
     p (1000 x + 1700 u q + 4000 r^2 - 6375 q s + 2500 r t); 
   L = -25 x p - 9 v p^2 - 25 w q - 7 u p q - 7 p^2 q^2 - 60 v r + 
     50 p^3 r + 128 q^2 r - 308 p r^2 + 525 u s - 145 p q s - 
     1000 s^2 - p^3 t + 11 q^2 t - 96 p r t; 
   M = -125 x p + 67 v p^2 + 75 w q - 109 u p q - 79 p^2 q^2 - 
     420 v r + 210 p^3 r + 496 q^2 r - 676 p r^2 + 1175 u s - 
     415 p q s - 750 s^2 + 63 p^3 t + 27 q^2 t - 412 p r t; {A, B, 
     F} = Select[{{A, B, F}, {-A, -B, F}, {B, -A, -F}, {-B, A, -F}}, 
      Apply[25 (2 u - p q - 5 s) + (L #1 + M #2)/g + H/#3 != 0 &], 
      1][[1]];
   
   P = 1/5 (5/4 (25 (2 u - p q - 5 s) + (L A + M B)/g + H/F))^(1/5); 
   Q = -((4 p^2 q + 2 (36 q r + 7 q t - 5 w) + p (-45 s + 4 u + F))/(
     10 P F)); 
   R = 1/(500 P^2) (-25 q + (
       25 (-40 r^2 - 35 q s + 2 p^2 (10 r + t) - 22 q u + 
          2 p (q^2 + v) - 10 x))/F + 
       1/g 2 (-105 q s A - 140 q s B + 4 r t (3 A + 4 B) + 
          2 p q^2 (7 A + 11 B) + r^2 (76 A + 68 B) - 
          2 p^2 (29 r A + 3 A t + 17 r B + 9 t B) + 23 q A u + 
          14 q B u - 2 p (2 A + 11 B) v + 35 A x + 5 B x)); 
   S = 1/(500 P^3) (1/
        g (-80 r s A + 30 s A t + 60 r s B + 40 s t B + 
          14 q^3 (A + 3 B) - 16 r g + 3 t g + 
          2 p^2 (26 s A + 18 s B + g) + 8 r A u + 44 r B u - 
          2 q (p (26 r A + 3 A t + 33 r B + 14 t B) + (A + 18 B) v) + 
          p (-8 A w + 6 B w)) + (
       5 (8 p^3 q - 2 p q (13 r + t) + p^2 (-20 s + 8 u) + 
          5 (14 q^3 + 10 r s - 5 s t - 10 r u - 2 q v)))/F); 
   Select[{P + Q + R + 
        S, (-1)^(4/5) P - (-1)^(1/5) Q + (-1)^(2/5) R - (-1)^(3/5)
          S, -(-1)^(3/5) P + (-1)^(2/5) Q + (-1)^(4/5) R - (-1)^(1/5)
          S, +(-1)^(2/5) P - (-1)^(3/5) Q - (-1)^(1/5) R + (-1)^(4/5)
          S, -(-1)^(1/5) P + (-1)^(4/5) Q - (-1)^(3/5) R + (-1)^(2/5)
          S} - b/(5 a), !TrueQ[# != root] &, 1][[1]]];

Beware! If found some typos in the paper on p. 222 in the formula for $P_{22}$: the term $\color{red}{8p^3}$ should be replaced with $8p^3q$, and the term $\color{red}{70q^3q}$ should be replaced with $70q^3$.

The function can be used on quintic Root objects as follows:

QuinticToRadicals[Root[-1 + 2 #1 + 3 #1^2 + #1^5 &, 1]]

After some simplifications the root I am interested in can be represented as

Block[{a, b, c, d, f, g, h}, 
  a = Sqrt[25778705 + 5353862 Sqrt[5]]; 
  b = 253 Sqrt[47] Sqrt[223185962057628283872014741096225 + 
     46404398781233715250377772758698 Sqrt[5]]; 
  c = 118179607126755427283 - 33773932059671 Sqrt[5]; 
  d = 1302883789494160617301390 - 930862886277288987 Sqrt[5]; 
  f = 765881115 - 1071962031710725 Sqrt[5]; 
  g = 5155741^(1/5) (6514418947470803086506950 - 4654314431386444935 Sqrt[5] + 
      253 Sqrt[47] Sqrt[223185962057628283872014741096225 + 
        46404398781233715250377772758698 Sqrt[5]])^(1/5); 
  h = 1/(5 d + b)^(1/5); 
   -1024/25778705 (10 5^(1/5) 10311482^(4/5) g + 
      253 10^(2/5) Sqrt[47]
        a h^2 (4993350841 5^(1/5) + 825542539482355 2^(1/5) h) + (
      38747022105 Sqrt[47] (-831611761 5^(1/10) 10311482^(2/5) + 
         18363423328399 2^(3/5) 5^(9/10) g^2 h^3))/(a g^2) + 
      25778705 (440984 + 2 2^(4/5) 5^(1/5) (5 d - b)^(1/5) - 
         2^(2/5) 5^(1/10) h^2 (f - 2^(1/5) 5^(3/10) c h)))]

Update: I found a rather simple case case when my implementation fails:

QuinticToRadicals[Root[-6 - 10 #1 - 10 #1^2 + #1^5 &, 1]]

gives a message about division by zero and returns Indeterminate, while the expected answer is

2^(1/5) + 2^(2/5)

It will try to investigate and fix this issue. Any help is appreciated.

$\endgroup$
10
  • 1
    $\begingroup$ Please let me know if you find solvable quintics that this program cannot handle. $\endgroup$ Jan 1, 2017 at 5:31
  • $\begingroup$ How to use it?.. $\endgroup$
    – Anixx
    Nov 5, 2021 at 22:49
  • $\begingroup$ @Anixx QuinticToRadicals[Root[-1 + 2 #1 + 3 #1^2 + #1^5 &, 1]] $\endgroup$ Nov 5, 2021 at 23:47
  • $\begingroup$ Thank you! I tried this before but it did not work for some reason. $\endgroup$
    – Anixx
    Nov 5, 2021 at 23:54
  • $\begingroup$ What happens if you remove all the conditional checks? Will it produce incorrect results? $\endgroup$
    – Anixx
    Nov 5, 2021 at 23:58
8
$\begingroup$

I reproduced the algorithm from this post and I tried to use it on your example: An Easy Way To Solve The Solvable Quintic Using Two Sextics.

As mentioned in the article, for the quintic equation:

$$a x^5 + b x^4 + c x^3 + d x^2 + e x + f=0$$

If the equation is solvable, then the solution is of the form:

$$\begin{bmatrix} x_1\\x_2\\x_3\\x_4\\x_5 \end{bmatrix}= \begin{bmatrix} 1 & 1 & 1 & 1 \\ e^{+\frac{2 i \pi }{5}} & e^{+\frac{4 i \pi }{5}} & e^{-\frac{4 i \pi}{5}} & e^{-\frac{2 i \pi}{5}} \\ e^{+\frac{4 i \pi }{5}} & e^{-\frac{2 i \pi}{5}} & e^{+\frac{2 i \pi }{5}} & e^{-\frac{4 i \pi}{5}} \\ e^{-\frac{4 i \pi}{5}} & e^{+\frac{2 i \pi }{5}} & e^{-\frac{2 i \pi}{5}} & e^{+\frac{4 i \pi }{5}} \\ e^{-\frac{2 i \pi}{5}} & e^{-\frac{4 i \pi}{5}} & e^{+\frac{4 i \pi }{5}} & e^{+\frac{2 i \pi }{5}} \\ \end{bmatrix} \cdot \begin{bmatrix} \sqrt[5]{\zeta_1}\\ \sqrt[5]{\zeta_2}\\ \sqrt[5]{\zeta_3}\\ \sqrt[5]{\zeta_4}\\ \end{bmatrix}-\frac{b}{5a}$$

So my algorithm only gives $\zeta_1,\zeta_2,\zeta_3,\zeta_4$.

simplify[e_] := FullSimplify[
    ToRadicals@e,
    ComplexityFunction -> (100 Count[#, Root[__], All] + LeafCount[#]&)
];
getCoefficient[a_, b_, c_, d_, e_, f_] := {
    (-2 b^2 + 5 a c) / (50 a^2),
    (4 b^3 - 15 a b c + 25 a^2 d) / (250 a^3),
    (-3 b^4 + 15 a b^2 c - 50 a^2 b d + 125 a^3 e) / (625 a^4),
    (b (4 b^4 - 25 a b^2 c + 125 a^2 b d - 625 a^3 e)) / (3125 a^5) + f / a
};
findGenerator[a_, b_, c_, d_] := Block[
    {\[CapitalDelta], d1, d2, g1, g2, discriminant, generator},
    \[CapitalDelta] = 16 c^2 (-200 a^3 b^2 - 135 b^4 + 400 a^4 c + 360 a b^2 c - 160 a^2 c^2 + 16 c^3) + 32 b (4 b^2 (40 a^3 + 27 b^2) - 45 a (8 a^3 + 7 b^2) c + 140 a^2 c^2 - 20 c^3) d + 8 (432 a^5 + 330 a^2 b^2 - 180 a^3 c + 45 b^2 c + 20 a c^2) d^2 - 120 a b d^3 + d^4;
    d1 = {
        3125,
        0,
        -625 (3 a^2 + c),
        0,
        25 (15 a^4 + 8 a b^2 - 2 a^2 c + 3 c^2 - 2 b d),
        Sqrt[\[CapitalDelta]],
        -25 a^6 - 40 a^3 b^2 - 16 b^4 + 35 a^4 c + 28 a b^2 c - 11 a^2 c^2 + c^3 - 2 b (a^2 + c) d + a d^2
    };
    d2 = {
        3125,
        0,
        625 (-3 b^2 + 4 a c),
        0,
        25 (15 b^4 - 40 a b^2 c + 20 a^2 c^2 - 4 c^3 + 8 a^2 b d + 6 b c d - 2 a d^2),
        d Sqrt[\[CapitalDelta]],
        -25 (b^3 - 2 a b c)^2 - 2 b (20 a^2 - 3 c) (b^2 - 2 a c) d - (16 a^4 + 2 a b^2 - 8 a^2 c + c^2) d^2 + b d^3
    };
    g1 = guessGenerator[d1];
    g2 = guessGenerator[d2];
    If[Length@g1 == 0, Return[Failure["Unable to solve", <||>]]];
    If[Length@g2 == 0, Return[Failure["Unable to solve", <||>]]];
    {First@guessGenerator[d1], First@guessGenerator[d2]}
];
guessGenerator[discriminant_] := Block[
    {kx, ks},
    ks = NSolve[FromDigits[discriminant, kx] == 0, kx,Reals, WorkingPrecision -> 60];
    Select[RootApproximant[kx /. ks, 2], FromDigits[discriminant, #] == 0&]
];
solveResolvent[a_, b_, c_, d_, p_, q_] := Block[
    {D5Resolvent, F5Resolvent, kx, var},
    D5Resolvent = {1, d, 2 a^5 - 5 a^3 c - 4 b^2 c + a (c^2 + 2 b d), -a^5 d, a^10};
    F5Resolvent = {
        p,
        p (d - 20 p q),
        -p (2 a^5 + 2 a^2 b^2 + 20 a^3 p^2 + 10 a p^4 + b^2 (c - 6 p^2)) - 2 b (a^3 + b^2 - a c + 3 a p^2) q + (4 a^2 - c) p q^2 + 2 b q^3, -5 a^6 b p + a^7 q + a^5 (-c + p^2) q + a p^3 (-4 b^3 + 3 c p q - 13 p^3 q + 4 b q^2) + a^3 p (-4 b^3 - 2 c p q + 11 p^3 q + 4 b q^2) + a^2 p^2 (-2 b c p + 9 b p^3 + 6 b^2 q - 6 q^3) + a^4 (3 b c p - 5 b p^3 + b^2 q - q^3) + p^4 (b (-c p + p^3) + b^2 q - q^3),
        p (a^2 - p^2)^5
    };
    If[
        p == 0,
        var /. Solve[FromDigits[D5Resolvent, var] == 0, var],
        var /. Solve[FromDigits[F5Resolvent, var] == 0, var]
    ]
];
getPseudoRoot[a_, b_, c_, d_, e_, f_] := Block[
    {p, q, r, s, g, u, v},
    {p, q, r, s} = getCoefficient[a, b, c, d, e, f];
    g = findGenerator[p, q, r, s];
    If[
        FailureQ@g,
        Return@g,
        {u, v} = g
    ];
    {-b / (5a), solveResolvent[p, q, r, s, u, v]}
];

coeff = Reverse@CoefficientList[-1 + 2 #1 + 3 #1^2 + #1^5 &[x], x];
coeff = Reverse@CoefficientList[-6 - 10 #1 - 10 #1^2 + #1^5 &[x], x];
{a, b} = getPseudoRoot @@ coeff
x1 = Tr@Surd[b, 5] + a
(*x1//RootReduce*)
RootApproximant[x1, 5]

It successfully found a root of the equation $x^5-10 x^2-10 x-6=0$ is $x_1=\sqrt[5]{2}+2^{2/5}$.

But it failed in your example.

After research, I found that this is not a problem of the algorithm.

The problem is that RootApproximant in guessGenerator doesn't fit the huge coefficients well, I don't know how to fix this.

After manual fitting, I found $\{p,q\}=\left\{-58275659776 \sqrt{5},26315474732392120320 \sqrt{5}\right\}$

So we have:

\begin{aligned} -\frac{x_1}{2048} &=220492\\ &+ 2^{4/5} \sqrt[5]{5 \left(-4654314431386444935 \sqrt{5}+253 \sqrt{47 \left(46404398781233715250377772758698 \sqrt{5}+223185962057628283872014741096225\right)}+6514418947470803086506950\right)}\\ &+2^{4/5} \sqrt[5]{5 \left(-4654314431386444935 \sqrt{5}-253 \sqrt{47 \left(46404398781233715250377772758698 \sqrt{5}+223185962057628283872014741096225\right)}+6514418947470803086506950\right)}\\ &+2^{4/5} \sqrt[5]{5 \left(4654314431386444935 \sqrt{5}+253 \sqrt{47 \left(223185962057628283872014741096225-46404398781233715250377772758698 \sqrt{5}\right)}+6514418947470803086506950\right)}\\ &+2^{4/5} \sqrt[5]{5 \left(4654314431386444935 \sqrt{5}-253 \sqrt{47 \left(223185962057628283872014741096225-46404398781233715250377772758698 \sqrt{5}\right)}+6514418947470803086506950\right)} \end{aligned}

eq = 1152921504606846976 + 99923616732282880 x + 3740744716124160 x^2 - 2794496983040 x^3 + 2257838080 x^4 + x^5;
coeff = Reverse@CoefficientList[eq, x];
{a, b} = {
    -451567616,
    solveResolvent[
        -203913591269621760,
        184161674750051152297984000,
        -124742258113864494225907240665088000,
        75106136945420552127297065232870932480000000,
        -58275659776 Sqrt[5],
        26315474732392120320 Sqrt[5]
    ]
}
x1 = N[Tr@Surd[b, 5] + a, 50]
First[x /. NSolve[eq == 0, WorkingPrecision -> 50]]
(*x1//RootReduce*)
RootApproximant[x1, 5]

After the verification of the numerical value, it is found that the fifty digits are exactly the same.

$\endgroup$
1
  • $\begingroup$ Nice. But I'd trust this more if it were verified to 1000 or so digits. $\endgroup$ May 20 at 23:24

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.