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