6
$\begingroup$

This question was originally asked by @fsrong70 six months ago. The OP deleted it shortly after posting and has not returned to this site since. I had just figured it out when it was deleted. I waited to see if the OP would repost it, but not yet. So I'm posting it with my solution.


Considering the solution to the following equation

$x^7+x^6-18 x^5-35 x^4+38 x^3+104 x^2+7 x-49=0$

poly = x^7 + x^6 - 18 x^5 - 35 x^4 + 38 x^3 + 104 x^2 + 7 x - 49;

This problem could be solved using notions from Galois theory and the Galois group of a polynomial, and the 43rd root of unity ($\displaystyle e^\frac{2i\pi}{43}$) .

The solutions are expressed in terms of trigonometric (cosine) functions. The seven solutions are:

$\displaystyle \alpha_1 = 2\cos(\frac{2\pi}{43}) + 2\cos(\frac{12\pi}{43}) + 2\cos(\frac{14\pi}{43})$

$\displaystyle \alpha_2 =2\cos(\frac{4\pi}{43}) + 2\cos(\frac{24\pi}{43}) + 2\cos(\frac{28\pi}{43})$

$\displaystyle \alpha_3 = 2\cos(\frac{6\pi}{43}) + 2\cos(\frac{36\pi}{43}) + 2\cos(\frac{42\pi}{43})$

$\displaystyle \alpha_4 =2\cos(\frac{8\pi}{43}) + 2\cos(\frac{30\pi}{43}) + 2\cos(\frac{38\pi}{43})$

$\displaystyle \alpha_5 =2\cos(\frac{10\pi}{43}) + 2\cos(\frac{16\pi}{43}) + 2\cos(\frac{24\pi}{43})$

$\displaystyle \alpha_6 =2\cos(\frac{18\pi}{43}) + 2\cos(\frac{22\pi}{43}) + 2\cos(\frac{40\pi}{43})$

$\displaystyle \alpha_7 =2\cos(\frac{20\pi}{43}) + 2\cos(\frac{32\pi}{43}) + 2\cos(\frac{34\pi}{43})$

Might this problem be entirely solved and the symbolic solutions computed with Mathematica?

This problem was asked and solved on Quora, but not in relation to Mathematica.

$\endgroup$
8
$\begingroup$
poly = x^7 + x^6 - 18 x^5 - 35 x^4 + 38 x^3 + 104 x^2 + 7 x - 49;

Find an extension in which the polynomial splits:

PrintTemporary@Dynamic@{Clock[Infinity], n};
Catch[
  Do[
   fl = DeleteCases[
     FactorList[poly, Extension -> Exp[2 Pi*I/n]], {_?NumericQ, _Integer}];
   If[Total[fl[[All, 2]]] > 1, Throw[n -> fl]], {n, 
    Rest@Divisors@Discriminant[poly, x]}]
  ] // AbsoluteTiming

Mathematica graphics

Solve:

Apply[Join, Solve[First@# == 0, x] & /@ fl]

Mathematica graphics

Cosmetic clean-up:

roots = Expand[
    Apply[Join, Solve[First@# == 0, x] & /@ fl] /. -1 + rest__ :> 
      Simplify[Sum[2 Cos[2 Pi/43*k], {k, 21}] + rest]
    ] /. {2 Sin[t_] :> 2 Inactive[Cos][Pi/2 - t],
         -2 Sin[t_] :> 2 Inactive[Cos][Pi/2 + t],
         -2 Cos[t_] :> 2 Inactive[Cos][Pi + t],
          2 Cos[t_] :> 2 Inactive[Cos][t]} // 
  SortBy[Min@Cases[#, Inactive[Cos][t_] :> N@t, Infinity] &]

Mathematica graphics

Note there's an error in $a_5$ in the OP.

Update: Here's the fastest way I've found to verify:

FullSimplify@TrigToExp@Activate[poly /. roots] // AbsoluteTiming
(*  {4.84673, {0, 0, 0, 0, 0, 0, 0}}  *)
$\endgroup$
  • 1
    $\begingroup$ Note that substituting the roots into poly and using Simplify to see if they satisfy it takes a very long time. (Using N after substituting gives verification almost immediately, rhough.) $\endgroup$ – murray Jan 12 at 20:59
  • $\begingroup$ @murray Yes, it does. This is a bit faster: FullSimplify @ TrigToExp@Activate[poly /. roots]. $\endgroup$ – Michael E2 Jan 12 at 21:01

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.