可解な5次方程式の厳密解  2025 年3月  by  (HyperlinkURL["mixedmoss", https://mixedmoss.com])

可解で既約な5次方程式の厳密解を求めます．実行は最大30秒程かかり，出力も長いです．
初期値は「 (x^5)+2=0 」になっています．
可解で既約な5次方程式の例は,次をご覧下さい．((但しx)^4)の係数が0 の場合しか実行できません．
　(HyperlinkURL["https://mixedmoss.com/mathematica/Galois/solvableEquations.txt", https://mixedmoss.com/mathematica/Galois/solvableEquations.txt]) 
可解な5次方程式やこのプログラムについての詳しい情報は，次をご覧下さい.
    (HyperlinkURL["https://mixedmoss.com/mathematica/Galois/", https://mixedmoss.com/mathematica/Galois/])

Manipulate[If[eval&&(MemberQ[solvables,{a,b,c,d}]||MemberQ[solvables,{a,-b,c,-d}]),
solveQuintic[x^5+ a x^3 +b x^2+ c x +d],Text["「実行」モードにして，可解で既約な5次方程式 「(x^5)+(ax^3)+(bx^2)+cx+d=0」 の係数を選んで下さい．\n可解で既約な方程式を選ぶと，右端のタグが赤くなり計算します．時間は最大30秒かかります. "]],Text[Style[TraditionalForm[f:x^5+Dynamic[a] x^3+Dynamic[b] x^2 +Dynamic[c] x +Dynamic[d]],Bold,Italic,Larger]],
Delimiter,{{eval,False,"実行"},{False,True}},{{a,0},Range[-15,15]},{{b,0},Range[-15,15]},{{c,0},Range[-15,15]},{{d,2},{Join[ Range[-15,-1],{"  "},Range[1,15]]}//Flatten},
ControlType->{SetterBar,RadioButton,SetterBar},
Initialization:>(ClearAll["`*"];
(*#################################################################################################*)
galoisBase[f_,selected0_:0]:=Module[{n,rx,allsets,coef,symm,base,contents,sols,oldselected,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10},
n=Exponent[f,x];
allsets=Subsets[Range[-5,5],{n}];
vars=Take[{x1,x2,x3,x4,x5,x6,x7,x8,x9,x10},n];
coef=CoefficientList[f,x]//Reverse//Drop[#,1]&;
symm=Table[SymmetricPolynomial[i,vars],{i,1,n}];
(*[Step1&2]while文の実行*)
sols=Table[1/v,{i,1,n}];rx=V=v;(*whileの初期値*)
selected=If[SameQ[selected0,0],RandomChoice[allsets],selected0];(*whileの初期値*)
While[
!AllTrue[Append[sols,rx],PolynomialQ[#,v]&]||Discriminant[rx,v]==0,(*「R(x)が重解を持つ」∨「rx,solsのうち多項式でないのがある」の間は以下を実行*)
oldselected=selected;
vs=Permutations[vars].selected;
contents=Append[symm+coef*Table[(-1)^(k-1),{k,1,n}],v−vs[[1]]];
rx=GroebnerBasis[contents,Append[vars,v]][[1]];(*原始元vを解に持つ因数分解前の式*)
V=If[IrreduciblePolynomialQ[rx],rx,Last@(List@@Factor[rx])];(*VのGroebner基底*)
sols=Table[base=GroebnerBasis[contents,{vars[[i]],v},Drop[vars,{i}]]//PolynomialMod[Last[#],V]&;(*解のGroebner基底*)
            vars[[i]]/.Solve[base==0,vars[[i]]][[1]]//Collect[#,v]&,{i,1,n}];
selected=RandomChoice[allsets]
];
selected=oldselected;
{V,sols}];
(*#################################################################################################*)
galoisGroup[f_,selected0_:0]:=Module[
{n,m,vsols,vs0,vs1,pos,vset,perm1,permi,irQ},
{V,sols}=galoisBase[f,selected0];
n=Exponent[f,x];
m=Exponent[V,v];
irQ=SameQ[m,Factorial[n]];(*=irreducibleQ*)
(*[Step3]V(x)の解の集合vsを,その第１要素v(=v1)の式で表す．(Subscript[Galois群がS, n])の時はバイパスしています*)
If[!irQ,vsols=v/.NSolve[V==0,v];
vs0=vs/.AssociationThread[vars->sols]//Collect[#,v]&;
vs1=vs0/.{v->vsols[[1]]};
pos=Table[PositionSmallest[Abs[vs1-vsols[[i]]]],{i,1,m}]//Flatten;
vset=vs0[[pos]]];
(*[Step4]Galois群を求める．(Subscript[Galois群がS, n])の時はバイパスしています*)
galoisgroup=If[irQ,Permutations[Range[n]],
   perm1=sols/.{v->vsols[[1]]};
   Table[
    permi=sols/.{v->vsols[[i]]};
    Table[PositionSmallest[Abs[permi-perm1[[k]]]][[1]],{k,1,n}]//Flatten,{i,1,m}]]];
(*#################################################################################################*)
solvables={{-15,-10,10,4},{-15,-10,10,7},{-14,-14,9,2},{-14,-9,10,4},{-13,-13,8,1},{-13,-8,10,4},{-12,-7,10,4},{-11,-11,11,11},{-11,-10,11,10},{-11,-6,10,4},{-11,11,6,1},{-10,5,10,1},{-10,10,5,2},{-9,-4,10,4},{-9,9,4,3},{-9,12,-6,12},{-8,-3,10,4},{-8,8,3,4},{-7,7,2,5},{-7,10,-5,2},{-6,-1,10,4},{-6,6,1,6},{-6,12,-9,12},{-5,0,5,3},{-5,0,5,4},{-5,0,5,5},{-5,0,5,6},{-5,0,5,7},{-5,0,5,8},{-5,0,5,9},{-5,0,5,10},{-5,0,5,11},{-5,0,5,12},{-5,0,5,13},{-5,0,5,14},{-5,0,5,15},{-5,0,10,4},{-5,0,10,9},{-5,0,15,14},{-5,5,0,7},{-5,7,8,5},{-5,10,-10,8},{-5,11,-3,9},{-5,12,-14,7},{-5,15,-5,3},{-4,1,10,4},{-4,4,-1,8},{-4,7,-14,13},{-4,13,-4,3},{-3,-4,8,1},{-3,1,7,5},{-3,2,6,3},{-3,2,10,4},{-3,3,-2,9},{-3,10,-13,14},{-3,11,-3,3},{-2,2,-3,10},{-2,3,10,4},{-2,7,-12,7},{-2,9,-2,3},{-1,-10,8,9},{-1,-7,1,11},{-1,-4,7,2},{-1,-2,3,4},{-1,1,-4,11},{-1,2,-2,1},{-1,4,4,1},{-1,4,10,4},{-1,7,-1,3},{-1,11,-13,13},{0,-15,15,6},{0,-10,10,2},{0,-5,0,15},{0,-3,2,1},{0,0,-5,12},{0,0,0,2},{0,0,0,3},{0,0,0,4},{0,0,0,5},{0,0,0,6},{0,0,0,7},{0,0,0,8},{0,0,0,9},{0,0,0,10},{0,0,0,11},{0,0,0,12},{0,0,0,13},{0,0,0,14},{0,0,0,15},{0,0,15,12},{0,5,-5,8},{0,5,-4,1},{0,5,0,3},{0,5,10,4},{0,9,14,4},{0,10,-10,6},{0,15,-15,12},{0,15,15,14},{1,-1,-6,13},{1,2,12,9},{1,3,1,3},{1,6,4,3},{1,6,10,4},{1,8,-10,13},{1,10,-12,8},{2,-2,-7,14},{2,1,2,3},{2,4,-1,4},{2,5,-4,4},{2,7,10,4},{2,8,9,8},{3,-3,-8,15},{3,-1,3,3},{3,3,-13,13},{3,6,-1,4},{3,8,6,9},{3,8,10,4},{4,-9,14,4},{4,-3,4,3},{4,4,8,8},{4,5,12,4},{4,9,10,1},{4,9,10,4},{5,-5,5,3},{5,0,5,1},{5,0,5,2},{5,0,5,3},{5,0,5,4},{5,0,5,5},{5,0,5,6},{5,0,5,7},{5,0,5,8},{5,0,5,9},{5,0,5,10},{5,0,5,12},{5,0,5,13},{5,0,5,14},{5,0,5,15},{5,1,9,5},{5,5,15,1},{5,10,0,5},{5,10,5,4},{5,10,10,4},{6,-7,6,3},{6,4,-9,4},{6,5,12,3},{6,11,10,4},{7,-9,7,3},{7,3,5,5},{7,5,5,1},{7,5,9,5},{7,10,-6,5},{7,12,10,4},{8,-11,8,3},{8,2,2,2},{8,5,6,7},{8,13,10,4},{9,-13,9,3},{9,5,3,9},{9,14,10,4},{10,-15,10,3},{10,0,0,5},{10,5,0,11},{10,10,10,3},{10,12,-11,4},{10,15,10,4},{10,15,10,12},{11,-2,0,7},{11,-2,4,8},{11,5,-3,13},{12,5,-6,15},{13,-8,12,7},{13,3,1,1}};
(*#################################################################################################*)
$c5=Table[RotateLeft[{1,2,3,4,5},i],{i,0,4}];(*名前の衝突を避けるため，$をつける*)
$d5=Join[$c5,$c5/.{2->5,5->2,3->4,4->3}]//Sort;
$f20=Join[$d5,$d5/.{2->3,3->5,5->4,4->2}]//Sort;
(*#################################################################################################*)
replace[gline_List,rp_List]:=(gline/.AssociationThread[Range[5]->rp])[[rp]];(*ガロア群の変換*)
realRoot[p_]:=Sign[p]Abs[p]^(1/5);(*実5乗根*)
deleteRedundancy[$rsets_]:=(*(r1,r2,r3,r4)がある時，(r4,r3,r1,r1),(r3,r1,r4,r2),(r2,r4,r1,r3)がもしあれば消去*)
　Nest[RotateLeft@DeleteElements[#,{#[[1]][[{4,3,2,1}]],#[[1]][[{3,1,4,2}]],#[[1]][[{2,4,1,3}]]}]&,$rsets,Length[$rsets]-1];
(*#################################################################################################*)
solveQuintic[f_]:=Module[
{coef,delta,g,order,gal,perm,i,r0,r1,r2,r3,r4,$w1,$w2,$$w1,$$w2,$r1,$r2,$r3,$r4,a1,a2,a3,a4,t1,t2,t3,t4,w1,w2,Rset,a2set,a3set,rsets,tset1,tset2,k1,k2,k3,k4,k5,k6,k7,m,j,pos,absTable},
coef=CoefficientList[f,x]//Reverse;
delta=coef[[2]]/coef[[1]]/5;
g=f/.{x->x-delta}//Collect[#,x]&;(*(x^4)の係数を0にする．本来は不要なはずだが 「4次の係数が0でない時」にエラーが出やすい．*)
galoisGroup[g];
order=Length[galoisgroup];
gal=If[MemberQ[{5,10,20},order],Switch[order,5,$c5,10,$d5,20,$f20],
　　　　Print["可解な5次方程式ではありません(It's not a solvable quintic equation)"];Break[]];
perm=Permutations[{1,2,3,4,5}];
i=1; While[Sort[replace[#,perm[[i]]]&/@galoisgroup]!=gal&&i<=120,perm[[i]];i++];
galoisbase={x1,x2,x3,x4,x5}=sols[[perm[[i]]]];
(*part1(前半)[変数の準備](Subscript[Lagrange分解式r, 0])~(Subscript[r, 4]), (Subscript[t, 1]),(Subscript[t, 2]),(Subscript[t, 3]),(Subscript[t, 4]),(Subscript[w, 1]),(Subscript[w, 2])を作る *)
Clear[ζ];
r0=x1+ x2+  x3 + x4 + x5//PolynomialMod[#,V]&;
r1=x1+ζ x2+ ζ^2 x3 +ζ^3 x4 +ζ^4 x5//PolynomialMod[#,{V,Cyclotomic[5,ζ]}]&;
r2=x1+ζ^2 x2+ ζ^4 x3 +ζ x4 +ζ^3 x5//PolynomialMod[#,{V,Cyclotomic[5,ζ]}]&;
r3=x1+ζ^3 x2+ ζ x3 +ζ^4 x4 +ζ^2 x5//PolynomialMod[#,{V,Cyclotomic[5,ζ]}]&;
r4=x1+ζ^4 x2+ ζ^3 x3 +ζ^2 x4 +ζ x5//PolynomialMod[#,{V,Cyclotomic[5,ζ]}]&;
t1=r1^5+r4^5;t2=r2^5+r3^5;t3=r1*r4;t4=r2*r3;
w1=r1 r2^2+r3^2 r4;
w2=r1^2 r3+r2 r4^2;
(*part1(後半)[単純計算] (Subscript[以下のk1～k7は全てF, 20])の固定体に含まれるので,(Subscript[Galois群がC, 5]),(Subscript[D, 5])であっても「単純計算」で値が求まる.*)
k1=t1+t2//PolynomialMod[#,{V,Cyclotomic[5,ζ]}]&;
k2=(t1-t2)^2 //PolynomialMod[#,{V,Cyclotomic[5,ζ]}]&;
k3=(t1-t2)(t3-t4)//PolynomialMod[#,{V,Cyclotomic[5,ζ]}]&;
k4=t3+t4//PolynomialMod[#,{V,Cyclotomic[5,ζ]}]&;
k5=t3*t4//PolynomialMod[#,{V,Cyclotomic[5,ζ]}]&;
k6=w1+w2//PolynomialMod[#,{V,Cyclotomic[5,ζ]}]&;
k7=(w1-w2)^2//PolynomialMod[#,{V,Cyclotomic[5,ζ]}]&;
(*part2[2次拡大(1回目)]k1~k3からt1,t2が,k4,k5からt3,t4の値が求まる．下のtset1には{t1,t2,t3,t4}の解の１つ目の組が，tset2には2つ目の組が入る*)
{tset1,tset2}={$t1,$t2,$t3,$t4}/.Solve[$t1+$t2==k1&&($t1-$t2)^2==k2&&($t1-$t2)($t3-$t4)==k3&&$t3+$t4==k4&&$t3*$t4==k5,{$t1,$t2,$t3,$t4}];
(*part3[2次拡大(2回目)]R1+R4=t1,R1R4=(t3^5),R2+R3=t2,R2R3=(t4^5).2次方程式を解くとR1~R4が求まる*)
Rset={R1,R2,R3,R4}/.Solve[(R1+R4==tset1[[1]]&&R1 R4==tset1[[3]]^5&&R2+R3==tset1[[2]]&&R2 R3==tset1[[4]]^5)
||(R2+R3==tset2[[1]]&&R2 R3==tset2[[3]]^5&&R2+R3==tset2[[2]]&&R2 R3==tset2[[4]]^5),{R1,R2,R3,R4}]//Simplify//deleteRedundancy;
(*part4[5次拡大]R1~R4の5乗根をとりr1~r4が求まる.このうちw1とw2の値を満足させる組を見つける.時間節約のため 有効数字計算を利用*)
{$r1,$r2,$r3,$r4}=If[Element[Rset,Reals],
(*Rsetが実数の時*)
  rsets=realRoot/@Rset;(*これは出力にもなるので，有効数字にしない*)
  absTable=Table[{a1,a2,a3,a4}=rsets[[i]];
  ww1=N[a1 a2^2+a4 a3^2];ww2=N[a1^2 a3+ a2 a4^2];
    Total@Abs@N[{ww1+ww2-k6,(ww1-ww2)^2-k7}],{i,1,Length[rsets]}];
    j=PositionSmallest[absTable]//First;(*|w1+w2-k6|+|(w1-w2)^2-k7|が最小となる位置を求める．なぜか$w1,$w2を使うとエラーとなる*)
  rsets[[j]],
(*Rsetが虚数の時*)
  ζ=Cos[2Pi/5]+I Sin[2Pi/5];(*この様に決めても一般性を失わない*)
  absTable=Table[(*absTableは実数の時と名前は同じだが，実行時は名前がぶつかることはない*)
    a1=Rset[[i,1]]^(1/5)//N;a4=Rset[[i,4]]^(1/5)//N;(*r1は5つの5乗根の内どれをとっても良い.r4とr1は複素共役*)
    a2set=Table[Rset[[i,2]]^(1/5)*ζ^n,{n,0,4}]//N;(*r2は5通りの5乗根を考える必要がある*)
    a3set=Table[Rset[[i,3]]^(1/5)*ζ^(-n),{n,0,4}]//N;(*r2とr3は複素共役*)
    Table[$w1=a1 a2set[[k]]^2+a4 a3set[[k]]^2;$w2=a1^2 a3set[[k]]+a4^2 a2set[[k]];
    Total@Abs@N[{$w1+$w2-k6,($w1-$w2)^2-k7}],{k,1,5}](*|$w1+$w2-k6|+|($w1-$w2)^2-k7|のTable*)
    ,{i,Length[Rset]}];
  pos=FirstPosition[absTable,Min@absTable];(*|$w1+$w2-k6|+|($w1-$w2)^2-k7|が最小となる位置を求める*)
  m=pos//Last;j=pos//First;(*posは {2,4}のように出力される．これは「Rsetの２番目∧a2set[[4]]」を表す*)
  (*pos=PositionSmallest[Flatten[absTable]];m=Mod[pos,5],n=Quotient[pos]でも大丈夫なはずだが分かりにくい*)
  {Rset[[j,1]]^(1/5),Rset[[j,2]]^(1/5)*ζ^(m-1),Rset[[j,3]]^(1/5)*ζ^(-(m-1)),Rset[[j,4]]^(1/5)}//Simplify
  ];(*end of if*)
(*part5[代入] r0~r4の値を代入するとx1~x5が求まる*)
ζ=Cos[2Pi/5]+I Sin[2Pi/5];(*偏角は2π/5に*) 
x1=1/5($r1+$r2+ $r3+ $r4)-delta//Simplify;(*x1~x5の定義を書き直し．また本来は()内にr0を入れれば deltaや平行移動は不要なはず*)
x2=1/5(ζ^4$r1+ζ^3 $r2+ζ ^2 $r3+ζ $r4)-delta//Simplify;
x3=1/5(ζ^3$r1+ζ $r2+ζ^4 $r3+ζ^2$r4)-delta//Simplify;
x4=1/5(ζ^2$r1+ζ^4 $r2+ζ $r3+ζ^3 $r4)-delta//Simplify;
x5=1/5(ζ$r1+ζ^2 $r2+ζ ^3 $r3+ζ^4 $r4)-delta//Simplify;
{x1,x2,x3,x4,x5}])]