(*^ ::[ Information = "This is a Mathematica Notebook file. It contains ASCII text, and can be transferred by email, ftp, or other text-file transfer utility. It should be read or edited using a copy of Mathematica or MathReader. If you received this as email, use your mail application or copy/paste to save everything from the line containing (*^ down to the line containing ^*) into a plain text file. On some systems you may have to give the file a name ending with ".ma" to allow Mathematica to recognize it as a Notebook. The line below identifies what version of Mathematica created this file, but it can be opened using any other version as well."; FrontEndVersion = "NeXT Mathematica Notebook Front End Version 2.2"; NeXTStandardFontEncoding; fontset = title, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, L1, e8, 24, "Times"; ; fontset = subtitle, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, L1, e6, 18, "Times"; ; fontset = subsubtitle, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, italic, L1, e6, 14, "Times"; ; fontset = section, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, grayBox, M22, bold, L1, a20, 18, "Times"; ; fontset = subsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, blackBox, M19, bold, L1, a15, 14, "Times"; ; fontset = subsubsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, whiteBox, M18, bold, L1, a12, 12, "Times"; ; fontset = text, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = smalltext, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 10, "Times"; ; fontset = input, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeInput, M42, N23, bold, L1, 12, "Courier"; ; fontset = output, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5, 12, "Courier"; ; fontset = message, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1, 12, "Courier"; ; fontset = print, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1, 12, "Courier"; ; fontset = info, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1, 12, "Courier"; ; fontset = postscript, PostScript, formatAsPostScript, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeGraphics, M7, l34, w282, h287, L1, 12, "Courier"; ; fontset = name, inactive, noPageBreakInGroup, nohscroll, preserveAspect, M7, italic, B65535, L1, 10, "Times"; ; fontset = header, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, italic, L1, 12, "Times"; ; fontset = leftheader, 12; fontset = footer, inactive, nohscroll, noKeepOnOnePage, preserveAspect, center, M7, italic, L1, 12, "Times"; ; fontset = leftfooter, 12; fontset = help, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = clipboard, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = completions, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12, "Courier"; ; fontset = special1, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special2, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special3, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special4, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special5, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; paletteColors = 128; automaticGrouping; currentKernel; ] :[font = subsection; inactive; preserveAspect; startGroup] Tschirnhaus' transformation :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] Calculating power sums with Newton's relations :[font = text; inactive; preserveAspect] We first need to implement a function for the sum s(n) of the n-th powers of all of the roots of a quintic equation a0 x^5 + a1 x^4 + a2 x^3 + a3 x^2 + a4 x + a5 = 0. In general Newton's relations are given recursively by s(n) = - (a1 s(n-1) + a2 s(n-2) + ... + an-1 s(1) + an n)/a0. We implement this in the function: :[font = input; preserveAspect] Psi[q_, x_, n_Integer] := Psi[q, x, n] = -(n Coefficient[q, x, 5-n] + Sum[Psi[q, x, n-j] Coefficient[q, x, 5-j], {j, n-1}]) / Coefficient[q, x, 5] :[font = text; inactive; preserveAspect] It is interesting that it is not necessary to solve the quintic to find the roots explicitly; the coefficients of the quintic have all the information we need. Let us give an example. Here is a quintic equation: :[font = input; Cclosed; preserveAspect; startGroup] r = (2. - 2.x + 4.x^2 + x^3 + 5.x^4 - 7x^5 == 0) :[font = output; output; inactive; preserveAspect; endGroup] 2. - 2.*x + 4.*x^2 + x^3 + 5.*x^4 - 7*x^5 == 0 ;[o] 2 3 4 5 2. - 2. x + 4. x + x + 5. x - 7 x == 0 :[font = text; inactive; preserveAspect] Here we calculate the first ten power sums with Psi: ;[s] 3:0,0;48,1;51,2;53,-1; 3:1,11,8,Times,0,12,0,0,0;1,10,8,Courier,1,12,0,0,0;1,11,8,Times,0,12,0,0,0; :[font = input; Cclosed; preserveAspect; startGroup] Table[Psi[r[[1]], x, i], {i, 10}] :[font = output; output; inactive; preserveAspect; endGroup] {0.7142857142857144, 0.7959183673469389, 2.384839650145772, 1.082465639316951, 2.793181412506693, 3.489209428044437, 3.055892649199859, 4.649449477961164, 5.262649457829135, 5.970601618975827} ;[o] {0.714286, 0.795918, 2.38484, 1.08247, 2.79318, 3.48921, 3.05589, 4.64945, 5.26265, 5.9706} :[font = text; inactive; preserveAspect] For comparison, we find the roots numerically and calculate the same power sums by brute force: :[font = input; Cclosed; preserveAspect; startGroup] roots = x /. NSolve[r, x] :[font = output; output; inactive; preserveAspect; endGroup] {-0.5271099650163091 - 0.6505021020228447*I, -0.5271099650163091 + 0.6505021020228447*I, 0.283532136767416 - 0.5087768696637565*I, 0.283532136767416 + 0.5087768696637565*I, 1.2014413707835} ;[o] {-0.52711 - 0.650502 I, -0.52711 + 0.650502 I, 0.283532 - 0.508777 I, 0.283532 + 0.508777 I, 1.20144} :[font = input; Cclosed; preserveAspect; startGroup] Table[Plus @@ (roots^i), {i, 10}] // Chop :[font = output; output; inactive; preserveAspect; endGroup; endGroup] {0.7142857142857143, 0.7959183673469387, 2.384839650145771, 1.082465639316951, 2.793181412506692, 3.489209428044434, 3.055892649199857, 4.64944947796116, 5.262649457829129, 5.970601618975821} ;[o] {0.714286, 0.795918, 2.38484, 1.08247, 2.79318, 3.48921, 3.05589, 4.64945, 5.26265, 5.9706} :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] Transformation to a principal quintic :[font = text; inactive; preserveAspect] We will show how to transform a quintic a0 x^5 + a1 x^4 + a2 x^3 + a3 x^2+ a4 x + a5 = 0 to one of the form y^5 + b3 y^2 + b4 y + b5 = 0. Newton's relations for the yj in terms of the bj is a linear system in the bj; solving for the bj expresses them in terms of the power sums s(n, yj). We will show that these power sums can be expressed in terms of the aj, so that the bj will be expressed in terms of the aj. For a quintic to have no quartic or cubic term it is necessary that the sums of the roots and the sums of the squares of the roots vanish: s(1, yj) = 0, s(2, yj) = 0 (*). Assume that the roots yj of the new quintic are related to the roots xj of the original quintic by yj = xj^2 + alpha xj + beta. Substituting this into (*) yields two equations for alpha and beta which can be multiplied out, simplified by using Newton's relations for the power sums in the xj, and finally solved, so that alpha and beta can be expressed using radicals in terms of the coefficients aj. Again by substitution into (*), we can calculate s(3, yj), s(4, yj), s(5, yj) in terms of alpha and beta and the xj; by the previous solution for alpha and beta and again by using Newton's relations for the power sums in the xj we can ultimately express these power sums in terms of the aj. We implement this in the following definition. The result is a list with two elements; the first element is the transformation of the roots as a pure function and the second element is the new quintic. :[font = input; preserveAspect] PrincipalTransform[p_ == 0, x_, y_]:= Module[{alpha, beta, xi}, {alpha, beta} = {alpha, beta} /. Last[Solve[ {5 (xi^2+ alpha xi + beta) == 0, Expand[5 (xi^2 + alpha xi + beta)^2] == 0} /. xi^n_.->1/5 Psi[p, x, n],{alpha, beta}]]; { Evaluate[#^2 + alpha # + beta]&, (y^5 - Sum[y^(5-j)/j Collect[(xi^2 + alpha xi + beta)^j + 4 beta^j, xi] /. xi^n_. -> Psi[p, x, n], {j, 3, 5}]) == 0 } ] /; MatchQ[CoefficientList[p, x], {_, _, _, _, _?(# =!= 0 &), _}] :[font = text; inactive; preserveAspect] As an example we use the same equation r as above. The principal quintic of r is: :[font = input; Cclosed; preserveAspect; startGroup] p = PrincipalTransform[r, x, y] :[font = output; output; inactive; preserveAspect; endGroup] {-0.1280903945728591 - 0.2176529522757005*#1 + #1^2 & , -0.125070426200835 - 0.4881212621975397*y - 0.5947058416083326*y^2 + y^5 == 0} ;[o] 2 {-0.12809 - 0.217653 #1 + #1 & , 2 5 -0.12507 - 0.488121 y - 0.594706 y + y == 0} :[font = text; inactive; preserveAspect] Applying the pure function (the first element of this result) to the roots xi of the old equation gives the roots of the transformed equation yi: :[font = input; Cclosed; preserveAspect; startGroup] (First[p] /@ roots) // Sort :[font = output; output; inactive; preserveAspect; endGroup] {-0.3682654317302792 - 0.1777723982552981*I, -0.3682654317302792 + 0.1777723982552981*I, -0.158671424029763 - 0.827355983447415*I, -0.158671424029763 + 0.827355983447415*I, 1.053873711520084} ;[o] {-0.368265 - 0.177772 I, -0.368265 + 0.177772 I, -0.158671 - 0.827356 I, -0.158671 + 0.827356 I, 1.05387} :[font = text; inactive; preserveAspect] Solving numerically gives us a check: :[font = input; Cclosed; preserveAspect; startGroup] NSolve[Last[p], y] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] {{y -> -0.3682654317302791 - 0.1777723982552981*I}, {y -> -0.3682654317302791 + 0.1777723982552981*I}, {y -> -0.1586714240297631 - 0.827355983447416*I}, {y -> -0.1586714240297631 + 0.827355983447416*I}, {y -> 1.053873711520084}} ;[o] {{y -> -0.368265 - 0.177772 I}, {y -> -0.368265 + 0.177772 I}, {y -> -0.158671 - 0.827356 I}, {y -> -0.158671 + 0.827356 I}, {y -> 1.05387}} :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] Transformation to a Bring-Jerrard quintic :[font = text; inactive; preserveAspect] We can also use a Tschirnhaus transformation to take a quintic y^5 + b3 y^2 + b4 y + b5 = 0 to one of the form z^5 + c4 z + c5 = 0. Now the sum of the third powers of the roots has to vanish as well: s(3, yj) = 0. We assume that the roots zi of the new Bring-Jerrard quintic are related to the roots yi of the principal quintic by zi = alpha yi^4 + beta yi^3 + gamma yi^2 + delta yi + epsilon. In a similar way to the previous reduction we can express the coefficients cj in terms of the bj. This is implemented in the following definition. The result is a list with two elements; the first element is the transformation of the roots as a pure function and the second element is the new quintic. :[font = input; preserveAspect] BringJerrardTransform[p_ == 0, y_, z_] := Module[{alpha, beta, gamma, delta, epsilon, kappa, lambda, mu, nu, psi, xi, zeta, a, b, c, g, h}, psi[t_] := Expand[5t]/.xi^n_. -> Psi[p, y, n]/5; {a, b, c} = Map[Psi[p, y, #]&, {3, 4, 5}]; g=5a xi^3 - 5 b xi^2 - a^2; h = 5 a xi^4 - 5 c xi^2 - a b; {lambda, mu, nu} = Map[psi, {g^2, 2 g h, h^2}]; kappa = -mu/(2 lambda) + Sqrt[mu^2/(4 lambda^2) - nu/lambda]; delta = Solve[psi[(zeta xi+ kappa g + h)^3] == 0, zeta][[1, 1, 2]]; alpha = 5a; beta = 5a kappa; gamma = -5b kappa-5 c; epsilon = -a^2 kappa- a b; { Evaluate[alpha #^4 + beta #^3 + gamma #^2 + delta # + epsilon]&, z^5 - Sum[z^(5-j)/j Collect[psi[(delta xi + kappa g + h)^j],xi],{j,4,5}] == 0 } ]/; MatchQ[CoefficientList[p, y],{_, _, _, 0, 0, _}] :[font = text; inactive; preserveAspect] We continue our example: :[font = input; Cclosed; preserveAspect; startGroup] b = BringJerrardTransform[p[[2]], y, z] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] {-2.608160064963465 - 6.264025500853689*#1 - 0.4422255673142468*#1^2 - 2.453041112377684*#1^3 + 8.92058762412499*#1^4 & , 6.683570234221407 - 1.784678302902648*z + z^5 == 0} ;[o] 2 3 {-2.60816 - 6.26403 #1 - 0.442226 #1 - 2.45304 #1 + 4 5 8.92059 #1 & , 6.68357 - 1.78468 z + z == 0} :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] Canonical quintic :[font = text; inactive; preserveAspect] A Bring-Jerrard quintic has the form z^5 + c4 z + c5 = 0. It is possible to write such a quintic by a simple rescaling in the form t^5 - t - r = 0, a canonical quintic. (It is not possible to transform a sextic to another that depends on only one parameter.) :[font = input; preserveAspect] CanonicalTransform[z_^5 + e_. z_ + f_ == 0, z_, t_] := {#/(-e)^(1/4)&, t^5 - t + f/(-e)^(5/4) == 0} :[font = text; inactive; preserveAspect] Here is our example reduced to a canonical quintic: :[font = input; Cclosed; preserveAspect; startGroup] c = CanonicalTransform[b[[2]], z, t] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] {#1/(--1.784678302902648)^(1/4) & , 3.24010128563984 - t + t^5 == 0} ;[o] #1 5 {-------------- & , 3.2401 - t + t == 0} 1/4 (--1.78468) :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] Transforming back :[font = text; inactive; preserveAspect] After having solved a canonical quintic via Hermite's method or with hypergeometric functions, or a principal quintic via Klein's approach, it is necessary to reverse the Tschirnhaus transformations to get back to the roots of the original quintic. Since these polynomial transformations are nonlinear inverting them will give mutiple roots; the spurious ones can be eliminated by seeing which one satisfies the original equation. The following function implements this. The original polynomial is p and s is the list of candidate solutions. :[font = input; preserveAspect] ChooseRoot[p_, s_] := s[[Position[#, Min[#]][[1, 1]]&[Abs[p /. s]]]] :[font = text; inactive; preserveAspect] These are the solutions of t^5 -t + 3.24201 = 0: :[font = input; preserveAspect] tau = {-1.356724, -0.317423 - 1.26515 I, -0.317425 + 1.26515 I, 0.9957874 - 0.64192 I, 0.9957874 + 0.64192 I}; :[font = text; inactive; preserveAspect] These are the solutions of the Bring-Jerrard quintic: :[font = input; Cclosed; preserveAspect; startGroup] zeta = Table[Solve[First[c][z] == tau[[i]], z][[1, 1, 2]], {i, 5}] :[font = output; output; inactive; preserveAspect; endGroup] {-1.568127942320668, -0.3668836667113233 - 1.462284935054582*I, -0.3668859783501567 + 1.462284935054582*I, 1.150950411838257 - 0.7419435999764751*I, 1.150950411838257 + 0.7419435999764751*I} ;[o] {-1.56813, -0.366884 - 1.46228 I, -0.366886 + 1.46228 I, 1.15095 - 0.741944 I, 1.15095 + 0.741944 I} :[font = text; inactive; preserveAspect] These are the solutions of the principal quintic: :[font = input; Cclosed; preserveAspect; startGroup] eta = Table[ChooseRoot[p[[2, 1]], Solve[First[b][y] == zeta[[i]], y] ][[1, 2]], {i, 5}] :[font = output; output; inactive; preserveAspect; endGroup] {1.053873724882538, -0.3682651702984545 + 0.1777709639429517*I, -0.3682649028302858 - 0.1777710816675959*I, -0.1586718791391074 + 0.827356255681592*I, -0.1586718791391074 - 0.827356255681592*I} ;[o] {1.05387, -0.368265 + 0.177771 I, -0.368265 - 0.177771 I, -0.158672 + 0.827356 I, -0.158672 - 0.827356 I} :[font = text; inactive; preserveAspect] Finally, these are the solutions of the original quintic: :[font = input; Cclosed; preserveAspect; startGroup] Sort[Table[ChooseRoot[r[[1]], Solve[First[p][x] == eta[[i]], x] ][[1, 2]], {i, 5}]] :[font = output; output; inactive; preserveAspect; endGroup] {-0.5271098971477955 - 0.6505023854878369*I, -0.5271098971477955 + 0.6505023854878369*I, 0.2835309547890224 + 0.508776206870753*I, 0.2835311390196337 - 0.5087760072777432*I, 1.201441376898397} ;[o] {-0.52711 - 0.650502 I, -0.52711 + 0.650502 I, 0.283531 + 0.508776 I, 0.283531 - 0.508776 I, 1.20144} :[font = text; inactive; preserveAspect] This checks with the direct numerical solution of the original quintic: :[font = input; Cclosed; preserveAspect; startGroup] x /. NSolve[r, x] :[font = output; output; inactive; preserveAspect; endGroup; endGroup; endGroup] {-0.5271099650163091 - 0.6505021020228447*I, -0.5271099650163091 + 0.6505021020228447*I, 0.283532136767416 - 0.5087768696637565*I, 0.283532136767416 + 0.5087768696637565*I, 1.2014413707835} ;[o] {-0.52711 - 0.650502 I, -0.52711 + 0.650502 I, 0.283532 - 0.508777 I, 0.283532 + 0.508777 I, 1.20144} ^*)