(*^ ::[ 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; showRuler; automaticGrouping; currentKernel; ] :[font = section; inactive; Cclosed; preserveAspect; startGroup] Solutions in radicals :[font = text; inactive; preserveAspect] This is an implementation of an algorithm for solving quintics in radicals, published by David Dummit : "Solving Solvable Quintics", Math. of Comp. 57, 387 (1991). :[font = input; preserveAspect] SolvableQ::usage = "SolvableQ[poly, x] yields True if poly, a quintic in the variable x, is solvable in radicals, and yields False otherwise."; :[font = input; preserveAspect] SolveQuintic::usage = "RadicalQuinticSolve[lhs == rhs, x] attempts to solve the reduced quintic lhs == rhs in the variable x in terms of radicals."; :[font = input; preserveAspect] SolveQuintic::rad = "This quintic is unsolvable in radicals."; :[font = input; preserveAspect] SolvableQ[e_, x_] := QuinticByRadicalsQ[e, x]//First :[font = input; preserveAspect] QuinticByRadicalsQ[expr_, x_] := Module[ {coefs, factor}, If[ Head[factor=Factor[expr]] === Times && Length[Complement[Exponent[#, x]&/@(List@@factor), {0,5}]] > 0 , Return[{True, $Failed}] ]; coefs = CoefficientList[expr, x]; If[ And@@((# === Integer || # === Rational)&/@(Head/@coefs)) , If[ Last[coefs] =!= 1 , coefs = coefs/Last[coefs] ]; If[ coefs[[-2]] =!= 0 , Return[ QuinticByRadicalsQ[expr/. x->x-coefs[[-2]]/(5 coefs[[-1]]), x] ] ]; factor = Factor[resolvent @@ Append[Drop[coefs, -2]/Last[coefs], x]]; If[ Head[factor] === Times , If[ MemberQ[Exponent[#, x]& /@ (List@@factor), 1] , {True, (Cases[factor, p_. x + r_.][[1]])/. {p_. x + r_. :> -r/p} } , {False, $Failed} ] , {False, $Failed} ] , {False, $Failed} ] ]/; PolynomialQ[expr, x] && Exponent[expr, x] == 5 :[font = input; preserveAspect] resolvent[s_,r_,q_,p_,x_] := x^6+8r x^5+(2p q^2-6p^2 r+40r^2-50q s) x^4 + (-2q^4+21p q^2 r-40p^2 r^2 +160r^3-15p^2 q s-400q r s+ 125p s^2) x^3+(p^2 q^4-6p^3 q^2 r-8 q^4 r+9p^4 r^2+ 76p q^2 r^2-136p^2 r^3+400 r^4-50p q^3 s+90p^2 q r s- 1400q r^2 s+625q^2 s^2+500p r s^2) x^2+(-2p q^6+19p^2 q^4 r- 51p^3 q^2 r^2+3q^4 r^2+32p^4 r^3+76p q^2 r^3-256p^2 r^4+ 512r^5-31p^3 q^3 s-58q^5 s+117p^4 q r s+105p q^3 r s+ 260p^2 q r^2 s-2400q r^3 s-108p^5 s^2-325p^2 q^2 s^2+ 525p^3 r s^2+2750q^2 r s^2-500p r^2 s^2+625 p q s^3- 3125s^4) x +(q^8-13p q^6 r+p^5 q^2 r^2+65 p^2 q^4 r^2- 4p^6 r^3-128 p^3 q^2 r^3 + 17 q^4 r^3+48 p^4 r^4-16p q^2 r^4- 192 p^2 r^5+256r^6-4p^5 q^3 s- 12p^2 q^5 s+18 p^6 q r s+ 12p^3 q^3 r s-124 q^5 r s+196 p^4 q r^2 s +590p q^3 r^2 s- 160 p^2 q r^3 s-1600q r^4 s-27p^7 s^2-150p^4 q^2 s^2 - 125p q^4 s^2 - 99 p^5 r s^2 - 725 p^2 q^2 r s^2 + 1200 p^3 r^2 s^2 +3250q^2 r^2 s^2-2000p r^3 s^2- 1250p q r s^3+3125p^2 s^4-9375 r s^4); :[font = input; preserveAspect] Discriminant[poly_, var_]:= Resultant[poly,D[poly,var],var]/Coefficient[poly,var,5] :[font = input; preserveAspect] SolveQuintic[a_ == b_, x_] := Module[ {temp}, temp = QuinticByRadicalsQ[a-b, x]; If[ temp[[1]] , If[ temp[[2]] === $Failed , Return[ Solve[ a == b, x] ] , If[ (# === Integer || # === Rational)& [Head[temp[[2]]]] , tosolve[a-b, x, temp[[2]]] , Message[Solve::rad]; Return[$Failed] ] ] , Message[Solve::rad]; Return[$Failed] ] ] :[font = input; preserveAspect] tosolve[pol_, x_, r_] := Module[ {coefs}, coefs = CoefficientList[pol, x]; If[ Last[coefs] =!= 1 , coefs = coefs/Last[coefs] ]; If[ coefs[[-2]] =!= 0 , coefs = CoefficientList[ pol/. x->x-coefs[[-2]]/(5 coefs[[-1]]), x] ]; If[ coefs[[3]] == coefs[[4]] == coefs[[5]] == 0 , canonicalQuintic[coefs[[2]], coefs[[1]], x, r, Sqrt[Discriminant[pol, x]]] , $Failed ] ] :[font = input; preserveAspect] canonicalQuintic[a_, b_, x_, r_, dis_] := Module[ {temp, l0, l1, l2, l3, l4}, temp = Roots[x^2 + (T1[a,b,r] + T2[a,b,r] dis) x + (T3[a,b,r] + T4[a,b,r] dis) == 0, x]; l1 = temp[[1,2]]/.Sqrt[w_] :> I Sqrt[-w]/; Negative[w]; l4 = temp[[2,2]]/.Sqrt[w_] :> I Sqrt[-w]/; Negative[w]; temp = Roots[x^2+(T1[a,b,r] - T2[a,b,r] dis) x + (T3[a,b,r] - T4[a,b,r] dis) == 0, x]; l2 = temp[[1,2]]/.Sqrt[w_] :> I Sqrt[-w]/; Negative[w]; l3 = temp[[2,2]]/.Sqrt[w_] :> I Sqrt[-w]/; Negative[w]; l0 = Expand[-(l1+l2+l3+l4)]; If[ (Expand[(l1-l4)(l2-l3) - V[a,b,r] dis]/. Sqrt[w_] :> Sqrt[w//Expand]) =!= 0, temp = l1; l1 = l4; l4 = temp ]; Inner[List[Rule[#1,#2]]&,Table[x,{5}], LagrangeResolvent[{l0,l1,l2,l3,l4}],List] ] :[font = input; preserveAspect] LagrangeResolvent[{l0_,l1_,l2_,l3_,l4_}] := Module[{prim1,prim2,prim3,prim4,r1,r2,r3,r4,p,q}, prim1 = (-q^2/Sqrt[5] + 2^(1/2)*I*p)/4; prim2 = (p^2/Sqrt[5] - 2^(1/2)*I*q)/4; prim3 = (p^2/Sqrt[5] + 2^(1/2)*I*q)/4; prim4 = (-q^2/Sqrt[5] - 2^(1/2)*I*p)/4; r1 = simp[{l0,l1,l2,l3,l4} . {1,prim1,prim2,prim3,prim4},p,q]; r2 = simp[{l0,l3,l1,l4,l2} . {1,prim1,prim2,prim3,prim4},p,q]; r3 = simp[{l0,l2,l4,l1,l3} . {1,prim1,prim2,prim3,prim4},p,q]; r4 = simp[{l0,l4,l3,l2,l1} . {1,prim1,prim2,prim3,prim4},p,q]; r1 = If[Positive[r1], r1^(1/5), -(-r1)^(1/5)]; r2 = If[Positive[r2], r2^(1/5), -(-r2)^(1/5)]; r3 = If[Positive[r3], r3^(1/5), -(-r3)^(1/5)]; r4 = If[Positive[r4], r4^(1/5), -(-r4)^(1/5)]; prim1 = (-1-5^(1/2)+2^(1/2)*I*(5-5^(1/2))^(1/2))/4; prim2 = (-1+5^(1/2)-2^(1/2)*I*(5+5^(1/2))^(1/2))/4; prim3 = (-1+5^(1/2)+2^(1/2)*I*(5+5^(1/2))^(1/2))/4; prim4 = (-1-5^(1/2)-2^(1/2)*I*(5-5^(1/2))^(1/2))/4; {{r1,r2,r3,r4} . {1,1,1,1}, {r1,r2,r3,r4} . {prim4,prim3,prim2,prim1}, {r1,r2,r3,r4} . {prim3,prim1,prim4,prim2}, {r1,r2,r3,r4} . {prim2,prim4,prim1,prim3}, {r1,r2,r3,r4} . {prim1,prim2,prim3,prim4} }/5 ] :[font = input; preserveAspect] simp[expr_, a_,b_] := Collect[expr, {a, b}]/.{ w_ a^2 :> Expand[w (5 - 5^(1/2))], w_ b^2 :> Expand[w (5 + 5^(1/2))] } /.{ a -> (5 - 5^(1/2))^(1/2), b -> (5 + 5^(1/2))^(1/2) } /.{Sqrt[w_] :> Sqrt[w//Expand]} :[font = input; preserveAspect] T1[a_, b_, r_] := (512 a^5 - 15625 b^4 + 768 a^4 r + 416a^3 r^2 + 112 a^2 r^3 + 24 a r^4 + 4 r^5)/(50 b^3); T2[a_, b_, r_] := (3840 a^5 - 78125b^4+4480a^4 r +2480a^3 r^2 + 760a^2 r^3+ 140a r^4+30r^5)/(512a^5 b + 6250 b^5); T3[a_, b_, r_] := (-18880 a^5 + 781250b^4-34240a^4 r-21260a^3 r^2- 5980a^2 r^3-1255 a r^4-240r^5)/(2 b^2); T4[a_, b_, r_] := (68800 a^5+25000a^4 r + 11500a^3 r^2+3250a^2 r^3+ 375 a r^4+100 r^5)/(512 a^5+6250 b^4); V[a_, b_, r_] := (-1036800 a^5+48828125 b^4-2280000a^4 r- 1291500a^3 r^2-399500a^2 r^3-76625a r^4-16100r^5)/ (256a^5+3125b^4); :[font = subsection; inactive; preserveAspect; startGroup] Example :[font = input; preserveAspect] SolvableQ[x^5 + 20 x + 32, x] :[font = input; preserveAspect] ??SolvableQ :[font = input; preserveAspect] SolveQuintic[x^5 + 20 x + 32 == 0, x] :[font = input; preserveAspect] N[%] :[font = input; preserveAspect] NRoots[x^5 + 20 x + 32 == 0, x] :[font = input; preserveAspect; endGroup; endGroup] SolveQuintic[x^5 + 20 x + 31 == 0, x] ^*)