Solving quintic in radicals

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.

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.