[math-fun] all solvable sextics are easy!?
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
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
On Sat, Sep 17, 2011 at 9:47 AM, Tito Piezas <tpiezas@gmail.com> wrote:
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
YIKES, you're right! In[1335]:= Factor[x^6 + x^4 - 4 x^3 + 7 x^2 - 2 x - 5]
Out[1335]= -5 - 2 x + 7 x^2 - 4 x^3 + x^4 + x^6 In[1336]:= Ssexy[%] During evaluation of In[1336]:= Factor::nalg : "\[NoBreak]\[LeftSkeleton]713\[RightSkeleton]\ \[NoBreak] is not an explicit algebraic number. \!\(\*ButtonBox["\ \[RightSkeleton]", Appearance->{Automatic, None}, BaseStyle->"Link", ButtonData:>"paclet:ref/message/General/nalg", ButtonNote->"Factor::nalg"]\)" In[1337]:= Solve[m^3 - 4 m - 2 == 0] Out[1337]= {{m -> (9 + I Sqrt[111])^(1/3)/3^(2/3) + 4/(3 (9 + I Sqrt[111]))^( 1/3)}, {m -> -(((1 + I Sqrt[3]) (9 + I Sqrt[111])^(1/3))/( 2 3^(2/3))) - (2 (1 - I Sqrt[3]))/(3 (9 + I Sqrt[111]))^( 1/3)}, {m -> -(((1 - I Sqrt[3]) (9 + I Sqrt[111])^(1/3))/( 2 3^(2/3))) - (2 (1 + I Sqrt[3]))/(3 (9 + I Sqrt[111]))^(1/3)}} In[1338]:= Factor[%1335, Extension -> m /. %[[1]]] Out[1338]= -(1/ 27) (15 + (48 3^(1/3))/(9 + I Sqrt[111])^( 2/3) + (3 (9 + I Sqrt[111]))^( 2/3) + ((12 3^(2/3))/(9 + I Sqrt[111])^(1/3) + 3 (3 (9 + I Sqrt[111]))^(1/3)) x + 9 x^2) (-3 + ( 48 3^(1/3))/(9 + I Sqrt[111])^(2/3) - ( 8 3^(2/3))/(9 + I Sqrt[111])^(1/3) - 2 (3 (9 + I Sqrt[111]))^(1/3) + (3 (9 + I Sqrt[111]))^( 2/3) + (6 - (4 3^(2/3))/(9 + I Sqrt[111])^( 1/3) - (3 (9 + I Sqrt[111]))^(1/3)) x - 6 x^2 + ((4 3^(2/3))/(9 + I Sqrt[111])^( 1/3) + (3 (9 + I Sqrt[111]))^(1/3)) x^3 - 3 x^4) There is apparently not even a rational quintic resolvent. This probably explains the difficulty I'm having extending my method to your octic. Thanks! (Blush.) --rwg
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
Ok. Glad to be of help. By the way, I found the 16th deg resolvent, call this R_16, of that "natural" and solvable 17-deg eqn I gave a week or so ago. R_16 factors into 4 quartics over Sqrt[2(17+Sqrt[17])]. It factors further into quadratics using an extension involved in the 17th root of unity, but is quite messy. I believe R_16 can be expressed in terms of the 17th roots of unity, similar to that septic and the 29th roots of unity. Now if we can only find Peter Montgomery.... (I'm checking my email. I think we corresponded before.) Sincerely, - Tito On Sat, Sep 17, 2011 at 12:28 PM, Bill Gosper <billgosper@gmail.com> wrote:
On Sat, Sep 17, 2011 at 9:47 AM, Tito Piezas <tpiezas@gmail.com> wrote:
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
YIKES, you're right! In[1335]:= Factor[x^6 + x^4 - 4 x^3 + 7 x^2 - 2 x - 5]
Out[1335]= -5 - 2 x + 7 x^2 - 4 x^3 + x^4 + x^6
In[1336]:= Ssexy[%]
During evaluation of In[1336]:= Factor::nalg : "\[NoBreak]\[LeftSkeleton]713\[RightSkeleton]\ \[NoBreak] is not an explicit algebraic number. \!\(\*ButtonBox["\ \[RightSkeleton]", Appearance->{Automatic, None}, BaseStyle->"Link", ButtonData:>"paclet:ref/message/General/nalg", ButtonNote->"Factor::nalg"]\)"
In[1337]:= Solve[m^3 - 4 m - 2 == 0]
Out[1337]= {{m -> (9 + I Sqrt[111])^(1/3)/3^(2/3) + 4/(3 (9 + I Sqrt[111]))^( 1/3)}, {m -> -(((1 + I Sqrt[3]) (9 + I Sqrt[111])^(1/3))/( 2 3^(2/3))) - (2 (1 - I Sqrt[3]))/(3 (9 + I Sqrt[111]))^( 1/3)}, {m -> -(((1 - I Sqrt[3]) (9 + I Sqrt[111])^(1/3))/( 2 3^(2/3))) - (2 (1 + I Sqrt[3]))/(3 (9 + I Sqrt[111]))^(1/3)}}
In[1338]:= Factor[%1335, Extension -> m /. %[[1]]]
Out[1338]= -(1/ 27) (15 + (48 3^(1/3))/(9 + I Sqrt[111])^( 2/3) + (3 (9 + I Sqrt[111]))^( 2/3) + ((12 3^(2/3))/(9 + I Sqrt[111])^(1/3) + 3 (3 (9 + I Sqrt[111]))^(1/3)) x + 9 x^2) (-3 + ( 48 3^(1/3))/(9 + I Sqrt[111])^(2/3) - ( 8 3^(2/3))/(9 + I Sqrt[111])^(1/3) - 2 (3 (9 + I Sqrt[111]))^(1/3) + (3 (9 + I Sqrt[111]))^( 2/3) + (6 - (4 3^(2/3))/(9 + I Sqrt[111])^( 1/3) - (3 (9 + I Sqrt[111]))^(1/3)) x - 6 x^2 + ((4 3^(2/3))/(9 + I Sqrt[111])^( 1/3) + (3 (9 + I Sqrt[111]))^(1/3)) x^3 - 3 x^4)
There is apparently not even a rational quintic resolvent. This probably explains the difficulty I'm having extending my method to your octic.
Thanks! (Blush.) --rwg
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
I. Searched my inbox. No Montgomery. II. Anyway, going back to your sextic solver, I did some work on solvable eqns of deg n = 2p (for p an odd prime) before. They factor either: 1) only over a sqrt root extension, 2) only over a pth root extension, 3) or both. A general solver should be able to handle all three cases. III. For n = 2^p such that 2^p-1 is a prime (a Mersenne prime), the highest ext is over deg 2^p-1. Hence, we have quartics that factor over a cubic ext, octics over a septic, and so on. IV. And we haven't even started with n = 3p. There are nonics that factor ONLY over a 12th deg ext. Crazy, huh? I been meaning to write an introduction and summary for solving equations of degs 3 to 12, but never got around to it. :-( Sincerely, - Tito On Sat, Sep 17, 2011 at 12:58 PM, Tito Piezas <tpiezas@gmail.com> wrote:
Ok. Glad to be of help.
By the way, I found the 16th deg resolvent, call this R_16, of that "natural" and solvable 17-deg eqn I gave a week or so ago. R_16 factors into 4 quartics over Sqrt[2(17+Sqrt[17])]. It factors further into quadratics using an extension involved in the 17th root of unity, but is quite messy. I believe R_16 can be expressed in terms of the 17th roots of unity, similar to that septic and the 29th roots of unity. Now if we can only find Peter Montgomery.... (I'm checking my email. I think we corresponded before.)
Sincerely,
- Tito On Sat, Sep 17, 2011 at 12:28 PM, Bill Gosper <billgosper@gmail.com>wrote:
On Sat, Sep 17, 2011 at 9:47 AM, Tito Piezas <tpiezas@gmail.com> wrote:
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
YIKES, you're right! In[1335]:= Factor[x^6 + x^4 - 4 x^3 + 7 x^2 - 2 x - 5]
Out[1335]= -5 - 2 x + 7 x^2 - 4 x^3 + x^4 + x^6
In[1336]:= Ssexy[%]
During evaluation of In[1336]:= Factor::nalg : "\[NoBreak]\[LeftSkeleton]713\[RightSkeleton]\ \[NoBreak] is not an explicit algebraic number. \!\(\*ButtonBox["\ \[RightSkeleton]", Appearance->{Automatic, None}, BaseStyle->"Link", ButtonData:>"paclet:ref/message/General/nalg", ButtonNote->"Factor::nalg"]\)"
In[1337]:= Solve[m^3 - 4 m - 2 == 0]
Out[1337]= {{m -> (9 + I Sqrt[111])^(1/3)/3^(2/3) + 4/(3 (9 + I Sqrt[111]))^( 1/3)}, {m -> -(((1 + I Sqrt[3]) (9 + I Sqrt[111])^(1/3))/( 2 3^(2/3))) - (2 (1 - I Sqrt[3]))/(3 (9 + I Sqrt[111]))^( 1/3)}, {m -> -(((1 - I Sqrt[3]) (9 + I Sqrt[111])^(1/3))/( 2 3^(2/3))) - (2 (1 + I Sqrt[3]))/(3 (9 + I Sqrt[111]))^(1/3)}}
In[1338]:= Factor[%1335, Extension -> m /. %[[1]]]
Out[1338]= -(1/ 27) (15 + (48 3^(1/3))/(9 + I Sqrt[111])^( 2/3) + (3 (9 + I Sqrt[111]))^( 2/3) + ((12 3^(2/3))/(9 + I Sqrt[111])^(1/3) + 3 (3 (9 + I Sqrt[111]))^(1/3)) x + 9 x^2) (-3 + ( 48 3^(1/3))/(9 + I Sqrt[111])^(2/3) - ( 8 3^(2/3))/(9 + I Sqrt[111])^(1/3) - 2 (3 (9 + I Sqrt[111]))^(1/3) + (3 (9 + I Sqrt[111]))^( 2/3) + (6 - (4 3^(2/3))/(9 + I Sqrt[111])^( 1/3) - (3 (9 + I Sqrt[111]))^(1/3)) x - 6 x^2 + ((4 3^(2/3))/(9 + I Sqrt[111])^( 1/3) + (3 (9 + I Sqrt[111]))^(1/3)) x^3 - 3 x^4)
There is apparently not even a rational quintic resolvent. This probably explains the difficulty I'm having extending my method to your octic.
Thanks! (Blush.) --rwg
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
On Sat, Sep 17, 2011 at 11:28 AM, Bill Gosper <billgosper@gmail.com> wrote:
On Sat, Sep 17, 2011 at 9:47 AM, Tito Piezas <tpiezas@gmail.com> wrote:
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
YIKES, you're right!
It would be *really* nice to find a simple solver for this sqrt(cuberts) case of the sextic, which I think would finish the problem,
Foo, it's easy. Just numerically construct the cubics in the first case, and the quadratics in the second. So we have an even more ridiculously short solver: Ssexy[q_]:=Catch[Block[{rts=#[[1,2]]&/@NSolve[q==0,WorkingPrecision->239],foos=1,v=Variables[q][[1]],Q=Solve[0==q]},If[FreeQ[Q,Root],Q, Do[foos*=Select[v*Factor[q,Extension->RootApproximant[rts[[j]]+rts[[k]],3]],Exponent[#,v]==2&]; If[Exponent[foos,v]==6,Throw[ToRadicals[Solve[0==foos]]]],{j,5},{k,j+1,6}]; foos=Factor[q]; Do[If[foos=!=(foos=Factor[q,Extension->RootApproximant[rts[[i]]+rts[[j]]+rts[[k]],2]]),Throw[Solve[foos==0]]],{i,4},{j,i+1,5},{k,j+1,6}]]]] In[1336]:= Ssexy[x^6 + x^4 - 4 x^3 + 7 x^2 - 2 x - 5] now gives {{x -> (1/2)*(-(((1 - I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 + I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3) - Sqrt[4 - 3*(-(((1 - I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 + I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*(-(((1 - I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 + I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3) + Sqrt[4 - 3*(-(((1 - I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 + I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*(-(((1 + I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 - I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3) - Sqrt[4 - 3*(-(((1 + I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 - I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*(-(((1 + I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 - I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3) + Sqrt[4 - 3*(-(((1 + I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 - I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*((-9 + I*Sqrt[111])^(1/3)/3^(2/3) + 4/(3*(-9 + I*Sqrt[111]))^(1/3) - Sqrt[4 - 3*((-9 + I*Sqrt[111])^(1/3)/3^(2/3) + 4/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*((-9 + I*Sqrt[111])^(1/3)/3^(2/3) + 4/(3*(-9 + I*Sqrt[111]))^(1/3) + Sqrt[4 - 3*((-9 + I*Sqrt[111])^(1/3)/3^(2/3) + 4/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}} 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])}}
Simplify[Ssexy[-1 - 8 c + 36 c^2 + 40 c^3 - 128 c^4 - 32 c^5 + 64 c^6]
now gives
{{c->1/4 (1/3-Sqrt[5]-(I 7^(2/3) (-I+Sqrt[3]))/(3 (1/2 (1+3 I Sqrt[3]))^(1/3))+1/3 I (7/2 (1+3 I Sqrt[3]))^(1/3) (I+Sqrt[3]))}, {c->1/4 (1/3+Sqrt[5]-(I 7^(2/3) (-I+Sqrt[3]))/(3 (1/2 (1+3 I Sqrt[3]))^(1/3))+1/3 I (7/2 (1+3 I Sqrt[3]))^(1/3) (I+Sqrt[3]))}, {c->((1+3 I Sqrt[3])^(2/3) (1-3 Sqrt[5])+14^(1/3) (2 2^(1/3) (2-I Sqrt[3])+I (7+21 I Sqrt[3])^(1/3) (I+Sqrt[3])))/(12 (1+3 I Sqrt[3])^(2/3))}, {c->((1+3 I Sqrt[3])^(2/3) (1+3 Sqrt[5])+14^(1/3) (2 2^(1/3) (2-I Sqrt[3])+I (7+21 I Sqrt[3])^(1/3) (I+Sqrt[3])))/(12 (1+3 I Sqrt[3])^(2/3))}, {c->((1+3 I Sqrt[3])^(2/3) (1-3 Sqrt[5])+14^(1/3) (2^(1/3) (1+3 I Sqrt[3])+2 (7+21 I Sqrt[3])^(1/3)))/(12 (1+3 I Sqrt[3])^(2/3))}, {c->((1+3 I Sqrt[3])^(2/3) (1+3 Sqrt[5])+14^(1/3) (2^(1/3) (1+3 I Sqrt[3])+2 (7+21 I Sqrt[3])^(1/3)))/(12 (1+3 I Sqrt[3])^(2/3))}} It's pretty slow, but can be sped up a lot at some cost in brevity. OK Tito, stump this one. --rwg
On Mon, Sep 19, 2011 at 1:30 AM, Bill Gosper <billgosper@gmail.com> wrote:
On Sat, Sep 17, 2011 at 11:28 AM, Bill Gosper <billgosper@gmail.com>wrote:
On Sat, Sep 17, 2011 at 9:47 AM, Tito Piezas <tpiezas@gmail.com> wrote:
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
YIKES, you're right!
It would be *really* nice to find a simple solver for this sqrt(cuberts) case of the sextic, which I think would finish the problem,
Foo, it's easy. Just numerically construct the cubics in the first case, and the quadratics in the second. So we have an even more ridiculously short solver:
Ssexy[q_]:=Catch[Block[{rts=#[[1,2]]&/@NSolve[q==0,WorkingPrecision->239],foos=1,v=Variables[q][[1]],Q=Solve[0==q]},If[FreeQ[Q,Root],Q,
Do[foos*=Select[v*Factor[q,Extension->RootApproximant[rts[[j]]+rts[[k]],3]],Exponent[#,v]==2&];
If[Exponent[foos,v]==6,Throw[ToRadicals[Solve[0==foos]]]],{j,5},{k,j+1,6}]; foos=Factor[q];
Do[If[foos=!=(foos=Factor[q,Extension->RootApproximant[rts[[i]]+rts[[j]]+rts[[k]],2]]),Throw[Solve[foos==0]]],{i,4},{j,i+1,5},{k,j+1,6}]]]]
In[1336]:= Ssexy[x^6 + x^4 - 4 x^3 + 7 x^2 - 2 x - 5]
now gives {{x -> (1/2)*(-(((1 - I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 + I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3) - Sqrt[4 - 3*(-(((1 - I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 + I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*(-(((1 - I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 + I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3) + Sqrt[4 - 3*(-(((1 - I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 + I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*(-(((1 + I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 - I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3) - Sqrt[4 - 3*(-(((1 + I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 - I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*(-(((1 + I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 - I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3) + Sqrt[4 - 3*(-(((1 + I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 - I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*((-9 + I*Sqrt[111])^(1/3)/3^(2/3) + 4/(3*(-9 + I*Sqrt[111]))^(1/3) - Sqrt[4 - 3*((-9 + I*Sqrt[111])^(1/3)/3^(2/3) + 4/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*((-9 + I*Sqrt[111])^(1/3)/3^(2/3) + 4/(3*(-9 + I*Sqrt[111]))^(1/3) + Sqrt[4 - 3*((-9 + I*Sqrt[111])^(1/3)/3^(2/3) + 4/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}}
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])}}
Simplify[Ssexy[-1 - 8 c + 36 c^2 + 40 c^3 - 128 c^4 - 32 c^5 + 64 c^6]
now gives
{{c->1/4 (1/3-Sqrt[5]-(I 7^(2/3) (-I+Sqrt[3]))/(3 (1/2 (1+3 I Sqrt[3]))^(1/3))+1/3 I (7/2 (1+3 I Sqrt[3]))^(1/3) (I+Sqrt[3]))}, {c->1/4 (1/3+Sqrt[5]-(I 7^(2/3) (-I+Sqrt[3]))/(3 (1/2 (1+3 I Sqrt[3]))^(1/3))+1/3 I (7/2 (1+3 I Sqrt[3]))^(1/3) (I+Sqrt[3]))}, {c->((1+3 I Sqrt[3])^(2/3) (1-3 Sqrt[5])+14^(1/3) (2 2^(1/3) (2-I Sqrt[3])+I (7+21 I Sqrt[3])^(1/3) (I+Sqrt[3])))/(12 (1+3 I Sqrt[3])^(2/3))}, {c->((1+3 I Sqrt[3])^(2/3) (1+3 Sqrt[5])+14^(1/3) (2 2^(1/3) (2-I Sqrt[3])+I (7+21 I Sqrt[3])^(1/3) (I+Sqrt[3])))/(12 (1+3 I Sqrt[3])^(2/3))}, {c->((1+3 I Sqrt[3])^(2/3) (1-3 Sqrt[5])+14^(1/3) (2^(1/3) (1+3 I Sqrt[3])+2 (7+21 I Sqrt[3])^(1/3)))/(12 (1+3 I Sqrt[3])^(2/3))}, {c->((1+3 I Sqrt[3])^(2/3) (1+3 Sqrt[5])+14^(1/3) (2^(1/3) (1+3 I Sqrt[3])+2 (7+21 I Sqrt[3])^(1/3)))/(12 (1+3 I Sqrt[3])^(2/3))}}
It's pretty slow, but can be sped up a lot at some cost in brevity. OK Tito, stump this one.
Oh cr*p, In[1563]:= Expand[(x^3 - Sqrt[2]*x - 1)*(x^3 + Sqrt[2]*x - 1)] Out[1563]= 1 - 2 x^2 - 2 x^3 + x^6 Fails for a stupid reason. I need to sleep on this.
--rwg
Dear Bill, In addition to that problematic sextic you found, can you also test the solver with a "promiscuous" sextic? It can be solved in 4 ways. Define, F(x) = 1 - 5 x + 9 x^3 - 2 x^4 - 3 x^5 + x^6 = 0 then F(x) decomposes as quadratics in 3 ways, 1. F(x) = Resultant[x^2 + a x + (a^2 + a - 3), a^3 + 3a^2 - a - 5, a] 2. F(x) = Resultant[x^2 + b x + (b^2 + 2b - 2), b^3 + 3b^2 - b - 1, b] 3. F(x) = Resultant[x^2 - x + c, c^3 + 5c^2 + 5c - 1, c] plus it factors into cubics over the extension, Sqrt[37]], 4. Factor[F(x), Extension -> Sqrt[37]] I'm curious which of the four the "ssexy" program will find. Sincerely, - Tito On Mon, Sep 19, 2011 at 2:53 AM, Bill Gosper <billgosper@gmail.com> wrote:
On Mon, Sep 19, 2011 at 1:30 AM, Bill Gosper <billgosper@gmail.com>wrote:
On Sat, Sep 17, 2011 at 11:28 AM, Bill Gosper <billgosper@gmail.com>wrote:
On Sat, Sep 17, 2011 at 9:47 AM, Tito Piezas <tpiezas@gmail.com> wrote:
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
YIKES, you're right!
It would be *really* nice to find a simple solver for this sqrt(cuberts) case of the sextic, which I think would finish the problem,
Foo, it's easy. Just numerically construct the cubics in the first case, and the quadratics in the second. So we have an even more ridiculously short solver:
Ssexy[q_]:=Catch[Block[{rts=#[[1,2]]&/@NSolve[q==0,WorkingPrecision->239],foos=1,v=Variables[q][[1]],Q=Solve[0==q]},If[FreeQ[Q,Root],Q,
Do[foos*=Select[v*Factor[q,Extension->RootApproximant[rts[[j]]+rts[[k]],3]],Exponent[#,v]==2&];
If[Exponent[foos,v]==6,Throw[ToRadicals[Solve[0==foos]]]],{j,5},{k,j+1,6}]; foos=Factor[q];
Do[If[foos=!=(foos=Factor[q,Extension->RootApproximant[rts[[i]]+rts[[j]]+rts[[k]],2]]),Throw[Solve[foos==0]]],{i,4},{j,i+1,5},{k,j+1,6}]]]]
In[1336]:= Ssexy[x^6 + x^4 - 4 x^3 + 7 x^2 - 2 x - 5]
now gives {{x -> (1/2)*(-(((1 - I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 + I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3) - Sqrt[4 - 3*(-(((1 - I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 + I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*(-(((1 - I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 + I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3) + Sqrt[4 - 3*(-(((1 - I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 + I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*(-(((1 + I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 - I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3) - Sqrt[4 - 3*(-(((1 + I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 - I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*(-(((1 + I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 - I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3) + Sqrt[4 - 3*(-(((1 + I*Sqrt[3])*(-9 + I*Sqrt[111])^(1/3))/(2*3^(2/3))) - (2*(1 - I*Sqrt[3]))/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*((-9 + I*Sqrt[111])^(1/3)/3^(2/3) + 4/(3*(-9 + I*Sqrt[111]))^(1/3) - Sqrt[4 - 3*((-9 + I*Sqrt[111])^(1/3)/3^(2/3) + 4/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}, {x -> (1/2)*((-9 + I*Sqrt[111])^(1/3)/3^(2/3) + 4/(3*(-9 + I*Sqrt[111]))^(1/3) + Sqrt[4 - 3*((-9 + I*Sqrt[111])^(1/3)/3^(2/3) + 4/(3*(-9 + I*Sqrt[111]))^(1/3))^2])}}
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])}}
Simplify[Ssexy[-1 - 8 c + 36 c^2 + 40 c^3 - 128 c^4 - 32 c^5 + 64 c^6]
now gives
{{c->1/4 (1/3-Sqrt[5]-(I 7^(2/3) (-I+Sqrt[3]))/(3 (1/2 (1+3 I Sqrt[3]))^(1/3))+1/3 I (7/2 (1+3 I Sqrt[3]))^(1/3) (I+Sqrt[3]))}, {c->1/4 (1/3+Sqrt[5]-(I 7^(2/3) (-I+Sqrt[3]))/(3 (1/2 (1+3 I Sqrt[3]))^(1/3))+1/3 I (7/2 (1+3 I Sqrt[3]))^(1/3) (I+Sqrt[3]))}, {c->((1+3 I Sqrt[3])^(2/3) (1-3 Sqrt[5])+14^(1/3) (2 2^(1/3) (2-I Sqrt[3])+I (7+21 I Sqrt[3])^(1/3) (I+Sqrt[3])))/(12 (1+3 I Sqrt[3])^(2/3))}, {c->((1+3 I Sqrt[3])^(2/3) (1+3 Sqrt[5])+14^(1/3) (2 2^(1/3) (2-I Sqrt[3])+I (7+21 I Sqrt[3])^(1/3) (I+Sqrt[3])))/(12 (1+3 I Sqrt[3])^(2/3))}, {c->((1+3 I Sqrt[3])^(2/3) (1-3 Sqrt[5])+14^(1/3) (2^(1/3) (1+3 I Sqrt[3])+2 (7+21 I Sqrt[3])^(1/3)))/(12 (1+3 I Sqrt[3])^(2/3))}, {c->((1+3 I Sqrt[3])^(2/3) (1+3 Sqrt[5])+14^(1/3) (2^(1/3) (1+3 I Sqrt[3])+2 (7+21 I Sqrt[3])^(1/3)))/(12 (1+3 I Sqrt[3])^(2/3))}}
It's pretty slow, but can be sped up a lot at some cost in brevity. OK Tito, stump this one.
Oh cr*p, In[1563]:= Expand[(x^3 - Sqrt[2]*x - 1)*(x^3 + Sqrt[2]*x - 1)]
Out[1563]= 1 - 2 x^2 - 2 x^3 + x^6
Fails for a stupid reason. I need to sleep on this.
--rwg
RootAp1[z_, n_] := Block[{r = RootApproximant[z, n]}, If[Log[Abs[(MinimalPolynomial[r] /. Plus -> Times)@1]] > 9*Precision[z], 1, r]] Ssexy[q_]:=Catch[Block[{rts=#[[1,2]]&/@NSolve[q==0,WorkingPrecision->69],foos=1,v=Variables[q][[1]],Q=Solve[0==q]},If[FreeQ[Q,Root],Q, Do[foos*=Select[v*Factor[q,Extension->{RootAp1[rts[[j]]+rts[[k]],3],RootAp1[rts[[j]]*rts[[k]],3]}],Exponent[#,v]==2&];If[Exponent[foos,v]==6,Throw[ToRadicals[Solve[0==foos]]]],{j,5},{k,j+1,6}];foos=Factor[q]; Do[If[foos=!=(foos=Factor[q,Extension->RootAp1[#,2]&/@CoefficientList[(#-rts[[i]])*(#-rts[[j]])*(#-rts[[k]]),#]]),Throw[Solve[foos==0]]],{i,4},{j,i+1,5},{k,j+1,6}]];Q]] This is seriously untested, longer, faster on most cases, but several minutes on Ssexy[2925951033851274156588135512485165232256823853056 - 2697817290737324449800236848640264992467435520 #1 + 9932351343021963689693473396732415411860992 #1^2 - 1881654619801628210127689611068977299937 #1^3 + 11450425009897563891465337536606118710 #1^4 + 3847649781964086608961673413540069 #1^5 + 378818692265664781682717625943 #1^6] On Mon, Sep 19, 2011 at 5:41 AM, Tito Piezas <tpiezas@gmail.com> wrote:
Dear Bill,
In addition to that problematic sextic you found, can you also test the solver with a "promiscuous" sextic? It can be solved in 4 ways. Define,
F(x) = 1 - 5 x + 9 x^3 - 2 x^4 - 3 x^5 + x^6 = 0
then F(x) decomposes as quadratics in 3 ways,
1. F(x) = Resultant[x^2 + a x + (a^2 + a - 3), a^3 + 3a^2 - a - 5, a] 2. F(x) = Resultant[x^2 + b x + (b^2 + 2b - 2), b^3 + 3b^2 - b - 1, b] 3. F(x) = Resultant[x^2 - x + c, c^3 + 5c^2 + 5c - 1, c]
plus it factors into cubics over the extension, Sqrt[37]],
4. Factor[F(x), Extension -> Sqrt[37]]
I'm curious which of the four the "ssexy" program will find.
Sincerely,
- Tito
None! As written, Ssexy first tries Mma Solve, which immediately scores with In[10]:= Decompose[1 - 5 x + 9 x^3 - 2 x^4 - 3 x^5 + x^6, x]
Out[10]= {1 + 5 x - 5 x^2 + x^3, -x + x^2} which I guess is your case 3. Experimentally disabling the call to Solve, it scored nine times looking for three quadratics with cubic extensions, and then found the sqrt 37 split very promptly, which gave massively simpler expressions. Maybe I should switch the order of checking. Also, if the three quadratics case always hits several (9?) times or never, it might be possible to give up after 1/severalth of the search. --rwg [...]
On Tue, Sep 20, 2011 at 3:34 AM, Bill Gosper <billgosper@gmail.com> wrote:
RootAp1[z_, n_] := Block[{r = RootApproximant[z, n]}, If[Log[Abs[(MinimalPolynomial[r] /. Plus -> Times)@1]] > 9*Precision[z], 1, r]]
[This replaces previous version, which had one of those delicious bugs that disappears when you insert Print statements. Thank you for not playing with it and sending me hate mail.-]
Ssexy[q_]:=Catch[Block[{rts,foos=1,v=Variables[q][[1]],Q},rts=#[[1,2]]&/@NSolve[q==0,WorkingPrecision->Ceiling[Log[Abs[Discriminant[q,v]]]]];If[FreeQ[Q=Solve[0==q],Root],Q, Do[foos*=Select[v*Factor[q,Extension->{RootAp1[rts[[j]]+rts[[k]],3],RootAp1[rts[[j]]*rts[[k]],3]}],Exponent[#,v]==2&];If[Exponent[foos,v]==6,Throw[ToRadicals[Solve[0==foos]]]],{j,5},{k,j+1,6}];foos=Factor[q]; Do[If[foos=!=(foos=Factor[q,Extension->(RootAp1[#,2]&/@CoefficientList[(#-rts[[i]])*(#-rts[[j]])*(#-rts[[k]]),#])]),Throw[Solve[foos==0]]],{i,4},{j,i+1,5},{k,j+1,6}]];Q]]
This is seriously untested, longer, faster on most cases, but several minutes on Ssexy[2925951033851274156588135512485165232256823853056 - 2697817290737324449800236848640264992467435520 #1 + 9932351343021963689693473396732415411860992 #1^2 - 1881654619801628210127689611068977299937 #1^3 + 11450425009897563891465337536606118710 #1^4 + 3847649781964086608961673413540069 #1^5 + 378818692265664781682717625943 #1^6]
The slowness was due to WorkingPrecision failing to track the problem size. Now takes .5 sec. That's right, decupling the precision sped it up 200 fold! But now In[51]:= Timing[Ssexy[1-2 x^2-2 x^3+x^6]]
Out[51]= {3.64753,{{x->1/3 (27/2-3/2 Sqrt[3 (27-8 Sqrt[2])])^(1/3)+(1/2 (9+Sqrt[3 (27-8 Sqrt[2])]))^(1/3)/3^(2/3)},{x->-(1/6) (1+I Sqrt[3]) (27/2-3/2 Sqrt[3 (27-8 Sqrt[2])])^(1/3)-((1-I Sqrt[3]) (1/2 (9+Sqrt[3 (27-8 Sqrt[2])]))^(1/3))/(2 3^(2/3))},{x->-(1/6) (1-I Sqrt[3]) (27/2-3/2 Sqrt[3 (27-8 Sqrt[2])])^(1/3)-((1+I Sqrt[3]) (1/2 (9+Sqrt[3 (27-8 Sqrt[2])]))^(1/3))/(2 3^(2/3))},{x->(1/2 (9+Sqrt[3 (27+8 Sqrt[2])]))^(1/3)/3^(2/3)-2^(5/6)/(3 (9+Sqrt[3 (27+8 Sqrt[2])]))^(1/3)},{x->-(((1+I Sqrt[3]) (1/2 (9+Sqrt[3 (27+8 Sqrt[2])]))^(1/3))/(2 3^(2/3)))+(1-I Sqrt[3])/(2^(1/6) (3 (9+Sqrt[3 (27+8 Sqrt[2])]))^(1/3))},{x->-(((1-I Sqrt[3]) (1/2 (9+Sqrt[3 (27+8 Sqrt[2])]))^(1/3))/(2 3^(2/3)))+(1+I Sqrt[3])/(2^(1/6) (3 (9+Sqrt[3 (27+8 Sqrt[2])]))^(1/3))}}} takes seven times longer than the hairy case! (Apparently the hairy case is at least somewhat "promiscuous".) Interlacing the 6choose2 quadratic(cubic) tests with the 6choose3 cubic(quadratic) tests ought speed up the unlucky cases more than slowing down the lucky ones. Anyway, play with this new Ssexy if you're that sort of person. It would be cool if a function this short solves all solvable (numerically explicit) sextics. --rwg
On Mon, Sep 19, 2011 at 5:41 AM, Tito Piezas <tpiezas@gmail.com> wrote:
Dear Bill,
In addition to that problematic sextic you found, can you also test the solver with a "promiscuous" sextic? It can be solved in 4 ways. Define,
F(x) = 1 - 5 x + 9 x^3 - 2 x^4 - 3 x^5 + x^6 = 0
then F(x) decomposes as quadratics in 3 ways,
1. F(x) = Resultant[x^2 + a x + (a^2 + a - 3), a^3 + 3a^2 - a - 5, a] 2. F(x) = Resultant[x^2 + b x + (b^2 + 2b - 2), b^3 + 3b^2 - b - 1, b] 3. F(x) = Resultant[x^2 - x + c, c^3 + 5c^2 + 5c - 1, c]
plus it factors into cubics over the extension, Sqrt[37]],
4. Factor[F(x), Extension -> Sqrt[37]]
I'm curious which of the four the "ssexy" program will find.
Sincerely,
- Tito
None! As written, Ssexy first tries Mma Solve, which immediately scores with In[10]:= Decompose[1 - 5 x + 9 x^3 - 2 x^4 - 3 x^5 + x^6, x]
Out[10]= {1 + 5 x - 5 x^2 + x^3, -x + x^2}
which I guess is your case 3. Experimentally disabling the call to Solve, it scored nine times looking for three quadratics with cubic extensions, and then found the sqrt 37 split very promptly, which gave massively simpler expressions. Maybe I should switch the order of checking. Also, if the three quadratics case always hits several (9?) times or never, it might be possible to give up after 1/severalth of the search. --rwg [...]
Bill Gosper <billgosper@gmail.com> wrote:
On Tue, Sep 20, 2011 at 3:34 AM, Bill Gosper <billgosper@gmail.com> wrote:
RootAp1[z_, n_] := Block[{r = RootApproximant[z, n]}, If[Log[Abs[(MinimalPolynomial[r] /. Plus -> Times)@1]] > 9*Precision[z], 1, r]]
[This replaces previous version, which had one of those delicious bugs that disappears when you insert Print statements. Thank you for not playing with it and sending me hate mail.-]
Ssexy[q_]:=Catch[Block[{rts,foos=1,v=Variables[q][[1]],Q},rts=#[[1,2]]&/@NSolve[q==0,WorkingPrecision->Ceiling[Log[Abs[Discriminant[q,v]]]]];If[FreeQ[Q=Solve[0==q],Root],Q, Do[foos*=Select[v*Factor[q,Extension->{RootAp1[rts[[j]]+rts[[k]],3],RootAp1[rts[[j]]*rts[[k]],3]}],Exponent[#,v]==2&];If[Exponent[foos,v]==6,Throw[ToRadicals[Solve[0==foos]]]],{j,5},{k,j+1,6}];foos=Factor[q]; Do[If[foos=!=(foos=Factor[q,Extension->(RootAp1[#,2]&/@CoefficientList[(#-rts[[i]])*(#-rts[[j]])*(#-rts[[k]]),#])]),Throw[Solve[foos==0]]],{i,4},{j,i+1,5},{k,j+1,6}]];Q]]
This is seriously untested, longer, faster on most cases, but several minutes on Ssexy[2925951033851274156588135512485165232256823853056 - 2697817290737324449800236848640264992467435520 #1 + 9932351343021963689693473396732415411860992 #1^2 - 1881654619801628210127689611068977299937 #1^3 + 11450425009897563891465337536606118710 #1^4 + 3847649781964086608961673413540069 #1^5 + 378818692265664781682717625943 #1^6]
The slowness was due to WorkingPrecision failing to track the problem size. Now takes .5 sec. That's right, decupling the precision sped it up 200 fold! But now In[51]:= Timing[Ssexy[1-2 x^2-2 x^3+x^6]]
Out[51]= {3.64753,{{x->1/3 (27/2-3/2 Sqrt[3 (27-8 Sqrt[2])])^(1/3)+(1/2 (9+Sqrt[3 (27-8 Sqrt[2])]))^(1/3)/3^(2/3)},{x->-(1/6) (1+I Sqrt[3]) (27/2-3/2 Sqrt[3 (27-8 Sqrt[2])])^(1/3)-((1-I Sqrt[3]) (1/2 (9+Sqrt[3 (27-8 Sqrt[2])]))^(1/3))/(2 3^(2/3))},{x->-(1/6) (1-I Sqrt[3]) (27/2-3/2 Sqrt[3 (27-8 Sqrt[2])])^(1/3)-((1+I Sqrt[3]) (1/2 (9+Sqrt[3 (27-8 Sqrt[2])]))^(1/3))/(2 3^(2/3))},{x->(1/2 (9+Sqrt[3 (27+8 Sqrt[2])]))^(1/3)/3^(2/3)-2^(5/6)/(3 (9+Sqrt[3 (27+8 Sqrt[2])]))^(1/3)},{x->-(((1+I Sqrt[3]) (1/2 (9+Sqrt[3 (27+8 Sqrt[2])]))^(1/3))/(2 3^(2/3)))+(1-I Sqrt[3])/(2^(1/6) (3 (9+Sqrt[3 (27+8 Sqrt[2])]))^(1/3))},{x->-(((1-I Sqrt[3]) (1/2 (9+Sqrt[3 (27+8 Sqrt[2])]))^(1/3))/(2 3^(2/3)))+(1+I Sqrt[3])/(2^(1/6) (3 (9+Sqrt[3 (27+8 Sqrt[2])]))^(1/3))}}}
takes seven times longer than the hairy case! (Apparently the hairy case is at least somewhat "promiscuous".) Interlacing the 6choose2 quadratic(cubic) tests with the 6choose3 cubic(quadratic) tests ought speed up the unlucky cases more than slowing down the lucky ones.
Anyway, play with this new Ssexy if you're that sort of person. It would be cool if a function this short solves all solvable (numerically explicit) sextics. --rwg
On Mon, Sep 19, 2011 at 5:41 AM, Tito Piezas <tpiezas@gmail.com> wrote:
Dear Bill,
In addition to that problematic sextic you found, can you also test the solver with a "promiscuous" sextic? It can be solved in 4 ways. Define,
F(x) = 1 - 5 x + 9 x^3 - 2 x^4 - 3 x^5 + x^6 = 0
then F(x) decomposes as quadratics in 3 ways,
1. F(x) = Resultant[x^2 + a x + (a^2 + a - 3), a^3 + 3a^2 - a - 5, a] 2. F(x) = Resultant[x^2 + b x + (b^2 + 2b - 2), b^3 + 3b^2 - b - 1, b] 3. F(x) = Resultant[x^2 - x + c, c^3 + 5c^2 + 5c - 1, c]
plus it factors into cubics over the extension, Sqrt[37]],
4. Factor[F(x), Extension -> Sqrt[37]]
I'm curious which of the four the "ssexy" program will find.
Sincerely,
- Tito
None! As written, Ssexy first tries Mma Solve, which immediately scores with In[10]:= Decompose[1 - 5 x + 9 x^3 - 2 x^4 - 3 x^5 + x^6, x]
Out[10]= {1 + 5 x - 5 x^2 + x^3, -x + x^2}
which I guess is your case 3. Experimentally disabling the call to Solve, it scored nine times looking for three quadratics with cubic extensions, and then found the sqrt 37 split very promptly, which gave massively simpler expressions. Maybe I should switch the order of checking. Also, if the three quadratics case always hits several (9?) times or never, it might be possible to give up after 1/severalth of the search. --rwg [...]
Bill, I noticed the constant term beginning 29259... is actually equal to 2^21*29^21*43^7 and wondered why these three primes play such a role in all these coefficients.
That big sextic is "the" resolvent of the septic 8903 + 47647 v + 39672 v^2 + 7192 v^3 - 522 v^4 - 174 v^5 + v^7 that Tito used to solve x^8-x^7+29*x^2+29, which at least "explains" the 29s. --rwg On Tue, Sep 20, 2011 at 3:06 PM, <jdb@math.arizona.edu> wrote:
Bill Gosper <billgosper@gmail.com> wrote:
On Tue, Sep 20, 2011 at 3:34 AM, Bill Gosper <billgosper@gmail.com> wrote:
RootAp1[z_, n_] := Block[{r = RootApproximant[z, n]}, If[Log[Abs[(MinimalPolynomial[r] /. Plus -> Times)@1]] > 9*Precision[z], 1, r]]
[This replaces previous version, which had one of those delicious bugs that disappears when you insert Print statements. Thank you for not playing with it and sending me hate mail.-]
Ssexy[q_]:=Catch[Block[{rts,foos=1,v=Variables[q][[1]],Q},rts=#[[1,2]]&/@NSolve[q==0,WorkingPrecision->Ceiling[Log[Abs[Discriminant[q,v]]]]];If[FreeQ[Q=Solve[0==q],Root],Q,
Do[foos*=Select[v*Factor[q,Extension->{RootAp1[rts[[j]]+rts[[k]],3],RootAp1[rts[[j]]*rts[[k]],3]}],Exponent[#,v]==2&];If[Exponent[foos,v]==6,Throw[ToRadicals[Solve[0==foos]]]],{j,5},{k,j+1,6}];foos=Factor[q];
Do[If[foos=!=(foos=Factor[q,Extension->(RootAp1[#,2]&/@CoefficientList[(#-rts[[i]])*(#-rts[[j]])*(#-rts[[k]]),#])]),Throw[Solve[foos==0]]],{i,4},{j,i+1,5},{k,j+1,6}]];Q]]
This is seriously untested, longer, faster on most cases, but several minutes on Ssexy[2925951033851274156588135512485165232256823853056 - 2697817290737324449800236848640264992467435520 #1 + 9932351343021963689693473396732415411860992 #1^2 - 1881654619801628210127689611068977299937 #1^3 + 11450425009897563891465337536606118710 #1^4 + 3847649781964086608961673413540069 #1^5 + 378818692265664781682717625943 #1^6]
JDB>
Bill, I noticed the constant term beginning 29259... is actually equal to 2^21*29^21*43^7 and wondered why these three primes play such a role in all these coefficients.
participants (3)
-
Bill Gosper -
jdb＠math.arizona.edu -
Tito Piezas