(************** Content-type: application/mathematica ************** Mathematica-Compatible Notebook This notebook can be used with any Mathematica-compatible application, such as Mathematica, MathReader or Publicon. The data for the notebook starts with the line containing stars above. To get the notebook into a Mathematica-compatible application, do one of the following: * Save the data starting with the line of stars above into a file with a name ending in .nb, then open the file inside the application; * Copy the data starting with the line of stars above to the clipboard, then use the Paste menu command inside the application. Data for notebooks contains only printable 7-bit ASCII and can be sent directly in email or through ftp in text mode. Newlines can be CR, LF or CRLF (Unix, Macintosh or MS-DOS style). NOTE: If you modify the data for this notebook not in a Mathematica- compatible application, you must delete the line below containing the word CacheID, otherwise Mathematica-compatible applications may try to use invalid cache data. For more information on notebooks and Mathematica-compatible applications, contact Wolfram Research: web: http://www.wolfram.com email: info@wolfram.com phone: +1-217-398-0700 (U.S.) Notebook reader applications are available free of charge from Wolfram Research. *******************************************************************) (*CacheID: 232*) (*NotebookFileLineBreakTest NotebookFileLineBreakTest*) (*NotebookOptionsPosition[ 31907, 701]*) (*NotebookOutlinePosition[ 32573, 724]*) (* CellTagsIndexPosition[ 32529, 720]*) (*WindowFrame->Normal*) Notebook[{ Cell[BoxData[ \(\(\( (*\ \[IndentingNewLine]ToSymbolic\ Version\ 0.1\[IndentingNewLine]\ \ Copyright\ 2001 - 2002\ Chris\ Becker\ \[IndentingNewLine]\ \(All\ code\ used\ by\ \ other\ authors\ is\ noted\), \ all\ of\ which\ came\ from\ MathSource . com\ \[IndentingNewLine]\[IndentingNewLine]\ The\ purpose\ of\ ToSymbolic\ is\ to\ analyze\ a\ Root\ object\ and\ \ see\ if\ it\ can\ convert\ it\ to\ a\ symbolic\ solution, \ a\ lot\ like\ ToRadicals\ except\ that\ it\ will\ work\ on\ higher\ \ order\ functions . \ The\ goal\ of\ this\ is\ to\ further\ the\ symbolic\ capabilities\ \ of\ mathematica\ in\ such\ things\ as\ Solve, \ DSolve\ and\ RSolve . \[IndentingNewLine]\[IndentingNewLine]ToSymbolic\ \ will\ convert\ these\ types\ of\ \(equations : \[IndentingNewLine]Most\ \ Quintic\ Equations\), \ in\ radicals\ if\ possible . \ \[IndentingNewLine]\[IndentingNewLine]\(NOTE : \ There\ probably\ are\ bugs\ in\ this\ and\ the\ outputs\ can\ be\ \ very\ very\ large\ so\ save\ your\ work\ before\ using\ this . \ Also\), \ make\ sure\ you\ check\ your\ answers\ numerically, \ it\ may\ not\ give\ the\ correct\ result . \[IndentingNewLine]\ \[IndentingNewLine]\(USAGE : \ Just\ like\ ToRadicals . \ ToSymbolic[ Solve[x^5 - x - 1 \[Equal] 0, x]]\)\[IndentingNewLine]\[IndentingNewLine]\t\ \ \[IndentingNewLine]*) \)\(\[IndentingNewLine]\)\(\ \)\)\)], "Input", FontWeight->"Plain", FontVariations->{"CompatibilityType"->0}], Cell[CellGroupData[{ Cell[BoxData[ \( (*\ All\ Quintic\ Functions\ *) \)], "Input"], Cell[BoxData[ \( (*\ Everything\ here\ except\ SolveHermite\ and\ ChooseRoot2\ was\ obtain\ \ from\ MathSource\ *) \)], "Input"], Cell[BoxData[ \(HermiteQuinticSolve[t_\^5 - t_ + \[Rho]_ == 0, t_] := \n\t Module[{k, b, q, \[CurlyPhi] = InverseEllipticNomeQ}, k = Tan[1\/4\ ArcSin[16\/\(25\ \@5\ \[Rho]\^2\)]]; b = \(\((k\^2)\)\^\(1/8\)\ If[Re[\[Rho]] == 0, \(-Sign[Im[\[Rho]]]\), \ Sign[Re[\[Rho]]]]\)\/\(2\ 5\^\(3/4\)\ \@k\ \@\(1 - k\^2\)\); q = EllipticNomeQ[ k\^2]; \({t \[Rule] #} &\) /@ {b\ \((\((\(-1\))\)\^\(3/4\)\ \((\ \[CurlyPhi][\(q\^\(1/5\)\) \[ExponentialE]\^\(\(-\(1\/5\)\)\ 2\ I\ \[Pi]\)]\^\ \(1/8\) + I\ \[CurlyPhi][\[ExponentialE]\^\(1\/5\ 2\ I\ \[Pi]\)\ \ q\^\(1/5\)]\^\(1/8\))\)\ \((\[CurlyPhi][\(q\^\(1/5\)\) \[ExponentialE]\^\(\(-\ \(1\/5\)\)\ 4\ I\ \[Pi]\)]\^\(1/8\) + \[CurlyPhi][\[ExponentialE]\^\(1\/5\ 4\ \ I\ \[Pi]\)\ q\^\(1/5\)]\^\(1/8\))\)\ \((\[CurlyPhi][q\^\(1/5\)]\^\(1/8\) + \(\ \[CurlyPhi][q\^5]\^\(1/8\)\ q\^\(5/8\)\)\/\((q\^5)\)\^\(1/8\))\))\), b\ \((\(-\[CurlyPhi][q\^\(1/5\)]\^\(1/8\)\) + \ \[ExponentialE]\^\(1\/4\ 3\ I\ \[Pi]\)\ \[CurlyPhi][\[ExponentialE]\^\(1\/5\ \ 2\ I\ \[Pi]\)\ q\^\(1/5\)]\^\(1/8\))\)\ \((\(\[CurlyPhi][\(q\^\(1/ 5\)\) \[ExponentialE]\^\(\(-\(1\/5\)\)\ 2\ \ I\ \[Pi]\)]\^\(1/8\)\) \[ExponentialE]\^\(\(-\(1\/4\)\)\ 3\ I\ \[Pi]\) + I\ \[CurlyPhi][\[ExponentialE]\^\(1\/5\ 4\ I\ \[Pi]\)\ \ q\^\(1/5\)]\^\(1/8\))\)\ \((I\ \[CurlyPhi][\(q\^\(1/5\)\) \[ExponentialE]\^\(\ \(-\(1\/5\)\)\ 4\ I\ \[Pi]\)]\^\(1/8\) + \(\[CurlyPhi][q\^5]\^\(1/8\)\ \ q\^\(5/8\)\)\/\((q\^5)\)\^\(1/8\))\), b\ \((\(\[CurlyPhi][\(q\^\(1/ 5\)\) \[ExponentialE]\^\(\(-\(1\/5\)\)\ 2\ \ I\ \[Pi]\)]\^\(1/8\)\) \[ExponentialE]\^\(\(-\(1\/4\)\)\ 3\ I\ \[Pi]\) - I\ \[CurlyPhi][\(q\^\(1/5\)\) \ \[ExponentialE]\^\(\(-\(1\/5\)\)\ 4\ I\ \[Pi]\)]\^\(1/8\))\)\ \((\(-\ \[CurlyPhi][q\^\(1/5\)]\^\(1/8\)\) - I\ \[CurlyPhi][\[ExponentialE]\^\(1\/5\ 4\ I\ \[Pi]\)\ \ q\^\(1/5\)]\^\(1/8\))\)\ \((\[CurlyPhi][\[ExponentialE]\^\(1\/5\ 2\ I\ \ \[Pi]\)\ q\^\(1/5\)]\^\(1/8\)\ \[ExponentialE]\^\(1\/4\ 3\ I\ \[Pi]\) + \(\ \[CurlyPhi][q\^5]\^\(1/8\)\ q\^\(5/8\)\)\/\((q\^5)\)\^\(1/8\))\), b\ \((\[CurlyPhi][q\^\(1/5\)]\^\(1/8\) - I\ \[CurlyPhi][\(q\^\(1/5\)\) \ \[ExponentialE]\^\(\(-\(1\/5\)\)\ 4\ I\ \[Pi]\)]\^\(1/8\))\)\ \((\(-\ \[CurlyPhi][\[ExponentialE]\^\(1\/5\ 2\ I\ \[Pi]\)\ q\^\(1/5\)]\^\(1/8\)\)\ \ \[ExponentialE]\^\(1\/4\ 3\ I\ \[Pi]\) - I\ \[CurlyPhi][\[ExponentialE]\^\(1\/5\ 4\ I\ \[Pi]\)\ \ q\^\(1/5\)]\^\(1/8\))\)\ \((\(\[CurlyPhi][\(q\^\(1/ 5\)\) \[ExponentialE]\^\(\(-\(1\/5\)\)\ 2\ \ I\ \[Pi]\)]\^\(1/ 8\)\) \[ExponentialE]\^\(\(-\(1\/4\)\)\ 3\ I\ \[Pi]\ \) + \(\[CurlyPhi][q\^5]\^\(1/8\)\ q\^\(5/8\)\)\/\((q\^5)\)\^\(1/8\))\), b\ \((\[CurlyPhi][q\^\(1/5\)]\^\(1/8\) - \(\[CurlyPhi][\(q\^\(1/ 5\)\) \[ExponentialE]\^\(\(-\(1\/5\)\)\ 2\ \ I\ \[Pi]\)]\^\(1/ 8\)\) \[ExponentialE]\^\(\(-\(1\/4\)\)\ 3\ I\ \[Pi]\ \))\)\ \((\(-\[CurlyPhi][\[ExponentialE]\^\(1\/5\ 2\ I\ \[Pi]\)\ \ q\^\(1/5\)]\^\(1/8\)\)\ \[ExponentialE]\^\(1\/4\ 3\ I\ \[Pi]\) + I\ \[CurlyPhi][\(q\^\(1/5\)\) \ \[ExponentialE]\^\(\(-\(1\/5\)\)\ 4\ I\ \[Pi]\)]\^\(1/8\))\)\ \((\(-I\)\ \ \[CurlyPhi][\[ExponentialE]\^\(1\/5\ 4\ I\ \[Pi]\)\ q\^\(1/5\)]\^\(1/8\) + \(\ \[CurlyPhi][q\^5]\^\(1/8\)\ q\^\(5/8\)\)\/\((q\^5)\)\^\(1/8\))\)}]\)], "Input"], Cell[BoxData[ \(CanonicalTransform[z_^5 + e_. \ z_ + f_ \[Equal] 0, z_, t_] := {#/\((\(-e\))\)^\((1/4)\) &, t^5 - t + f/\((\(-e\))\)^\((5/4)\) \[Equal] 0}\)], "Input"], Cell[BoxData[ \(\(SolvableQ::"\" = "\";\)\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(\(SolveQuintic::"\" = "\";\)\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(\(SolveQuintic::"\" = "\";\)\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(SolvableQ[e_, x_] := First[QuinticByRadicalsQ[e, x]]\)], "Input", AspectRatioFixed->True], Cell[CellGroupData[{ Cell[BoxData[ \(QuinticByRadicalsQ[expr_, x_] := Module[{coefs, factor}, If[Head[factor = Factor[expr]] === Times && Length[Complement[\((Exponent[#1, x] &)\) /@ \(List @@ factor\), {0, 5}]] > 0, Return[{True, $Failed}]]; coefs = CoefficientList[expr, x]; If[And @@ \(\((#1 === Integer || #1 === Rational &)\) /@ \(Head /@ coefs\)\), If[Last[coefs] =!= 1, coefs = coefs\/Last[coefs]]; If[coefs\[LeftDoubleBracket]\(-2\)\[RightDoubleBracket] =!= 0, Return[QuinticByRadicalsQ[ expr /. x \[Rule] x - coefs\[LeftDoubleBracket]\(-2\)\[RightDoubleBracket]\ \/\(5\ coefs\[LeftDoubleBracket]\(-1\)\[RightDoubleBracket]\), x]]]; factor = Factor[resolvent @@ Append[Drop[coefs, \(-2\)]\/Last[coefs], x]]; If[Head[factor] === Times, If[MemberQ[\((Exponent[#1, x] &)\) /@ \(List @@ factor\), 1], {True, \(Cases[factor, p_. \ x + r_. ]\)\[LeftDoubleBracket]1\[RightDoubleBracket] /. \ {p_. \ x + r_. \[RuleDelayed] \(-\(r\/p\)\)}}, {False, \ $Failed}], {False, $Failed}], {False, $Failed}]] /; PolynomialQ[expr, x] && Exponent[expr, x] == 5\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(General::"spell1" \(\(:\)\(\ \)\) "Possible spelling error: new symbol name \"\!\(factor\)\" is similar \ to existing symbol \"\!\(Factor\)\"."\)], "Message"] }, Open ]], Cell[BoxData[ \(\(resolvent[s_, r_, q_, p_, x_] := x\^6 + 8\ r\ x\^5 + \((2\ p\ q\^2 - 6\ p\^2\ r + 40\ r\^2 - 50\ q\ s)\)\ x\^4 + \((\(-2\)\ q\^4 + 21\ p\ q\^2\ r - 40\ p\^2\ r\^2 + 160\ r\^3 - 15\ p\^2\ q\ s - 400\ q\ r\ s + 125\ p\ s\^2)\)\ x\^3 + \((p\^2\ q\^4 - 6\ p\^3\ q\^2\ r - 8\ q\^4\ r + 9\ p\^4\ r\^2 + 76\ p\ q\^2\ r\^2 - 136\ p\^2\ r\^3 + 400\ r\^4 - 50\ p\ q\^3\ s + 90\ p\^2\ q\ r\ s - 1400\ q\ r\^2\ s + 625\ q\^2\ s\^2 + 500\ p\ r\ s\^2)\)\ x\^2 + \((\(-2\)\ p\ q\^6 + 19\ p\^2\ q\^4\ r - 51\ p\^3\ q\^2\ r\^2 + 3\ q\^4\ r\^2 + 32\ p\^4\ r\^3 + 76\ p\ q\^2\ r\^3 - 256\ p\^2\ r\^4 + 512\ r\^5 - 31\ p\^3\ q\^3\ s - 58\ q\^5\ s + 117\ p\^4\ q\ r\ s + 105\ p\ q\^3\ r\ s + 260\ p\^2\ q\ r\^2\ s - 2400\ q\ r\^3\ s - 108\ p\^5\ s\^2 - 325\ p\^2\ q\^2\ s\^2 + 525\ p\^3\ r\ s\^2 + 2750\ q\^2\ r\ s\^2 - 500\ p\ r\^2\ s\^2 + 625\ p\ q\ s\^3 - 3125\ s\^4)\)\ x + \((q\^8 - 13\ p\ q\^6\ r + p\^5\ q\^2\ r\^2 + 65\ p\^2\ q\^4\ r\^2 - 4\ p\^6\ r\^3 - 128\ p\^3\ q\^2\ r\^3 + 17\ q\^4\ r\^3 + 48\ p\^4\ r\^4 - 16\ p\ q\^2\ r\^4 - 192\ p\^2\ r\^5 + 256\ r\^6 - 4\ p\^5\ q\^3\ s - 12\ p\^2\ q\^5\ s + 18\ p\^6\ q\ r\ s + 12\ p\^3\ q\^3\ r\ s - 124\ q\^5\ r\ s + 196\ p\^4\ q\ r\^2\ s + 590\ p\ q\^3\ r\^2\ s - 160\ p\^2\ q\ r\^3\ s - 1600\ q\ r\^4\ s - 27\ p\^7\ s\^2 - 150\ p\^4\ q\^2\ s\^2 - 125\ p\ 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 + 3250\ q\^2\ r\^2\ s\^2 - 2000\ p\ r\^3\ s\^2 - 1250\ p\ q\ r\ s\^3 + 3125\ p\^2\ s\^4 - 9375\ r\ s\^4)\);\)\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(Discriminant[poly_, var_] := Resultant[poly, \[PartialD]\_var poly, var]\/Coefficient[poly, var, \ 5]\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(SolveQuintic[a_ == b_, x_] := Module[{temp}, temp = QuinticByRadicalsQ[a - b, x]; If[temp\[LeftDoubleBracket]1\[RightDoubleBracket], If[temp\[LeftDoubleBracket]2\[RightDoubleBracket] === $Failed, Return[Solve[a == b, x]], If[\((#1 === Integer || #1 === Rational &)\)[ Head[temp\[LeftDoubleBracket]2\[RightDoubleBracket]]], tosolve[a - b, x, temp\[LeftDoubleBracket]2\[RightDoubleBracket]], Message[Solve::"\"]; Return[$Failed]]], Message[Solve::"\"]; Return[$Failed]]]\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(tosolve[pol_, x_, r_] := Module[{coefs}, coefs = CoefficientList[pol, x]; If[Last[coefs] =!= 1, coefs = coefs\/Last[coefs]]; If[coefs\[LeftDoubleBracket]\(-2\)\[RightDoubleBracket] =!= 0, coefs = CoefficientList[ pol /. x \[Rule] x - coefs\[LeftDoubleBracket]\(-2\)\[RightDoubleBracket]\/\(\ 5\ coefs\[LeftDoubleBracket]\(-1\)\[RightDoubleBracket]\), x]]; If[coefs\[LeftDoubleBracket]3\[RightDoubleBracket] == coefs\[LeftDoubleBracket]4\[RightDoubleBracket] == coefs\[LeftDoubleBracket]5\[RightDoubleBracket] == 0, canonicalQuintic[coefs\[LeftDoubleBracket]2\[RightDoubleBracket], coefs\[LeftDoubleBracket]1\[RightDoubleBracket], x, r, \@Discriminant[pol, x]], $Failed]]\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(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\[LeftDoubleBracket]1, 2\[RightDoubleBracket] /. \@w_ \[RuleDelayed] I\ \@\(-w\) /; Negative[w]; l4 = temp\[LeftDoubleBracket]2, 2\[RightDoubleBracket] /. \@w_ \[RuleDelayed] I\ \@\(-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\[LeftDoubleBracket]1, 2\[RightDoubleBracket] /. \@w_ \[RuleDelayed] I\ \@\(-w\) /; Negative[w]; l3 = temp\[LeftDoubleBracket]2, 2\[RightDoubleBracket] /. \@w_ \[RuleDelayed] I\ \@\(-w\) /; Negative[w]; l0 = Expand[\(-\((l1 + l2 + l3 + l4)\)\)]; If[\((Expand[\((l1 - l4)\)\ \((l2 - l3)\) - V[a, b, r]\ dis] /. \@w_ \[RuleDelayed] \@Expand[w])\) =!= 0, temp = l1; l1 = l4; l4 = temp]; Inner[{#1 \[Rule] #2} &, Table[x, {5}], LagrangeResolvent[{l0, l1, l2, l3, l4}], List]]\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(LagrangeResolvent[{l0_, l1_, l2_, l3_, l4_}] := \n\t Module[{prim1, prim2, prim3, prim4, r1, r2, r3, r4, p, q}, prim1 = 1\/4\ \((\(-\(q\^2\/\@5\)\) + \@2\ I\ p)\); prim2 = 1\/4\ \((p\^2\/\@5 - \@2\ I\ q)\); prim3 = 1\/4\ \((p\^2\/\@5 + \@2\ I\ q)\); prim4 = 1\/4\ \((\(-\(q\^2\/\@5\)\) - \@2\ I\ p)\); r1 = simp[{l0, l1, l2, l3, l4} . {1, prim1, prim2, prim3, prim4}, p, q]; \n\ \ \ \ \ 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]; \n\t\tr1 = If[RootReduce[r1] > 0, r1\^\(1/5\), \(-\((\(-r1\))\)\^\(1/5\)\)]; r2 = If[RootReduce[r2] > 0, r2\^\(1/5\), \(-\((\(-r2\))\)\^\(1/5\)\)]; r3 = If[RootReduce[r3] > 0, r3\^\(1/5\), \(-\((\(-r3\))\)\^\(1/5\)\)]; r4 = If[RootReduce[r4] > 0, r4\^\(1/5\), \(-\((\(-r4\))\)\^\(1/5\)\)]; prim1 = 1\/4\ \((\(-1\) - \@5 + \@2\ I\ \@\(5 - \@5\))\); prim2 = 1\/4\ \((\(-1\) + \@5 - \@2\ I\ \@\(5 + \@5\))\); prim3 = 1\/4\ \((\(-1\) + \@5 + \@2\ I\ \@\(5 + \@5\))\); prim4 = 1\/4\ \((\(-1\) - \@5 - \@2\ I\ \@\(5 - \@5\))\); 1\/5\ {{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}}]\)], "Input", AspectRatioFixed->True], Cell[BoxData[ \(simp[expr_, a_, b_] := \(\(Collect[ expr, {a, b}] /. {w_\ a\^2 \[RuleDelayed] Expand[w\ \((5 - \@5)\)], w_\ b\^2 \[RuleDelayed] Expand[w\ \((5 + \@5)\)]}\) /. {a \[Rule] \@\(5 - \@5\), b \[Rule] \@\(5 + \@5\)}\) /. {\@w_ \[RuleDelayed] \ \@Expand[w]}\)], "Input", AspectRatioFixed->True], Cell[BoxData[{ \(\(T1[a_, b_, r_] := \(1\/\(50\ b\^3\)\) \((512\ a\^5 - 15625\ b\^4 + 768\ a\^4\ r + 416\ a\^3\ r\^2 + 112\ a\^2\ r\^3 + 24\ a\ r\^4 + 4\ r\^5)\);\)\), "\n", \(\(T2[a_, b_, r_] := \((3840\ a\^5 - 78125\ b\^4 + 4480\ a\^4\ r + 2480\ a\^3\ r\^2 + 760\ a\^2\ r\^3 + 140\ a\ r\^4 + 30\ r\^5)\)/\((512\ a\^5\ b + 6250\ b\^5)\);\)\), "\n", \(\(T3[a_, b_, r_] := \(1\/\(2\ b\^2\)\) \((\(-18880\)\ a\^5 + 781250\ b\^4 - 34240\ a\^4\ r - 21260\ a\^3\ r\^2 - 5980\ a\^2\ r\^3 - 1255\ a\ r\^4 - 240\ r\^5)\);\)\), "\n", \(\(T4[a_, b_, r_] := \((68800\ a\^5 + 25000\ a\^4\ r + 11500\ a\^3\ r\^2 + 3250\ a\^2\ r\^3 + 375\ a\ r\^4 + 100\ r\^5)\)/\((512\ a\^5 + 6250\ b\^4)\);\)\), "\n", \(\(V[a_, b_, r_] := \((\(-1036800\)\ a\^5 + 48828125\ b\^4 - 2280000\ a\^4\ r - 1291500\ a\^3\ r\^2 - 399500\ a\^2\ r\^3 - 76625\ a\ r\^4 - 16100\ r\^5)\)/\((256\ a\^5 + 3125\ b\^4)\);\)\)}], "Input", AspectRatioFixed->True], Cell[BoxData[ \(CanonicalTransform[z_^5 + e_. \ z_ + f_ \[Equal] 0, z_, t_] := {#/\((\(-e\))\)^\((1/4)\) &, t^5 - t + f/\((\(-e\))\)^\((5/4)\) \[Equal] 0}\)], "Input"], Cell["\<\ f[u_, v_] = u v (u^10 + 11 u^5 v^5 - v^10); H[u_, v_] = -u^20 - v^20 + 228(u^15 v^5 - u^5 v^15) - 494 u^10 v^10; T[u_, v_] = u^30 + v^30 + 522 (u^25 v^5 - u^5 v^25) - 10005 (u^20 v^10 + u^10 v^20); W[k_, u_, v_] = -e^(4k) u^8 + e^(3k) u^7 v - 7 e^(2k) u^6 v^2 - 7 e^k u^5 v^3 + 7 e^(4k) u^3 v^5 - 7 e^(3k) u^2 v^6 - e^(2k) u v^7 - e^k v^8; t[k_, u_, v_] = e^(3k) u^6 + 2 e^(2k) u^5 v - 5 e^k u^4 v^2 - 5e^(4k) u^2 v^4 - 2 e^(3k) u v^5 + e^(2k) v^6; e = Exp[2Pi I/5];\ \>", "Input", AspectRatioFixed->True], Cell["\<\ u[Z_] := (12)^(1/20) 1/(1728Z)^(1/60)* Hypergeometric2F1[-1/60,29/60,4/5,1728 Z]; v[Z_] := 1/(12^11)^(1/20) (1/(1728 Z))^(-11/60)* Hypergeometric2F1[11/60,41/60,6/5,1728 Z];\ \>", "Input", AspectRatioFixed->True], Cell["\<\ lhsIcoEq[u_, v_, Z_]:= u^5 v^5 (u^10 + 11 u^5 v^5 - v^10)^5 - (u^30 + v^30 - 10005 (u^20 v^10 + u^10 v^20) + 522 (u^25 v^5 - u^5 v^25))^2 Z\ \>", "Input", AspectRatioFixed->True], Cell["\<\ KleinSolve[p_ == 0, y_] := Module[{a, b, c, n, l, m, w, Z, fm, Hm, Tm, um, vm, sol}, {a, b, c} = ({1/5, 1/5, 1} (Coefficient[p, y, #]& /@ {2, 1, 0}))/ Coefficient[p, y, 5] ; l = (-#2/#1/2+Sqrt[#2^2/#1^2/4-#3/#1])&[ (a^4+a b c-b^3),-(11a^3 b-a c^2+2b^2c),(64 a^2 b^2- 27a^3c-b c^2)]; w = (l b + c)/a; V=(l^2-3w)^3/(l c-w b); Z = 1/(1728-V); m = (V a-8 l^3-72 l w)/(l^2+w); um = u[Z]; vm = v[Z]; fm = f[um, vm]; Hm = H[um, vm]; Tm = T[um, vm]; {#}& /@ Sort[Table[l fm W[k, um, vm]/Hm + m fm^3 t[k, um, vm] W[k, um, vm]/Tm/Hm,{k, 0 ,4}]] ] /; MatchQ[CoefficientList[p, y],{_, _ ,_, 0, 0, _}] \ \>", "Input", AspectRatioFixed->True], Cell["\<\ 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]\ \>", "Input", AspectRatioFixed->True], Cell[CellGroupData[{ Cell["\<\ 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 + \t\t4 beta^j, xi] /. \t\txi^n_. -> Psi[p, x, n], {j, 3, 5}]) == 0 } ] /; MatchQ[CoefficientList[p, x], \t\t{_, _, _, _, _?(# =!= 0 &), _}]\ \>", "Input", AspectRatioFixed->True], Cell[BoxData[ \(General::"spell1" \(\(:\)\(\ \)\) "Possible spelling error: new symbol name \"\!\(beta\)\" is similar to \ existing symbol \"\!\(Beta\)\"."\)], "Message"] }, Open ]], Cell[BoxData[ \(ChooseRoot[p_, s_] := s[\([\(\(Position[#, Min[#]]\)[\([1, 1]\)] &\)[ Abs[p /. s]]]\)]\)], "Input"], Cell[BoxData[ \(\(\( (*\ Numerical\ ChooseRoot\ *) \)\(\[IndentingNewLine]\)\(ChooseRoot2[p_, s_] := Block[{i}, For[i = 1, i \[LessEqual] Length[s], \(i++\), If[Abs[p /. s[\([i]\)]] < 10^\((\(-10. \))\), Return[i]]]]\)\)\)], "Input"], Cell[BoxData[ \(SolveHermite[p_ \[Equal] 0, x_] := \((\ \[IndentingNewLine] (*\ First, \ get\ rid\ of\ the\ first\ coefficient\ *) \[IndentingNewLine]new = Expand[p/\((Coefficient[p, x^5])\)]; \[IndentingNewLine]ct = CanonicalTransform[new \[Equal] 0, x, t]; \ hqs = HermiteQuinticSolve[Last[ct], t]; \ntau = t /. hqs; \n Table[{x -> \(Solve[\(First[ct]\)[x] \[Equal] tau[\([i]\)], x]\)[\([1, 1, 2]\)]}, {i, 5}]\ \ )\)\)], "Input"] }, Closed]], Cell[CellGroupData[{ Cell[BoxData[ \( (*\ RootSort\ *) \)], "Input"], Cell[BoxData[ \( (*\ Written\ by\ me\ to\ get\ the\ sorting\ that\ Root\ objects\ use\ *) \ \)], "Input"], Cell[CellGroupData[{ Cell[BoxData[{ \(\[IndentingNewLine]\(CorrectReal[x__] := If[Abs[Im[x]] < 10^\(-10\), Re[x], x];\)\), "\[IndentingNewLine]", \(\(RealQ[x__] := Im[x] \[Equal] 0;\)\), "\[IndentingNewLine]", \(\(ComplexCompare[X__, Y__] := Block[{x, y}, \[IndentingNewLine]x = CorrectReal[N[X]]; \[IndentingNewLine]y = CorrectReal[N[Y]]; \[IndentingNewLine]If[ RealQ[x] && \(! RealQ[y]\), Return[True]]; \[IndentingNewLine]If[ RealQ[y]\ && \ \(! RealQ[x]\), Return[False]]; \[IndentingNewLine]If[RealQ[x]\ && \ RealQ[y], Return[x < y]]; \[IndentingNewLine]If[Abs[Arg[x]] == Abs[Arg[y]], Return[Arg[x] < Arg[y]]]; \[IndentingNewLine]Return[ Abs[Arg[x]] > Abs[Arg[y]]];\[IndentingNewLine]];\)\), "\[IndentingNewLine]", \(\(RootSort[list__] := Sort[list, ComplexCompare];\)\)}], "Input"], Cell[BoxData[ \(General::"spell1" \(\(:\)\(\ \)\) "Possible spelling error: new symbol name \"\!\(RealQ\)\" is similar to \ existing symbol \"\!\(Real\)\"."\)], "Message"] }, Open ]] }, Closed]], Cell[CellGroupData[{ Cell[BoxData[ \( (*\ Differential\ Resolvant\ \((Not\ used\ yet)\)\ *) \)], "Input"], Cell[BoxData[ \( (*\ This\ is\ written\ by\ me\ but\ is\ 99 %\ ported\ from\ \ DifferentialResolvent . nb\ *) \)], "Input"], Cell[CellGroupData[{ Cell[BoxData[ \(\(\(DifferentialResolvant[x_^e_ - x_ + b_ \[Equal] 0, x_] := Block[{diffeqn, p, eqn, t, deriv, alg1, alg2, alg3, coeffs, sol, approximation, \[IndentingNewLine]algequ, system}, \[IndentingNewLine]equ = t[p]^e - t[p] - p \[Equal] 0; \[IndentingNewLine] (*\ \(If[Abs[a] \[NotEqual] 1, Return[$Failed]];\)\ *) \[IndentingNewLine]diffequ = Sum[a\_n*D[t[p], {p, e - n}], {n, 1, e}] + a\_e*t[p] + a\_\(e + 1\); \[IndentingNewLine]deriv = Flatten[Table[ Solve[D[equ, {p, k}], D[t[p], {p, k}]], {k, 1, e - 1}]]; \[IndentingNewLine]alg1 = Factor[Numerator[ Together[\((diffequ //. deriv)\)]]]; \[IndentingNewLine]alg2 = FixedPoint[ Expand[# /. t[p]^\((n_)\) \[RuleDelayed] \((t[p] + p)\)^\((Quotient[n, e])\)*t[p]^\((Mod[n, e])\)] &, alg1]; \[IndentingNewLine]alg3 = \((# \[Equal] 0 &)\) /@ CoefficientList[alg2, t[p]]; \[IndentingNewLine]coeffs = Simplify[ Solve[alg3, Table[a\_n, {n, 1, e + 1}]]]; \[IndentingNewLine]diffequ = First[diffequ /. coeffs] \[Equal] 0; \[IndentingNewLine]Print[ diffequ]; \[IndentingNewLine]sol = DSolve[diffequ, t[p], p]; \[IndentingNewLine] (*\ If\ we\ can' t\ solve\ it\ then\ fail\ *) \[IndentingNewLine]If[ Head[sol] === DSolve, Return[$Failed]]; \[IndentingNewLine]Print[ sol]; \[IndentingNewLine]approximation = sol /. HoldPattern[HypergeometricPFQ[___]] \[Rule] 1; \[IndentingNewLine]Print[ approximation]; \[IndentingNewLine]algequ = equ /. approximation; \[IndentingNewLine]Print[ algequ]; \[IndentingNewLine]system = \((#1 \[Equal] 0 &)\) /@ Take[CoefficientList[algequ[\([1, 1]\)], p], e - 1]; \[IndentingNewLine]Print[ system]; \[IndentingNewLine]coeffs = Solve[system, Table[C[j], {j, e - 1}]]; \[IndentingNewLine]Print[ coeffs]; \[IndentingNewLine]Return[\(First[sol] /. coeffs\) /. p \[Rule] \(-b\)];\[IndentingNewLine]]\)\(\[IndentingNewLine]\) \)\)], "Input"], Cell[BoxData[ \(General::"spell1" \(\(:\)\(\ \)\) "Possible spelling error: new symbol name \"\!\(coeffs\)\" is similar \ to existing symbol \"\!\(coefs\)\"."\)], "Message"], Cell[BoxData[ \(General::"spell1" \(\(:\)\(\ \)\) "Possible spelling error: new symbol name \"\!\(diffequ\)\" is similar \ to existing symbol \"\!\(diffeqn\)\"."\)], "Message"] }, Open ]] }, Closed]], Cell[CellGroupData[{ Cell[BoxData[ \( (*\ ToSymbolic\ *) \)], "Input"], Cell[BoxData[ \( (*\ I\ wrote\ this\ to\ analyze\ a\ root\ object\ and\ convert\ it\ to\ \ radicals\ or\ functions\ *) \)], "Input"], Cell[CellGroupData[{ Cell[BoxData[{ \(\[IndentingNewLine] (*\ Cache\ so\ we\ dont\ have\ the\ solve\ the\ equations\ again\ *) \ \[IndentingNewLine]\(ToSymbolicCacheSol = 0;\)\), "\[IndentingNewLine]", \(\(ToSymbolicCacheEqu = 0;\)\[IndentingNewLine]\), "\[IndentingNewLine]", \(\(Remove[ToSymbolic, ConvertToSymbolic];\)\), "\[IndentingNewLine]", \(ToSymbolic[expression__] := Block[{result}, \[IndentingNewLine]Off[Function::slot]; Off[Part::partd]; \[IndentingNewLine]result = MapAll[ConvertToSymbolic, expression]; \[IndentingNewLine]On[ Function::slot]; On[Part::partd]; \[IndentingNewLine]Return[ result];\[IndentingNewLine]]\), "\[IndentingNewLine]", \(ConvertToSymbolic[expression_] := Block[\ {x, equ, rootnum, i, list, coeflist, sol, \[Eta], p, roots, s}, \[IndentingNewLine]\[IndentingNewLine] (*\ If\ we' re\ not\ a\ root\ then\ we\ shouldn' t\ touch\ it\ *) \[IndentingNewLine]If[ Head[expression] =!= \ Root, Return[expression]]; \[IndentingNewLine]\[IndentingNewLine] (*\ Get\ the\ polynomial\ *) \[IndentingNewLine]equ\ = \ \(First[ expression]\)[x]; \[IndentingNewLine]\[IndentingNewLine] (*\ If\ it' s\ of\ degree\ 4\ or\ less\ we\ can\ change\ it\ to\ \ radicals\ *) \[IndentingNewLine]If[Exponent[equ, x] \[LessEqual] 4, Return[ToRadicals[ expression]]]; \[IndentingNewLine]\[IndentingNewLine]rootnum = expression[\([2]\)]; \[IndentingNewLine]\[IndentingNewLine] (*\ Check\ the\ cache\ *) \[IndentingNewLine]If[ equ\ \[Equal] \ ToSymbolicCacheEqu, Return[\(RootSort[ ToSymbolicCacheSol]\)[\([rootnum]\)]]]; \[IndentingNewLine]\ \[IndentingNewLine] (*\ Is\ it\ solvable\ by\ \(\(radicals\)\(?\)\)\ \ *) \[IndentingNewLine]If[ SolvableQ[equ, x], \[IndentingNewLine]sol = SolveQuintic[equ \[Equal] 0, x]; \[IndentingNewLine]If[ sol =!= $Failed, \[IndentingNewLine]ToSymbolicCacheSol\ = \ sol; \[IndentingNewLine]ToSymbolicCacheEqu\ = \ equ; \[IndentingNewLine]Return[\(RootSort[ x /. sol]\)[\([rootnum]\)]]]]; \[IndentingNewLine]coeflist = CoefficientList[equ, x]; \[IndentingNewLine]\[IndentingNewLine] (*\ Quintic\ equation\ *) \[IndentingNewLine]If[ Exponent[equ, x] \[Equal] 5, \[IndentingNewLine]\[IndentingNewLine] (*\ Hermite\ Quintic\ *) \[IndentingNewLine]If[ coeflist[\([5]\)] \[Equal] 0 && coeflist[\([4]\)] \[Equal] 0 && coeflist[\([3]\)] \[Equal] 0 && coeflist[\([2]\)] \[NotEqual] 0 && coeflist[\([1]\)] \[NotEqual] 0, \[IndentingNewLine]sol\ = \ x /. SolveHermite[equ \[Equal] 0, x]; \[IndentingNewLine]ToSymbolicCacheSol\ = \ sol; \[IndentingNewLine]ToSymbolicCacheEqu\ = \ equ; \[IndentingNewLine]Return[\(RootSort[ sol]\)[\([rootnum]\)]]]; \[IndentingNewLine]\ \[IndentingNewLine] (*\ Klien\ Quintic\ *) \[IndentingNewLine]If[ coeflist[\([5]\)] \[Equal] 0 && coeflist[\([4]\)] \[Equal] 0 && \((coeflist[\([3]\)] \[NotEqual] 0\ || coeflist[\([2]\)] \[NotEqual] 0)\) && coeflist[\([1]\)] \[NotEqual] 0, \[IndentingNewLine]sol = KleinSolve[equ \[Equal] 0, x]; \[IndentingNewLine]ToSymbolicCacheSol\ = \ sol; \[IndentingNewLine]ToSymbolicCacheEqu\ = \ equ; \[IndentingNewLine]Return[\(RootSort[ Flatten[ sol]]\)[\([rootnum]\)]]]; \[IndentingNewLine]\ \[IndentingNewLine]\[IndentingNewLine] (*\ General\ Quintic\ *) \[IndentingNewLine]p = Simplify[PrincipalTransform[equ \[Equal] 0, x, y]]; If[\ Head[p] === PrincipalTransform, Return[expression]]; \[IndentingNewLine]p[\([2]\)] = Expand[\(p[\([2]\)]\)[\([1]\)] - \(p[\([2]\)]\)[\([2]\)]] \ \[Equal] 0; \n\ \ \ \ \ \ \ \[Eta] = KleinSolve[p[\([2]\)], y]; \n\ \ \ \ \ \ \ sol = Table[s = Solve[\(First[p]\)[x] \[Equal] roots[\([i]\)], x]; \[IndentingNewLine]\(x /. s[\([ChooseRoot2[equ, N[s /. roots[\([i]\)] \[Rule] N[\(\[Eta][\([i]\)]\)[\([1]\)]]]]]\)]\) /. roots[\([i]\)] \[Rule] \[Eta][\([i]\)], {i, 5}]; \[IndentingNewLine]ToSymbolicCacheSol\ = \ sol; \[IndentingNewLine]ToSymbolicCacheEqu\ = \ equ; \[IndentingNewLine]\ \ \ \ Return[\(RootSort[ Flatten[ sol]]\)[\([rootnum]\)]];\[IndentingNewLine]\ \[IndentingNewLine]]; (*\ If\ Quintic\ *) \[IndentingNewLine]\[IndentingNewLine] (*\ Couldn' t\ do\ anything\ with\ it\ *) \[IndentingNewLine]Return[ expression];\[IndentingNewLine]]\)}], "Input"], Cell[BoxData[ \(General::"spell1" \(\(:\)\(\ \)\) "Possible spelling error: new symbol name \"\!\(roots\)\" is similar to \ existing symbol \"\!\(Roots\)\"."\)], "Message"] }, Open ]] }, Closed]] }, FrontEndVersion->"4.1 for Microsoft Windows", ScreenRectangle->{{0, 1024}, {0, 695}}, CellGrouping->Manual, WindowSize->{663, 653}, WindowMargins->{{Automatic, 44}, {4, Automatic}} ] (******************************************************************* Cached data follows. If you edit this Notebook file directly, not using Mathematica, you must remove the line containing CacheID at the top of the file. The cache data will then be recreated when you save this file from within Mathematica. *******************************************************************) (*CellTagsOutline CellTagsIndex->{} *) (*CellTagsIndex CellTagsIndex->{} *) (*NotebookFileOutline Notebook[{ Cell[1705, 50, 1597, 29, 542, "Input"], Cell[CellGroupData[{ Cell[3327, 83, 66, 1, 30, "Input"], Cell[3396, 86, 139, 3, 50, "Input"], Cell[3538, 91, 3532, 54, 556, "Input"], Cell[7073, 147, 189, 3, 50, "Input"], Cell[7265, 152, 222, 4, 70, "Input"], Cell[7490, 158, 227, 4, 70, "Input"], Cell[7720, 164, 137, 3, 30, "Input"], Cell[7860, 169, 111, 2, 30, "Input"], Cell[CellGroupData[{ Cell[7996, 175, 1434, 27, 336, "Input"], Cell[9433, 204, 185, 3, 70, "Message"] }, Open ]], Cell[9633, 210, 1987, 30, 278, "Input"], Cell[11623, 242, 167, 4, 44, "Input"], Cell[11793, 248, 666, 12, 130, "Input"], Cell[12462, 262, 870, 15, 147, "Input"], Cell[13335, 279, 1367, 27, 269, "Input"], Cell[14705, 308, 1734, 30, 494, "Input"], Cell[16442, 340, 394, 9, 84, "Input"], Cell[16839, 351, 1145, 21, 243, "Input"], Cell[17987, 374, 189, 3, 50, "Input"], Cell[18179, 379, 587, 12, 192, "Input"], Cell[18769, 393, 266, 6, 84, "Input"], Cell[19038, 401, 207, 6, 84, "Input"], Cell[19248, 409, 741, 17, 282, "Input"], Cell[19992, 428, 212, 6, 84, "Input"], Cell[CellGroupData[{ Cell[20229, 438, 560, 16, 264, "Input"], Cell[20792, 456, 181, 3, 70, "Message"] }, Open ]], Cell[20988, 462, 138, 3, 30, "Input"], Cell[21129, 467, 286, 6, 70, "Input"], Cell[21418, 475, 513, 8, 130, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[21968, 488, 51, 1, 27, "Input"], Cell[22022, 491, 116, 3, 30, "Input"], Cell[CellGroupData[{ Cell[22163, 498, 920, 15, 270, "Input"], Cell[23086, 515, 182, 3, 70, "Message"] }, Open ]] }, Closed]], Cell[CellGroupData[{ Cell[23317, 524, 88, 1, 27, "Input"], Cell[23408, 527, 135, 3, 30, "Input"], Cell[CellGroupData[{ Cell[23568, 534, 2308, 41, 570, "Input"], Cell[25879, 577, 184, 3, 70, "Message"], Cell[26066, 582, 187, 3, 70, "Message"] }, Open ]] }, Closed]], Cell[CellGroupData[{ Cell[26302, 591, 53, 1, 27, "Input"], Cell[26358, 594, 143, 3, 50, "Input"], Cell[CellGroupData[{ Cell[26526, 601, 5167, 91, 1530, "Input"], Cell[31696, 694, 183, 3, 70, "Message"] }, Open ]] }, Closed]] } ] *) (******************************************************************* End of Mathematica Notebook file. *******************************************************************)