Polynomial Root object simplification

Question

Sometimes you may prefer to have Root object expressed as combination of several simpler Root's objects.

So suppose you have one Root object (expr2) with huge coefficients and want to simplify it so that it is expressed in terms of simpler Root's.

expr1 = (Root[2 x^3 + x^2 - 2, 1] Root[3 x^3 + 5 x^1 - 1, 2] + 
    Root[x^3 + x^2 + x - 2, 3])/Root[x^3 + 7 x^2 + 2, 1]
expr2 = expr1 // RootReduce
LeafCount /@ {expr1, expr2}
ByteCount /@ {expr1, expr2}
{FullSimplify[expr2], ToRadicals[expr2]}
(* {69, 484} )
( {2512, 20456} *)

You can see that LeafCount or ByteCount are much smaller for expr1 than expr2 but neither FullSimplify nor ToRadicals can deal with expr2, they just return the same expression.

What would be strategies to simplify such Root's?

You can test your code on the following Root for which I do not reveal its simplest form:

Root[39660142577319936 - 132200475257733120 x + 
  159899622454591488 x^2 - 90232070414008320 x^3 + 
  24561509310922752 x^4 - 2783945823289344 x^5 - 27578444414976 x^6 + 
  32208721821696 x^7 - 1960364177408 x^8 - 51842545664 x^9 + 
  8063584256 x^10 - 127145984 x^11 - 8529920 x^12 + 279104 x^13 + 
  896 x^14 - 112 x^15 + x^16, 15]

Answer 1

eq=39660142577319936 - 132200475257733120 x + 159899622454591488 x^2 - 
 90232070414008320 x^3 + 24561509310922752 x^4 - 
 2783945823289344 x^5 - 27578444414976 x^6 + 32208721821696 x^7 - 
 1960364177408 x^8 - 51842545664 x^9 + 8063584256 x^10 - 
 127145984 x^11 - 8529920 x^12 + 279104 x^13 + 896 x^14 - 
 112 x^15 + x^16

---

TL;DR:

The code below attempts to find factors of the polynomial by setting a symbolic polynomial remainder to 0. Coefficients in the factors are used as field extensions with Factor[poly,Extension->extension]. The code is not quick but works for sufficiently "simple" polynomials (including the degree 17 example above), see applications sections for examples.

The code provides explicit radical roots in cases that are a bit more complicated than the ones where ToRadical works but also struggles for relatively easy polynomials like z^8-2.

---

Preprocessing

The code below requires solving polynomial systems and tends to be very slow when the polynomial can not be easily factored by polynomials with radical coefficients. It might be good to check if the polynomial can be simplified before using the hefty codes below. Two tricks one might want to consider:

• Check If the polynomial P can be written as R[S[X]]. One may find R and S by solving the system P[X]==R[S[X]] for symbolic coefficients with R having a degree that is at most the greatest divisor of the degree of P

• Try the transformation $$x==(t+r\frac{1}{t})$$ and determine $r$ in such a way that it simplifies the equations.

---

Usage of code below:

Note: ⎵ is used for names of symbols below

factorized⎵poly=factor[eq, x]
SolveValues[factorized⎵poly == 0, x][[8]] // FullSimplify // {Identity, N} // Through

$$\left\{\left(\sqrt{5}+1\right) \left(\sqrt{7}+7\right)+2 \sqrt{7 \left(3-\sqrt{3}\right) \left(\sqrt{7}+4\right)},46.5747\right\}$$

(from the question)

N@Root[39660142577319936 - 132200475257733120 x + 
   159899622454591488 x^2 - 90232070414008320 x^3 + 
   24561509310922752 x^4 - 2783945823289344 x^5 - 
   27578444414976 x^6 + 32208721821696 x^7 - 1960364177408 x^8 - 
   51842545664 x^9 + 8063584256 x^10 - 127145984 x^11 - 
   8529920 x^12 + 279104 x^13 + 896 x^14 - 112 x^15 + x^16, 15]

