Quintic Equation

Author

Eric W. Weisstein
February 17, 2005

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Algebra/QuinticEquation.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/QuinticEquation.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Additional Authors

GaloisGroup code by
Victor Adamchik and
Michael Trott

Code

This can probably be done more efficiently by permuting coefficients and RootReducing the result

GaloisGroup::"usage"="GaloisGroup[quintic] computes the Galois group of the given quintic.";
GaloisGroup::"red"="The quintic is reducible.";

GaloisGroup[expr_]:=Module[{var},var=Union[Select[Level[expr,{-1}],Head[#1]===Symbol&]];If[Length[var]==1&&Exponent[expr,var[[1]]]==5,galois[expr,var[[1]]],Return[$Failed]]]
galois[expr_,var_]:=If[Exponent[expr,var]==5&&And@@(#1===Integer||#1===Rational&)/@Head/@CoefficientList[expr,var],Module[{factor},If[Head[factor=Factor[expr]]===Times&&Length[Complement[(Exponent[#1,var]&)/@List@@factor,{0,5}]]>0,Message[GaloisGroup::"red"];Select[(Irreducible[#1,var,Exponent[#1,var]]&)/@List@@factor,#1=!=NULL&],If[Head[factor=Factor[expr]]===Power,Message[GaloisGroup::"red"];Table[SymmetricGroup[1],{i,Exponent[expr,var]}],{Irreducible[expr,var,Exponent[expr,var]]}]]],$Failed]
Irreducible[expr_,var_,n_]:=Module[{isfactorable,introot,roots},{isfactorable,introot,roots}=Resolvent[(expr/(Coefficient[expr,var,n])),var];If[isfactorable,SolvableGroup[(Sqrt[Discriminant[expr,var,5]]),expr,var,introot,roots],If[IntegerQ[(Sqrt[Discriminant[expr,var,5]])],AlternatingGroup[n],SymmetricGroup[n]],$Failed]]/;n==5
Irreducible[__]:=NULL
Discriminant[poly_,var_,n_]:=((Resultant[poly,(∂_var)poly,var] (((-1))^((1/2) n (n-1))))/(Coefficient[poly,var,n]))
Resolvent[expr_,var_]:=Module[{roots,integralroot,temp},roots=List@@NRoots[expr==0,var,20]/._==p_:>p;temp=Stabilizer/@Representatives[roots];integralroot=Position[Chop/@(Round[#1]-#1&)/@temp,_Integer];If[Length[integralroot]≥1,{True,Round[temp[[integralroot[[1,1]]]]],roots},{False,$Failed,$Failed}]]
Representatives[{x1_,x2_,x3_,x4_,x5_}]:={{x1,x2,x3,x4,x5},{x2,x1,x3,x4,x5},{x3,x2,x1,x4,x5},{x4,x2,x3,x1,x5},{x5,x2,x3,x4,x1},{x1,x5,x3,x4,x2}}
Stabilizer[{x1_,x2_,x3_,x4_,x5_}]:=(x1^2) (x2 x5+x3 x4)+(x2^2) (x1 x3+x4 x5)+(x3^2) (x1 x5+x2 x4)+(x4^2) (x1 x2+x3 x5)+(x5^2) (x1 x4+x2 x3)
SolvableGroup[disc_,r__]:=If[!IntegerQ[disc],MetacyclicGroup[20],DihedralOrCyclic[r]]
DihedralOrCyclic[expr_,var_,introot_,roots_List]:=Module[{disc,p},Fnew[x1_,x2_,x3_,x4_,x5_]:=x1 (x2^2)+x2 (x3^2)+x3 (x4^2)+x4 (x5^2)+x5 (x1^2);NewResolvent[{x1_,x2_,x3_,x4_,x5_}]:=(var-Fnew[x1,x2,x3,x4,x5]) (var-Fnew[x2,x1,x5,x4,x3]);p=Position[Round/@Stabilizer/@Representatives[roots],introot][[1,1]];disc=Discriminant[NewResolvent[Representatives[roots][[p]]],var,2];disc=disc/.{e_Real:>Round[e],e_Complex:>Round[e]};If[disc==0,Return[SingularCase[expr,var,roots,5]]];If[IntegerQ[(Sqrt[disc])],CyclicGroup[5],DihedralGroup[10]]]
SingularCase[expr_,var_,roots_,n_]:=Module[{newp,newroots,stabs,realr,p,disc},newp=Tschirnhaus[expr,var,n];newroots=newp/.({var->#1}&)/@roots;stabs=Stabilizer/@N[Representatives[newroots],32];realr=Select[Round[stabs],IntegerQ];If[Length[realr]==0,Return[$Failed]];p=Position[Round[stabs],First[realr]][[1,1]];disc=Discriminant[NewResolvent[Representatives[newroots][[p]]],var,2];If[IntegerQ[(Sqrt[disc])],CyclicGroup[5],DihedralGroup[10]]]
Tschirnhaus[expr_,var_,n_]:=Module[{z,randp,newp},randp=(∑_(k=0)^(n-2))Random[Integer,{-1,0}] (z^(n-k-2));newp=Resultant[expr/.var->z,var-randp,z];If[FreeQ[PolynomialGCD[newp,(∂_var)newp],var],newp,Tschirnhaus[expr,var,n]]]

Series Reversion

s=InverseSeries[Series[(t^5)-t-ρ,{t,0,20}],y]

Normal[s]/.y->0

Table[-(((ρ^(4 k+1)) Binomial[5 k,k])/(4 k+1)),{k,0,10}]

Sum[-(((ρ^(4 k+1)) Binomial[5 k,k])/(4 k+1)),{k,0,∞}]

Galois Group

Examples

{#,GaloisGroup[#]}&/@{(x^5)+20 x+32,(x^5)+(x^4)-4 (x^3)-3 (x^2)+3 x+1,(x^5)+(x^4)-12 (x^3)-21 (x^2)+x+5,(x^5)+2,(x^5)+20 x+16,(x^5)-5 x+12,(x^5)+15 x+12,(x^5)+5 (x^3)+10 (x^2)+5 x+4,(x^5)-33826005 x-4140303012}//TableForm//TraditionalForm

<<Graphics`Legend`
<<Graphics`Colors`

GaloisPlot[k_,dx_:.07]:=Module[{x,n},
ShowLegend[
Graphics[Table[{GaloisGroup[x^5+p x+q],Rectangle[{p,q}+dx-.5,{p,q}+(1-dx)-.5]},{p,-k,k},{q,-k,k}] /.{
{}:>Yellow,
{SymmetricGroup[1],SymmetricGroup[1],SymmetricGroup[1],SymmetricGroup[1],SymmetricGroup[1]}:>Black,
{SymmetricGroup[n_]}:>Red,
{MetacyclicGroup[n_]}:>Blue,
{DihedralGroup[n_]}:>Green,
{AlternatingGroup[n_]}:>Purple,
{CyclicGroup[n_]}:>LightBlue
},AspectRatio->Automatic,Frame->True,FrameLabel->TraditionalForm/@{p,q,"group of \!\(TraditionalForm\`\*SuperscriptBox[\(x\), \(5\)] + p\\\\ x + q\)",""}],
{{
{Yellow,TraditionalForm["R"]},
{Red,TraditionalForm["(Subscript[S, n])"]},
{Blue,TraditionalForm["(Subscript[M, n])"]},
{Green,TraditionalForm["(Subscript[D, n])"]},
{Purple,TraditionalForm["(Subscript[A, n])"]},
{LightBlue,TraditionalForm["(Subscript[C, n])"]}
},LegendPosition->{1.5,-.5},LegendTextSpace->2,LegendSize->{.5,1.}}]
]

Off[GaloisGroup::"red"]

GaloisPlot[2]//Timing

GaloisPlot[5]//Timing

GaloisPlot[15]//Timing

GaloisPlot[20]//Timing

GaloisPlot[25]//Timing

GaloisPlot[30]//Timing

GaloisPlot[50]//Timing