解一个伽罗娃方程x^5-x+1=0的根式解

风花飘飘

验根代码：



(*嫦娥灵枢一元五次方程一步锁死直取法定理，适用Bring‑Jerrard型 x^5+p x+q==0*)
ClearAll["Global`*"];
Off[Solve::ifun];
Off[N::meprec];

(*----------参数入口----------*)
p = -1; q = 1;(*基准实例布灵方程x^5‑x+1==0*)
precision = 1000;(*计算精度位数*)

(*----------配对公理求解u,v方程组----------*)
eqs = {u^5 + v^5 == -4*Sqrt[2]*q, u*v == -2*p/25};
sols = Solve[eqs, {u, v}, Complexes];

(*----------筛选主实分支：(u+v)/Sqrt[2]为实数且绝对值最小----------*)
realCond[sol_] := Abs[Im[(u + v)/Sqrt[2] /. sol]] < 10^(-precision/2);
realSols = Select[sols, realCond];
{U0, V0} = First[Sort[realSols, Abs[N[(u + v)/Sqrt[2] /. #1]] < Abs[N[(u + v)/Sqrt[2] /. #2]] &]];
{u0, v0} = {U0, V0};

(*----------五次本原单位根----------*)
w5 = Exp[2*Pi*I/5];

(*----------生成全部五个根式解----------*)
rootSym = Table[(u0*w5^(k&#8209;1) + v0*w5^(-(k&#8209;1)))/Sqrt[2], {k, 1, 5}];
rootNum = N[rootSym, precision];

(*----------验根：代入原方程计算残差----------*)
residual = Chop[#^5 + p*# + q & /@ rootNum, 10^(-precision + 10)];

(*----------结果分类：分离实根与共轭复根对----------*)
realRoots = Select[rootNum, Abs[Im[#]] < 10^(-20) &];
compRoots = Complement[rootNum, realRoots];

(*----------格式化输出全部信息----------*)
Print["=====嫦娥灵枢一元五次方程一步锁死直取法====="];
Print["求解方程：x^5 + ", p, " x + ", q, " == 0"];
Print["-------------------------------------------"];
Do[
res = residual[[k]];
Print["根 ", k, "："];
Print["符号根式解：", rootSym[[k]]];
Print[DecimalForm[rootNum[[k]], 60]];
Print["代入方程残差：", res];
Print["-------------------------------------------"];
, {k, 1, 5}];

Print["★唯一实根："];
If[Length[realRoots] >= 1, Print[First[realRoots]], Print["无实根"]];
Print["★第一组共轭复根：", compRoots[[1;;2]]];
Print["★第二组共轭复根：", compRoots[[3;;4]]];

Print["=====定理自洽性校验完成====="];

风花飘飘

代码这样比较完整一些：


(*嫦娥灵枢体系·蝶恋花公式+Bring&#8209;Jerrard退化接口自动切换完整合并代码
适配一般五次方程 a x^5+b x^4+c x^3+d x^2+e x+f==0
非退化：使用蝶恋花主根公式；退化B3&#8209;A2C=0转入Bring&#8209;Jerrard配对公理求解全部五根*)
ClearAll["Global`*"];
Off[Solve::ifun]; Off[N::meprec];

(*====================1.参数入口：输入五次方程系数====================*)
{a, b, c, d, e, f} = {1, 0, 0, 0, -1, 1};(*测试方程 x^5&#8209;x+1==0 *)
precision = 1000;(*全局计算精度位数*)

(*====================2.计算蝶恋花体系中间变量A,B,C,D====================*)
A = c/a - b^2/(5 a^2);
B = d/a - (b c)/(5 a^2) + (2 b^3)/(25 a^3);
C = e/a - (2 b d)/(5 a^2) + (b^2 c)/(25 a^3) - (3 b^4)/(125 a^4);
D = f/a - (b e)/(5 a^2) + (b^2 d)/(25 a^3) - (b^3 c)/(125 a^4) + (4 b^5)/(3125 a^5);

Print["=====第一步：中间变量A,B,C,D计算结果====="];
Print["A = ", N[A, 60]];
Print["B = ", N[B, 60]];
Print["C = ", N[C, 60]];
Print["D = ", N[D, 60]];

(*====================3.退化判断基准 base=B3&#8209;A2C====================*)
base = B^3 - A^2*C;
n = Surd[base, 3];
Print["\n=====第二步：退化条件判定====="];
Print["判别式 B3&#8209;A2C = ", base];

If[Chop[base, 10^(-30)] != 0,
(*————————————分支1：非退化情形，执行蝶恋花标准主根公式————————————*)
Print["判定结果：非退化，执行蝶恋花主根求解模式"];
innerRad = B^3/n - n^2 + C^2 - 2*A*D;
y1 = Surd[n + Sqrt[innerRad], 5];
y2 = Surd[n - Sqrt[innerRad], 5];
p = y1; q = y2;
(*主根x1闭式表达式*)
x1 = p + q - (1/5)*Surd[B^3 - A^2*C*(p^5 q^5 - (Surd[B^3 - A^2*C, 3])^2) + C^2 - 2*A*D, 5] - b/(5*a);
(*高精度数值计算与验根*)
x1Num = N[x1, precision];
residual = Chop[N[a*x1^5 + b*x1^4 + c*x1^3 + d*x1^2 + e*x1 + f, precision], 10^(-precision + 10)];
(*格式化输出*)
Print["\n=====蝶恋花主根求解结果====="];
Print["简约布林标准五次方程：t^5+", A, "t^3+", B, "t^2+", C, "t+", D, "==0，平移代换x = t&#8209;", b/(5 a)];
Print["主根符号闭式：x1 = ", x1];
Print["主根高精度数值解：", N[x1Num, 60]];
Print["代入原方程残差：", residual];
Print["说明：剩余四根可按时展开扩充求解"];,

(*————————————分支2：退化情形base≈0，转入Bring&#8209;Jerrard配对公理完整求解五根————————————*)
Print["判定结果：B3&#8209;A2C≈0，蝶恋花主根公式失效，自动转入Bring&#8209;Jerrard配对公理求解接口"];
(*平移代换还原 t=x+b/(5a)，简约Bring&#8209;Jerrard标准型 x^5+pBJ x+qBJ==0 *)
pBJ = C; qBJ = D;
Print["转入Bring&#8209;Jerrard标准简约五次方程：x^5 + ", pBJ, " x + ", qBJ, " == 0"];
(*配对公理方程组 u^5+v^5=&#8209;4√2 qBJ，u v=&#8209;2 pBJ/25 *)
eqs = {u^5 + v^5 == -4*Sqrt[2]*qBJ, u*v == -2*pBJ/25};
sols = Solve[eqs, {u, v}, Complexes];
(*筛选实分支：(u+v)/Sqrt[2]为实数且绝对值最小*)
realCond[sol_] := Abs[Im[(u + v)/Sqrt[2] /. sol]] < 10^(-precision/2);
realSols = Select[sols, realCond];
{U0, V0} = First[Sort[realSols, Abs[N[(u + v)/Sqrt[2] /. #1]] < Abs[N[(u + v)/Sqrt[2] /. #2]] &]];
{u0, v0} = {U0, V0};
(*五次本原单位根*)
w5 = Exp[2*Pi*I/5];
(*生成全部五个根，叠加平移修正&#8209;b/(5a)*)
rootSym = Table[(u0*w5^(k&#8209;1) + v0*w5^(-(k&#8209;1)))/Sqrt[2] - b/(5*a), {k, 1, 5}];
rootNum = N[rootSym, precision];
(*批量验根计算残差*)
residual = Chop[N[a*#^5 + b*#^4 + c*#^3 + d*#^2 + e*# + f & /@ rootNum, precision], 10^(-precision + 10)];
(*根分类：分离实根、共轭复根对*)
realRoots = Select[rootNum, Abs[Im[#]] < 10^(-20) &];
compRoots = Complement[rootNum, realRoots];
(*格式化完整输出全部解信息*)
Print["\n=====Bring&#8209;Jerrard接口求解全部五个根====="];
Do[
Print["第", k, "个根："];
Print["符号根式解：", rootSym[[k]]];
Print["高精度数值解：", N[rootNum[[k]], 60]];
Print["代入原方程残差：", residual[[k]]];
Print