7次方程式の厳密解を求める「未完成」プログラム
with Mathematica 14

2025 年5月4日  by  (HyperlinkURL["mixedmoss", https://mixedmoss.com])

§1. 使い方

これは5次方程式の「solveQuintic」の様なプログラムではありません．7次方程式f[x], その原始元vの最小多項式V[x], vによるfの解x1～x7の表現solsの3つを最初に入力して，notebook全体を評価する事により，f=0の厳密解が求まります．評価には1分ほど掛かります．F42_Solutions.nb の補足Bの方法- 3次方程式の解の公式を使う方法- を使っています．sols は {1 + v + v^2,1-v+2(v^2), 3-v+3(v^2)}のように, v の式のみで入力してくださいSageMath の場合は次のようなコマンドの後，Lの結果からVの式が，roots の結果から sols が求まりますが，editor などで少し変形する必要があります．

x=polygen(QQ,’x’) 　#xを有理数係数多項式の変数と設定，R_.<x>=QQ などもOK
f=x^7 - 2*x^5 + x^4 + 4*x^3 - x^2 - 4*x + 3
N.<a>=NumberField(f)　#Nはfの解の一つ(ここではa)を Qに付加した体
L.<v>=N.galois_closure()   #LはNのガロア閉包
L

y=polygen(L,’y’) 　#yをLの変数と設定
g=y^7 - 2*y^5 + y^4 + 4*y^3 - y^2 - 4*y + 3
g.roots()

§2. 例 (下の f,V,sols を変えて, notebook を評価して下さい)

ClearAll["`*"]

f[x_]=x^7+7*x^3-7*x^2+7*x+1;
V[x_]=x^14-14*x^12+49*x^10+98*x^8-686*x^6+343*x^4+343*x^2+3087;

sols=(*{x1,x5,x4,x6,x7,x2,x3}=*){38/17199*v^12-15/637*v^10+59/2457*v^8+131/351*v^6-55/117*v^4-541/351*v^2-67/39,-79/34398*v^12+85/3822*v^10-29/2457*v^8-1657/4914*v^6+31/117*v^4+629/702*v^2+1/2*v+167/78,-79/34398*v^12+85/3822*v^10-29/2457*v^8-1657/4914*v^6+31/117*v^4+629/702*v^2-1/2*v+167/78,31/34398*v^13-22/17199*v^12-131/11466*v^11+157/11466*v^10+80/2457*v^9-95/4914*v^8+236/2457*v^7-418/2457*v^6-17/39*v^5+7/26*v^4+59/351*v^3+188/351*v^2-8/39*v+55/78,4/17199*v^13+85/34398*v^12-25/11466*v^11-277/11466*v^10-2/2457*v^9+47/2457*v^8+269/4914*v^7+788/2457*v^6-5/78*v^5-35/117*v^4-313/702*v^3-232/351*v^2+55/78*v-155/78,-4/17199*v^13+85/34398*v^12+25/11466*v^11-277/11466*v^10+2/2457*v^9+47/2457*v^8-269/4914*v^7+788/2457*v^6+5/78*v^5-35/117*v^4+313/702*v^3-232/351*v^2-55/78*v-155/78,-31/34398*v^13-22/17199*v^12+131/11466*v^11+157/11466*v^10-80/2457*v^9-95/4914*v^8-236/2457*v^7-418/2457*v^6+17/39*v^5+7/26*v^4-59/351*v^3+188/351*v^2+8/39*v+55/78};

準備プログラム(ガロア群を求めて整形)

(*ガロア群を求めてgaloisgroupに入れる*)
vsols=v/.NSolve[V[v]==0];
perm1=sols/.{v->vsols[[1]]};
galoisgroup=Table[
permi=sols/.{v->vsols[[i]]};
Table[PositionSmallest[Abs[permi-perm1[[k]]]][[1]],{k,1,7}]//Flatten,{i,1,Length[vsols]}]//Sort;
(*(Subscript[C, 7]),(Subscript[D, 7]),(Subscript[F, 21]),(Subscript[F, 42 ])の定義*)
c7=Table[RotateLeft[{1,2,3,4,5,6,7},i],{i,0,6}];(*名前の衝突にお気を付け下さい*)
d7=Join[c7,c7/.{1->6,2->5,3->4,4->3,5->2,6->1}]//Sort;
f21=Join[c7,c7/.{1->3,2->6,3->2,4->5,5->1,6->4},c7/.{1->2,2->4,3->6,4->1,5->3,6->5}]//Union//Sort;
f42=Join[d7,d7/.{1->3,2->6,3->2,4->5,5->1,6->4},d7/.{1->2,2->4,3->6,4->1,5->3,6->5}]//Union//Sort;
(*x1~x7の順序を変換して「正確に」(Subscript[C, 7]),(Subscript[D, 7]),(Subscript[F, 21]),(Subscript[F, 42 ])に一致させる*)
replace[gline_List,rp_List]:=(gline/.AssociationThread[Range[7]->rp])[[rp]];(*ガロア群の変換*)
order=Length[galoisgroup];
gal=If[MemberQ[{7,14,21,42},order],Switch[order,7,c7,14,d7,21,f21,42,f42],
　　　　Print["可解な7次方程式ではありません(It's not a solvable septic equation)"];Break[]];
perm=Permutations[{1,2,3,4,5,6,7}];
i=1; While[Sort[replace[#,perm[[i]]]&/@galoisgroup]!=gal&&i<=Factorial[7],perm[[i]];i++];
sols=sols[[perm[[i]]]];

メインプログラム

(*[1]{t1,t2,t3,t4,t5,t6}={R1+R6,R2+R5,R3+R4,R1R6,R2R5,R3R4}の候補を求める*)
x2r={{1,1,1,1,1,1,1},{1,ζ,ζ^2,ζ^3,ζ^4,ζ^5,ζ^6},{1,ζ^2,ζ^4,ζ^6,ζ,ζ^3,ζ^5},{1,ζ^3,ζ^6,ζ^2,ζ^5,ζ,ζ^4},{1,ζ^4,ζ,ζ^5,ζ^2,ζ^6,ζ^3},{1,ζ^5,ζ^3,ζ,ζ^6,ζ^4,ζ^2},{1,ζ^6,ζ^5,ζ^4,ζ^3,ζ^2,ζ}};
{r0,r1,r2,r3,r4,r5,r6}=x2r.sols//PolynomialMod[#,{V[v],Cyclotomic[7,ζ]}]&;
{R1,R2,R3,R4,R5,R6}={r1,r2,r3,r4,r5,r6}^7;
{t1,t2,t3,t4,t5,t6}={R1+R6,R2+R5,R3+R4,R1 R6,R2 R5,R3 R4}//PolynomialMod[#,{V[v],Cyclotomic[7,ζ]}]&;(*t1~t6はvの式*)
{p1,p2,p3}={t1+t2+t3,t1 t2+t2 t3+t3 t1,t1*t2*t3}//PolynomialMod[#,{V[v],Cyclotomic[7,ζ]}]&;
{q1,q2,q3}={t4+t5+t6,t4 t5+t5 t6+t6 t4,t4*t5*t6}//PolynomialMod[#,{V[v],Cyclotomic[7,ζ]}]&;
t123456=x/.Solve[x^3-p1 x^2+p2 x-p3==0||x^3-q1 x^2+q2 x-q3==0,x,Cubics->True]//Simplify;(*t123456={t1,t2,t3,t4,t5,t6}は厳密解.順序はまだ不明*)

(*[2]数値計算を利用して　t1~t6,R1~R6,r1~r6の厳密解を求める．近似解は $ を先頭に付けて表す*)
v0=(v/.NSolve[V[v]==0,v])[[1]];
$sols={$x1,$x2,$x3,$x4,$x5,$x6,$x7}=sols/.{v->v0};(*x1~x7の数値解*)
ζ=Cos[2Pi/7]+I Sin[2Pi/7];
{$r0,$r1,$r2,$r3,$r4,$r5,$r6}=x2r.$sols;(*r1~r6の数値解*)
$r123456={$r1,$r2,$r3,$r4,$r5,$r6};(*r1~r6の数値解をr123456.順序も正しい*)
$R123456={$R1,$R2,$R3,$R4,$R5,$R6}=$r123456 ^7;(*R1~R6の数値解*)
$t123456={$t1,$t2,$t3,$t4,$t5,$t6}={$R1+$R6,$R2+$R5,$R3+$R4,$R1 $R6, $R2 $R5, $R3 $R4};(*t1~t6の数値解.順序も正しい*)
pos=Table[PositionSmallest[Abs[$t123456[[i]]-N[t123456]]]//First,{i,1,6}];(*t123456の内,$t123456に対応する要素のposition*)
t123456={t1,t2,t3,t4,t5,t6}=t123456[[pos]];(*t1~t6の厳密解.順序も正しい*)
R123456=y/.Solve[y^2-(t1)y+t4==0||y^2-(t2)y+t5==0||y^2-(t3)y+t6==0,y];(*R1~R6の厳密解.順序は不明*)
pos=Table[PositionSmallest[Abs[$R123456[[i]]-N[R123456]]]//First,{i,1,6}];(*R123456の内,$R123456に対応する要素のposition*)
R123456={R1,R2,R3,R4,R5,R6}=R123456[[pos]];(*R1~R6の厳密解.順序も正しい*)
power=Round[Arg[$r123456]-Arg[(N@R123456)^(1/7)]]~Mod~7;(*R1~R6の7乗根と$r1~$r6が一致するように偏角を「ζの累乗の指数として」決定*)
r123456=R123456^(1/7)*ζ^power;(*r1~r6の厳密解.順序も正しい*)
(*[3]r1~r6を代入してx1~x7の厳密解を求める*)
{x1,x2,x3,x4,x5,x6,x7}=1/7{{1,1,1,1,1,1},{ζ^6,ζ^5,ζ^4,ζ^3,ζ^2,ζ},{ζ^5,ζ^3,ζ,ζ^6,ζ^4,ζ^2},{ζ^4,ζ,ζ^5,ζ^2,ζ^6,ζ^3},{ζ^3,ζ^6,ζ^2,ζ^5,ζ,ζ^4},{ζ^2,ζ^4,ζ^6,ζ,ζ^3,ζ^5},{ζ,ζ^2,ζ^3,ζ^4,ζ^5,ζ^6}}.r123456;

実行結果

ガロア群の位数は

Length[gal]

f=0 の厳密解は，x1~x7に入っています．x1のみ表示します

x1//Simplify//TraditionalForm//Style[#,Small]&

検算です. 「f=0の数値解」と「上で求めた厳密解x1~x7の近似値」です．

x/.NSolve[f[x]==0,x]//Chop[#,10^(-8)]&//Sort
N[{x1,x2,x3,x4,x5,x6,x7}]//Chop[#,10^(-8)]&//Sort