(* 46.5747 *)

The code below took too long in the first example with combinations of roots as the degree of the polynomial for which the element is a root is degree 81.

---

Code:

(explanation below)

Note: ⎵ and • are used for names of symbols below

 •RadicalDenest = ResourceFunction["RadicalDenest"];
•Extensions[poly_,x_,d_,opts:OptionsPattern[]]:=
Module[{b,c,ansatz,a},
ansatz=x^d+Sum[x^ha[h],{h,0,d-1}];
PolynomialRemainder[poly,ansatz,x]
//CoefficientList[#,x]&
//SolveValues[#==0,
            Table[a[h],{h,0,d-1}],
            FilterRules[{opts}, Options[SolveValues]]
           ]&
//Flatten
//Cases[?(FreeQ[Root])]
//Flatten
//DeleteDuplicates
//DeleteCases[?AtomQ]
//Map[•RadicalDenest/Quiet]
//Cases[#,_Power,All]&
//DeleteDuplicates
]
•Extensions•Auto[poly_,x_,opts:OptionsPattern[]]:=
Module[{extensions,d,degree},
d=2
;
degree=Exponent[poly,x]
;
extensions=
•Extensions[poly,x,d,
                FilterRules[{opts}, Options[SolveValues]]
           ]
;
While[extensions==={},
    d++;
    If[d==extensions,
        Print["No factor found"]
        ;
        Abort[]
    ]
    ;
    extensions=•Extensions[poly,x,d]
]
;
extensions
]
factor[poly_,x_, opts:OptionsPattern[]]:=
Module[{extensions,factorized⎵poly},
If[Exponent[poly,x]<5,Return[poly]];
extensions=•Extensions•Auto[poly,x,
                    FilterRules[{opts}, Options[SolveValues]]
           ];
factorized⎵poly=Factor[poly,Extension->extensions];
factor[#,x]&/@factorized⎵poly
]

---

Explanation:

(Application section below)

The code •Extensions•Auto above searches for field extensions to be used in Factor[poly,Extension->extensions]. To find the extensions it starts by searching for a quadratic polynomial that factors the polynomial using the method by @chyanog here. The code then searches for radicals among its coefficients. Those radicals are used as the field extensions.

If •Extensions•Auto does not find a field extension then it tries a polynomial pf degree 3 and so on by calling •Extensions[poly,x,d] with increasing degree d for the factor.

One can also use the options Quartic and Cubic for SolveValues to determine whether the algorithm should use quartics or cubics. There are case where I found that to be useful but it can take a long time and so by default It is set to false as in SolveValues.

I used the resource function RadicalDenest to find explicit radical extensions in the event that radicals are nested and can be denested. RadicalDenest produces errors from Solve and so I used Quiet to those errors.

factor recursively factors each polynomial factor using the extensions found by •Extensions until the polynomial degree is 4 or lower. Once all polynomial factors are lower than 4 one can find exact roots.

---

Applications

Example 1 :

I imagine whether or not one can solve by radicals by factoring a quadratic term depends on the Galois Group of the roots as that would probably imply a simple permutation structure. Here is a case where factoring a degree 2 polynomial will not work:

ResourceFunction["StauduharGaloisGroup"][
  x^6 - x^5 + x^4 - x^3 - 4 x^2 + 5, x]["GaloisGroup"]

(* PermutationGroup[{Cycles[{{1, 2, 3}}], Cycles[{{4, 5, 6}}], Cycles[{{1, 2}, {4, 5}}], Cycles[{{1, 4, 2, 5}, {3, 6}}]}] *)

The Cycles[{{1, 2, 3}}], Cycles[{{4, 5, 6}}] seems to infer that a field extension can allow the polynomial to be factorized into 2 polynomials of degree 3.

Now if we try factoring a quadratic polynomial with (2 is the degree of the factor):

•Extensions[x^6 - x^5 + x^4 - x^3 - 4 x^2 + 5, x, 2]

we obtain an empty list but

•Extensions[x^6 - x^5 + x^4 - x^3 - 4 x^2 + 5, x, 3]

has the output {Sqrt[5]}

That indeed allows us to obtain the roots by radicals :

SolveValues[
  Factor[x^6 - x^5 + x^4 - x^3 - 4 x^2 + 5, Extension -> Sqrt[5]] == 
   0, x, Cubics -> True][[1]]

$$ -\frac{\left(1-i \sqrt{3}\right) \sqrt[3]{-13 \sqrt{5}+\sqrt{11070-3834 \sqrt{5}}+89}}{6\ 2^{2/3}}-\frac{1}{12} \left(1+i \sqrt{3}\right) \sqrt[3]{-26 \sqrt{5}-2 \sqrt{11070-3834 \sqrt{5}}+178}+\frac{1}{6} \left(1-\sqrt{5}\right) $$

Note that SolveValues[x^6 - x^5 + x^4 - x^3 - 4 x^2 + 5 == 0, x, Cubics -> True] // Map[ToRadicals] only yields root objects;

Example 2:

The minimal polynomial of Sqrt[2] + Sqrt[3] + Sqrt[5] + Sqrt[7]

Sqrt[2] + Sqrt[3] + Sqrt[5] + Sqrt[7] // MinimalPolynomial

(* 46225 - 5596840 #1^2 + 13950764 #1^4 - 7453176 #1^6 + 1513334 #1^8 - 141912 #1^10 + 6476 #1^12 - 136 #1^14 + #1^16 & *)

We simplify the polynomial using th substitution:

46225 - 5596840*x^2 + 13950764*x^4 - 7453176*x^6 + 1513334*x^8 - 
  141912*x^10 + 6476*x^12 - 136*x^14 + x^16 /. x -> r^(1/2)

$$ r^8-136 r^7+6476 r^6-141912 r^5+1513334 r^4-7453176 r^3+13950764 r^2-5596840 r+46225 $$

Mathematica does not find the radicals:

SolveValues[
46225 - 5596840 r + 13950764 r^2 - 7453176 r^3 + 1513334 r^4 - 
141912 r^5 + 6476 r^6 - 136 r^7 + r^8 == r, r] // Map[ToRadicals]

factor finds the roots directly :

$$ \left(-r+2 \sqrt{6}+2 \sqrt{10}-2 \sqrt{14}+2 \sqrt{15}-2 \sqrt{21}-2 \sqrt{35}+17\right) \left(-r+2 \sqrt{6}-2 \sqrt{10}+2 \sqrt{14}-2 \sqrt{15}+2 \sqrt{21}-2 \sqrt{35}+17\right) \left(-r+2 \sqrt{6}-2 \sqrt{10}-2 \sqrt{14}-2 \sqrt{15}-2 \sqrt{21}+2 \sqrt{35}+17\right) \left(-r+2 \sqrt{6}+2 \sqrt{10}+2 \sqrt{14}+2 \sqrt{15}+2 \sqrt{21}+2 \sqrt{35}+17\right) \left(r+2 \sqrt{6}+2 \sqrt{10}+2 \sqrt{14}-2 \sqrt{15}-2 \sqrt{21}-2 \sqrt{35}-17\right) \left(r+2 \sqrt{6}-2 \sqrt{10}-2 \sqrt{14}+2 \sqrt{15}+2 \sqrt{21}-2 \sqrt{35}-17\right) \left(r+2 \sqrt{6}-2 \sqrt{10}+2 \sqrt{14}+2 \sqrt{15}-2 \sqrt{21}+2 \sqrt{35}-17\right) \left(r+2 \sqrt{6}+2 \sqrt{10}-2 \sqrt{14}-2 \sqrt{15}+2 \sqrt{21}+2 \sqrt{35}-17\right) $$