Solving quintic in radicals

Question

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.

Answer 1

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.

Answer 2

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.