Solving quintic in radicals

11

4

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.

Vladimir Reshetnikov

Posted 2016-12-15T01:39:44.990

Reputation: 6 772

Were you at least able to perform a Tschirnhaus transformation on it? – J. M.'s ennui – 2016-12-15T01:49:42.250

I tried to perform it using function from TschirnhausTransformation.nb, but it looks Mathematica chokes on too large expressions.

– Vladimir Reshetnikov – 2016-12-15T03:36:24.777

Could try code from this Wolfram Communiity post.

– Daniel Lichtblau – 2016-12-15T22:44:32.457

@DanielLichtblau Isn't that post about radical denesting? How do I apply it to solving quintics? – Vladimir Reshetnikov – 2016-12-15T22:58:10.057

Yes, it is about denesting. I guess I had a hope that it might be able to go from min poly to radical expression. – Daniel Lichtblau – 2016-12-16T18:35:47.913

Answers

10

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

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)))]

Vladimir Reshetnikov

Posted 2016-12-15T01:39:44.990

Reputation: 6 772

1Please let me know if you find solvable quintics that this program cannot handle. – Vladimir Reshetnikov – 2017-01-01T05:31:16.923