[math-fun] That InverseFourier hack seems also to solve cubics and septics.
(But the septic solver requires a sextic solver.) Here, with crucial help from Julian (despite his disdain for preoccupation with radicals), is the cubic (with rational coefficients) solver: In[107]:= scub[x^3-8x-10] Out[107]= {(45+Sqrt[489])^(1/3)/(3^(2/3) I^(4/3))+((45-Sqrt[489])^(1/3) I^(4/3))/3^(2/3), (45-Sqrt[489])^(1/3)/(3^(2/3) I^(4/3))+((45+Sqrt[489])^(1/3) I^(4/3))/3^(2/3), (45-Sqrt[489])^(1/3)/3^(2/3)+(45+Sqrt[489])^(1/3)/3^(2/3)} In[109]:= ContinuedFraction[%%[[3]],69] Out[109]= {3,3,7,4,2,30,1,8,3,1,1,1,9,2,2,1,3,22986, 2,1,32,8,2,1,8,55,1, 5,2,28,1,5,1,1501790, 1,2,1,7,6,1,1,5,2,1,6,2,2,1,2,1,1,3,1,3,1,2,4,3,1,35657, 1,17,2,15,1,1,2,1,1} scub[q_]:= ToRadicals[Block[{rts = (#1[[1,2]] & ) /@ NSolve[q == 0,WorkingPrecision->33],foos}, foos = (rts.{{1,1,1},{1,1/I^(4/3),I^(4/3)},{1,I^(4/3),1/I^(4/3)}})^3/27; foos = (Together[#1[[1,2]]]^(1/3) & ) /@ Solve[0 == Rationalize[Expand[Times @@ (#1 - Rest@foos)]]]; Rationalize@Mean@ rts + (foos . #1 & ) /@ {{I^(4/3),1/I^(4/3)},{1/I^(4/3),I^(4/3)},{1,1}}]] That's it! For triples, the InverseFourier open codes to this little matrix multiplication foos = (rts.{{1,1,1},{1,1/I^(4/3),I^(4/3)},{1,I^(4/3),1/I^(4/3)}})^3/27; and the searches over root permutations and roots of unity degenerate. Whoa, wait a minute, it calls Solve! But only on quadratics. Which we could open-code. In[111]:= scub[Echo@MinimalPolynomial[Cos[2\[Pi]/7],x]] -1-4 x+4 x^2+8 x^3 Out[111]= {-(1/6)+(7/2 (1+3 I Sqrt[3]))^(1/3)/(6 I^(4/3))+1/6 (7/2 (1-3 I Sqrt[3]))^(1/3) I^(4/3), -(1/6)+(7/2 (1-3 I Sqrt[3]))^(1/3)/(6 I^(4/3))+1/6 (7/2 (1+3 I Sqrt[3]))^(1/3) I^(4/3), -(1/6)+1/6 (7/2 (1-3 I Sqrt[3]))^(1/3)+1/6 (7/2 (1+3 I Sqrt[3]))^(1/3)} In[114]:= FullSimplify@ArcCos@%%% Out[114]= {ArcCos[-(1/6)+(7/2 (1+3 I Sqrt[3]))^(1/3)/(6 I^(4/3))+1/6 I^(4/3) 2.37\[Ellipsis]-1.18\[Ellipsis] I], ArcCos[-(1/6)+1/6 (7/2 (1+3 I Sqrt[3]))^(1/3) I^(4/3)+2.37\[Ellipsis]-1.18\[Ellipsis] I/(6 I^(4/3))], 2π/7}. Disclaimer: For sufficiently exotic coefficients, WorkingPrecision->33 would need to increase, But I'm surprised that such a concise formula isn't more popular. —rwg
Ouch, mea gufa—emergency recall! In[121]:= MinimalPolynomial[(Power[22, (3)^-1]-Power[7, (3)^-1])^3,x] Out[121]= -3375+4833 x-45 x^2+x^3 In[122]:= scub@% Out[122]= {15+(3 7^(2/3) 22^(1/3))/I^(4/3)+3 (-7)^(1/3) 22^(2/3) I^(4/3),15+(3 (-7)^(1/3) 22^(2/3))/I^(4/3)+3 7^(2/3) 22^(1/3) I^(4/3),15+3 7^(2/3) 22^(1/3)+3 (-7)^(1/3) 22^(2/3)} No real root!! Debugging in progress. Apologies. —Bill On Tue, Nov 17, 2020 at 5:11 AM Bill Gosper <billgosper@gmail.com> wrote:
(But the septic solver requires a sextic solver.) Here, with crucial help from Julian (despite his disdain for preoccupation with radicals), is the cubic (with rational coefficients) solver:
In[107]:= scub[x^3-8x-10]
Out[107]= {(45+Sqrt[489])^(1/3)/(3^(2/3) I^(4/3))+((45-Sqrt[489])^(1/3) I^(4/3))/3^(2/3), (45-Sqrt[489])^(1/3)/(3^(2/3) I^(4/3))+((45+Sqrt[489])^(1/3) I^(4/3))/3^(2/3), (45-Sqrt[489])^(1/3)/3^(2/3)+(45+Sqrt[489])^(1/3)/3^(2/3)}
In[109]:= ContinuedFraction[%%[[3]],69] Out[109]= {3,3,7,4,2,30,1,8,3,1,1,1,9,2,2,1,3,22986, 2,1,32,8,2,1,8,55,1, 5,2,28,1,5,1,1501790, 1,2,1,7,6,1,1,5,2,1,6,2,2,1,2,1,1,3,1,3,1,2,4,3,1,35657, 1,17,2,15,1,1,2,1,1}
scub[q_]:= ToRadicals[Block[{rts = (#1[[1,2]] & ) /@ NSolve[q == 0,WorkingPrecision->33],foos}, foos = (rts.{{1,1,1},{1,1/I^(4/3),I^(4/3)},{1,I^(4/3),1/I^(4/3)}})^3/27; foos = (Together[#1[[1,2]]]^(1/3) & ) /@ Solve[0 == Rationalize[Expand[Times @@ (#1 - Rest@foos)]]]; Rationalize@Mean@ rts + (foos . #1 & ) /@ {{I^(4/3),1/I^(4/3)},{1/I^(4/3),I^(4/3)},{1,1}}]]
That's it! For triples, the InverseFourier open codes to this little matrix multiplication
foos = (rts.{{1,1,1},{1,1/I^(4/3),I^(4/3)},{1,I^(4/3),1/I^(4/3)}})^3/27;
and the searches over root permutations and roots of unity degenerate.
Whoa, wait a minute, it calls Solve! But only on quadratics. Which we could open-code.
In[111]:= scub[Echo@MinimalPolynomial[Cos[2\[Pi]/7],x]]
-1-4 x+4 x^2+8 x^3
Out[111]= {-(1/6)+(7/2 (1+3 I Sqrt[3]))^(1/3)/(6 I^(4/3))+1/6 (7/2 (1-3 I Sqrt[3]))^(1/3) I^(4/3), -(1/6)+(7/2 (1-3 I Sqrt[3]))^(1/3)/(6 I^(4/3))+1/6 (7/2 (1+3 I Sqrt[3]))^(1/3) I^(4/3), -(1/6)+1/6 (7/2 (1-3 I Sqrt[3]))^(1/3)+1/6 (7/2 (1+3 I Sqrt[3]))^(1/3)}
In[114]:= FullSimplify@ArcCos@%%% Out[114]= {ArcCos[-(1/6)+(7/2 (1+3 I Sqrt[3]))^(1/3)/(6 I^(4/3))+1/6 I^(4/3) 2.37\[Ellipsis]-1.18\[Ellipsis] I], ArcCos[-(1/6)+1/6 (7/2 (1+3 I Sqrt[3]))^(1/3) I^(4/3)+2.37\[Ellipsis]-1.18\[Ellipsis] I/(6 I^(4/3))], 2π/7}.
Disclaimer: For sufficiently exotic coefficients, WorkingPrecision->33 would need to increase, But I'm surprised that such a concise formula isn't more popular. —rwg
That remind me — I have to empty my septics.
On Nov 17, 2020, at 12:24 PM, Bill Gosper <billgosper@gmail.com> wrote:
Ouch, mea gufa—emergency recall! In[121]:= MinimalPolynomial[(Power[22, (3)^-1]-Power[7, (3)^-1])^3,x] Out[121]= -3375+4833 x-45 x^2+x^3 In[122]:= scub@% Out[122]= {15+(3 7^(2/3) 22^(1/3))/I^(4/3)+3 (-7)^(1/3) 22^(2/3) I^(4/3),15+(3 (-7)^(1/3) 22^(2/3))/I^(4/3)+3 7^(2/3) 22^(1/3) I^(4/3),15+3 7^(2/3) 22^(1/3)+3 (-7)^(1/3) 22^(2/3)} No real root!! Debugging in progress. Apologies. —Bill
On Tue, Nov 17, 2020 at 5:11 AM Bill Gosper <billgosper@gmail.com> wrote:
(But the septic solver requires a sextic solver.) Here, with crucial help from Julian (despite his disdain for preoccupation with radicals), is the cubic (with rational coefficients) solver:
In[107]:= scub[x^3-8x-10]
Out[107]= {(45+Sqrt[489])^(1/3)/(3^(2/3) I^(4/3))+((45-Sqrt[489])^(1/3) I^(4/3))/3^(2/3), (45-Sqrt[489])^(1/3)/(3^(2/3) I^(4/3))+((45+Sqrt[489])^(1/3) I^(4/3))/3^(2/3), (45-Sqrt[489])^(1/3)/3^(2/3)+(45+Sqrt[489])^(1/3)/3^(2/3)}
In[109]:= ContinuedFraction[%%[[3]],69] Out[109]= {3,3,7,4,2,30,1,8,3,1,1,1,9,2,2,1,3,22986, 2,1,32,8,2,1,8,55,1, 5,2,28,1,5,1,1501790, 1,2,1,7,6,1,1,5,2,1,6,2,2,1,2,1,1,3,1,3,1,2,4,3,1,35657, 1,17,2,15,1,1,2,1,1}
scub[q_]:= ToRadicals[Block[{rts = (#1[[1,2]] & ) /@ NSolve[q == 0,WorkingPrecision->33],foos}, foos = (rts.{{1,1,1},{1,1/I^(4/3),I^(4/3)},{1,I^(4/3),1/I^(4/3)}})^3/27; foos = (Together[#1[[1,2]]]^(1/3) & ) /@ Solve[0 == Rationalize[Expand[Times @@ (#1 - Rest@foos)]]]; Rationalize@Mean@ rts + (foos . #1 & ) /@ {{I^(4/3),1/I^(4/3)},{1/I^(4/3),I^(4/3)},{1,1}}]]
That's it! For triples, the InverseFourier open codes to this little matrix multiplication
foos = (rts.{{1,1,1},{1,1/I^(4/3),I^(4/3)},{1,I^(4/3),1/I^(4/3)}})^3/27;
and the searches over root permutations and roots of unity degenerate.
Whoa, wait a minute, it calls Solve! But only on quadratics. Which we could open-code.
In[111]:= scub[Echo@MinimalPolynomial[Cos[2\[Pi]/7],x]]
-1-4 x+4 x^2+8 x^3
Out[111]= {-(1/6)+(7/2 (1+3 I Sqrt[3]))^(1/3)/(6 I^(4/3))+1/6 (7/2 (1-3 I Sqrt[3]))^(1/3) I^(4/3), -(1/6)+(7/2 (1-3 I Sqrt[3]))^(1/3)/(6 I^(4/3))+1/6 (7/2 (1+3 I Sqrt[3]))^(1/3) I^(4/3), -(1/6)+1/6 (7/2 (1-3 I Sqrt[3]))^(1/3)+1/6 (7/2 (1+3 I Sqrt[3]))^(1/3)}
In[114]:= FullSimplify@ArcCos@%%% Out[114]= {ArcCos[-(1/6)+(7/2 (1+3 I Sqrt[3]))^(1/3)/(6 I^(4/3))+1/6 I^(4/3) 2.37\[Ellipsis]-1.18\[Ellipsis] I], ArcCos[-(1/6)+1/6 (7/2 (1+3 I Sqrt[3]))^(1/3) I^(4/3)+2.37\[Ellipsis]-1.18\[Ellipsis] I/(6 I^(4/3))], 2π/7}.
Disclaimer: For sufficiently exotic coefficients, WorkingPrecision->33 would need to increase, But I'm surprised that such a concise formula isn't more popular. —rwg
_______________________________________________ math-fun mailing list math-fun@mailman.xmission.com https://linkprotect.cudasvc.com/url?a=https%3a%2f%2fmailman.xmission.com%2fc...
scub was "over-optimized". This under-optimized version seems to work: scub[q_]:= ToRadicals[Block[{rts = (#1[[1,2]] & ) /@ NSolve[q == 0, WorkingPrecision -> 99],boa,foos}, foos = (rts.{{1,1,1},{1,1/I^(4/3),I^(4/3)},{1,I^(4/3),1/I^(4/3)}})^3/27; foos = (Together[#1[[1,2]]]^(1/3) & ) /@ Solve[0 == Rationalize[Expand[Times @@ (#1 - Rest@foos)]]]; boa= Rationalize@Mean@ rts; boa+ Union[(foos . #1 & ) /@ Echo@Select[Tuples[I^(4Range@3/3),2], MemberQ[Chop[#1 . foos + boa - rts], 0] &]]]] —Bill On Tue, Nov 17, 2020 at 11:24 AM Bill Gosper <billgosper@gmail.com> wrote:
Ouch, mea gufa—emergency recall! In[121]:= MinimalPolynomial[(Power[22, (3)^-1]-Power[7, (3)^-1])^3,x] Out[121]= -3375+4833 x-45 x^2+x^3 In[122]:= scub@% Out[122]= {15+(3 7^(2/3) 22^(1/3))/I^(4/3)+3 (-7)^(1/3) 22^(2/3) I^(4/3),15+(3 (-7)^(1/3) 22^(2/3))/I^(4/3)+3 7^(2/3) 22^(1/3) I^(4/3),15+3 7^(2/3) 22^(1/3)+3 (-7)^(1/3) 22^(2/3)} No real root!! Debugging in progress. Apologies. —Bill
On Tue, Nov 17, 2020 at 5:11 AM Bill Gosper <billgosper@gmail.com> wrote:
(But the septic solver requires a sextic solver.) Here, with crucial help from Julian (despite his disdain for preoccupation with radicals), is the cubic (with rational coefficients) solver:
In[107]:= scub[x^3-8x-10]
Out[107]= {(45+Sqrt[489])^(1/3)/(3^(2/3) I^(4/3))+((45-Sqrt[489])^(1/3) I^(4/3))/3^(2/3), (45-Sqrt[489])^(1/3)/(3^(2/3) I^(4/3))+((45+Sqrt[489])^(1/3) I^(4/3))/3^(2/3), (45-Sqrt[489])^(1/3)/3^(2/3)+(45+Sqrt[489])^(1/3)/3^(2/3)}
In[109]:= ContinuedFraction[%%[[3]],69] Out[109]= {3,3,7,4,2,30,1,8,3,1,1,1,9,2,2,1,3,22986, 2,1,32,8,2,1,8,55,1, 5,2,28,1,5,1,1501790, 1,2,1,7,6,1,1,5,2,1,6,2,2,1,2,1,1,3,1,3,1,2,4,3,1,35657, 1,17,2,15,1,1,2,1,1}
scub[q_]:= ToRadicals[Block[{rts = (#1[[1,2]] & ) /@ NSolve[q == 0,WorkingPrecision->33],foos}, foos = (rts.{{1,1,1},{1,1/I^(4/3),I^(4/3)},{1,I^(4/3),1/I^(4/3)}})^3/27; foos = (Together[#1[[1,2]]]^(1/3) & ) /@ Solve[0 == Rationalize[Expand[Times @@ (#1 - Rest@foos)]]]; Rationalize@Mean@ rts + (foos . #1 & ) /@ {{I^(4/3),1/I^(4/3)},{1/I^(4/3),I^(4/3)},{1,1}}]]
That's it! For triples, the InverseFourier open codes to this little matrix multiplication
foos = (rts.{{1,1,1},{1,1/I^(4/3),I^(4/3)},{1,I^(4/3),1/I^(4/3)}})^3/27;
and the searches over root permutations and roots of unity degenerate.
Whoa, wait a minute, it calls Solve! But only on quadratics. Which we could open-code.
In[111]:= scub[Echo@MinimalPolynomial[Cos[2\[Pi]/7],x]]
-1-4 x+4 x^2+8 x^3
Out[111]= {-(1/6)+(7/2 (1+3 I Sqrt[3]))^(1/3)/(6 I^(4/3))+1/6 (7/2 (1-3 I Sqrt[3]))^(1/3) I^(4/3), -(1/6)+(7/2 (1-3 I Sqrt[3]))^(1/3)/(6 I^(4/3))+1/6 (7/2 (1+3 I Sqrt[3]))^(1/3) I^(4/3), -(1/6)+1/6 (7/2 (1-3 I Sqrt[3]))^(1/3)+1/6 (7/2 (1+3 I Sqrt[3]))^(1/3)}
In[114]:= FullSimplify@ArcCos@%%% Out[114]= {ArcCos[-(1/6)+(7/2 (1+3 I Sqrt[3]))^(1/3)/(6 I^(4/3))+1/6 I^(4/3) 2.37\[Ellipsis]-1.18\[Ellipsis] I], ArcCos[-(1/6)+1/6 (7/2 (1+3 I Sqrt[3]))^(1/3) I^(4/3)+2.37\[Ellipsis]-1.18\[Ellipsis] I/(6 I^(4/3))], 2π/7}.
Disclaimer: For sufficiently exotic coefficients, WorkingPrecision->33 would need to increase, But I'm surprised that such a concise formula isn't more popular. —rwg
participants (2)
-
Bill Gosper -
Cris Moore