Dear Bill, I think this method of "factoring sextics into cubics over a square root extension" works only for certain solvable transitive groups (including the cyclic and dihedral groups). But what if the sextic factors ONLY as three quadratics over a cube root extension? For example, the solvable sextic below has transitive group 6T8, x^6+x^4-4x^3+7x^2-2x-5 = 0 (eq.1) This does not factor over the square root of its discriminant D = 6^6*37^3, but will factor into three quadratics as, x^2+m x+(m^2-1) = 0 with coefficients determined by the cubic, m^3-4m-2 = 0 Can you try (eq.1) with your program, pls? (I'm using an older version of Mathematica so cannot test it myself.) Sincerely, - Tito On Sat, Sep 17, 2011 at 2:31 AM, Bill Gosper <billgosper@gmail.com> wrote:
I believe the following ridiculously short function will solve any solvable sextic:
Ssexy[q_] := Catch[Block[{rts = #[[1, 2]] & /@ NSolve[q == 0, WorkingPrecision -> 666], foos}, foos = InverseFourier[ rts[[#]]/Sqrt[6]]^6 & /@ (Join[{1}, #] & /@ (1 + Permutations[Range[5]])); Factor[Rationalize[ Expand[Times @@ (# - Rest[foos[[ Ordering[Denominator[Rationalize[Plus @@ #, 9.^-666]] & /@ foos, 1][[1]]]]])]]] /. (a_: 1)*# + b_ :> Throw[Solve[0 == Factor[q, Extension -> Sqrt[-b/a]]]]; Solve[0 == q]]]
This is based on the empirical observation that the resolvent quintic, when it exists, will have a linear factor whose root, when square rooted, will split the sextic into cubics. When there is no quintic with rational coeffs, Solve still has a chance of factoring or decomposing. Here's an example of splitting.
In[1325]:= MinimalPolynomial[Cos[\[Pi]/5] - Cos[\[Pi]/7], c]
Out[1325]= -1 - 8 c + 36 c^2 + 40 c^3 - 128 c^4 - 32 c^5 + 64 c^6
In[1326]:= Ssexy[%]
Out[1326]= {{c -> 1/12 (1 - 3 Sqrt[5] + (2 7^(2/3))/(1/2 (1 + 3 I Sqrt[3]))^(1/3) + 2^(2/3) (7 (1 + 3 I Sqrt[3]))^(1/3))}, {c -> 1/12 (1 + 3 Sqrt[5] + (2 7^(2/3))/(1/2 (1 + 3 I Sqrt[3]))^(1/3) + 2^(2/3) (7 (1 + 3 I Sqrt[3]))^(1/3))}, {c -> -((7^(2/3) (1 + I Sqrt[3]))/(6 2^(2/3) (1 + 3 I Sqrt[3])^(1/3))) - 1/12 (1 - I Sqrt[3]) (7/2 (1 + 3 I Sqrt[3]))^(1/3) + 1/12 (1 - 3 Sqrt[5])}, {c -> -((7^(2/3) (1 - I Sqrt[3]))/( 6 2^(2/3) (1 + 3 I Sqrt[3])^(1/3))) - 1/12 (1 + I Sqrt[3]) (7/2 (1 + 3 I Sqrt[3]))^(1/3) +1/12 (1 - 3 Sqrt[5])}, {c -> -((7^(2/3) (1 + I Sqrt[3]))/(6 2^(2/3) (1 + 3 I Sqrt[3])^(1/3))) - 1/12 (1 - I Sqrt[3]) (7/2 (1 + 3 I Sqrt[3]))^(1/3) + 1/12 (1 + 3 Sqrt[5])}, {c -> -((7^(2/3) (1 - I Sqrt[3]))/(6 2^(2/3) (1 + 3 I Sqrt[3])^(1/3))) - 1/12 (1 + I Sqrt[3]) (7/2 (1 + 3 I Sqrt[3]))^(1/3) +1/12 (1 + 3 Sqrt[5])}}
In[1332]:= FindIntegerNullVector[ Append[#[[1, 2]] & /@ %1326, Cos[\[Pi]/5] - Cos[\[Pi]/7]]]
Out[1332]= {0, 0, 0, 0, 1, 0, -1}
So Cos[\[Pi]/5] - Cos[\[Pi]/7] is the penultimate solution. --rwg