Quartic Equation

Author

Eric W. Weisstein
August 4, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Algebra/QuarticEquation.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/QuarticEquation.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Solution

Plus@@(Subscript[a,#]x^#&/@Range[0,4])==0//TraditionalForm

SetOptions[Roots,Quartics->False];
Solve[Plus@@(Subscript[a,#]x^#&/@Range[0,4])==0,x]

SetOptions[Roots,Quartics->True]

Ferrari Quartic

Roots[x^4+6x^2-60x+36==0,x]//TraditionalForm

General Quartic

Solve[Plus@@(Subscript[a,#]x^#&/@Range[0,4])==0,x]//TraditionalForm

Newton's Relations

RootReduce[Plus@@((x/.{ToRules[Roots[x^4+p x^2+q x+r==0,x,Cubics->False,Quartics->False]]}))]

Table[RootReduce[Plus@@((x/.{ToRules[Roots[x^4+p x^2+q x+r==0,x,Cubics->False,Quartics->False]]})^i)],{i,5}]

Elimination of Coefficients in Terms of Roots

eqns={z1+z2+z3+z4==0,
z1 z2+z1 z3+z1 z4+z2 z3+z2 z4+z3 z4==p,
z1 z2 z3+z1 z2 z4+z2 z3 z4==-q,
z1 z2 z3 z4==r};

FullSimplify[Eliminate[eqns,{z2,z3,z4}]]

Eliminate q

FullSimplify[Eliminate[eqns,{q,z3,z4}]]

Eliminate p

FullSimplify[Eliminate[eqns,{p,z3,z4}]]

Eliminate r

FullSimplify[Eliminate[eqns,{r,z3,z4}]]

Elimination of Cubed Terms

Collect[z^4+(Subscript[a, 3]) z^3+(Subscript[a, 2]) z^2+(Subscript[a, 1]) z+(Subscript[a, 0])/.z->x-1/4 (Subscript[a, 3]),{x^4,x^3,x^2,x,1}]

CoefficientList[%,x]

Resolvent

Expand[(x^2+1/2u)^2-((u-p)x^2-q x+(u^2/4-r))]

P==(x^2)+(u/2)

Expand[((u-p)x^2-q x+(u^2/4-r))]

(u-p)(x^2-(q/(u-p))x+((u^2/4-r)/(u-p)))

(u-p)(x-Sqrt[((u^2/4-r)/(u-p))])^2

2Sqrt[((u^2/4-r)/(u-p))]==(q/(u-p))

q^2==(u-p)^2 4(((u^2/4-r)/(u-p)))

q==2Sqrt[u-p]Sqrt[u^2/4-r]

Q==Sqrt[u-p](x-Sqrt[((u^2/4-r)/(u-p))])
==A x - Sqrt[u^2/4-r]
==A x-q/(2Sqrt[u-p])
==A x-q/2A

where

A==Sqrt[u-p]

Verifying,

Simplify[(u-p)(x^2-(q/(u-p))x+((u^2/4-r)/(u-p)))-(A x-(q/(2A)))^2
/.A->Sqrt[u-p]
/.q->Sqrt[4(u-p)( u^2/4-r)]]

Roots[q^2==4(u-p)((1/4)(u^2)-r),u]

Expand[x^4+p x^2+q x+r/.{p->a2-3/8a3^2,q->a1-1/2a2 a3+a3^3/8,r->a0-a1 a3/4+a2 a3^2/16-3/256 a3^4}/.x->(z+a3/4)]

eqn1=P^2-Q^2/.{P->x^2+(1/2)u,Q->(Sqrt[u-p])x-(q/(2(Sqrt[u-p])))}/.u->(p/3)+(((2^(1/3)) (-(p^2)-12 r))/(3 (((-2 (p^3)-27 (q^2)+72 p r+(Sqrt[4 (((-(p^2)-12 r))^3)+(((-2 (p^3)-27 (q^2)+72 p r))^2)])))^(1/3))))-((((-2 (p^3)-27 (q^2)+72 p r+(Sqrt[4 (((-(p^2)-12 r))^3)+(((-2 (p^3)-27 (q^2)+72 p r))^2)])))^(1/3))/(3 (2^(1/3))))/.{p->a2-3/8a3^2,q->a1-1/2a2 a3+a3^3/8,r->a0-a1 a3/4+a2 a3^2/16-3/256 a3^4}/.x->(z+a3/4);

eqn2=P^2-Q^2/.{P->x^2+(1/2)u,Q->(Sqrt[u-p])x-(q/(2(Sqrt[u-p])))}/.u->(p/3)-(((1+I (Sqrt[3])) (-(p^2)-12 r))/(3 (2^(2/3)) (((-2 (p^3)-27 (q^2)+72 p r+(Sqrt[4 (((-(p^2)-12 r))^3)+(((-2 (p^3)-27 (q^2)+72 p r))^2)])))^(1/3))))+(((1-I (Sqrt[3])) (((-2 (p^3)-27 (q^2)+72 p r+(Sqrt[4 (((-(p^2)-12 r))^3)+(((-2 (p^3)-27 (q^2)+72 p r))^2)])))^(1/3)))/(6 (2^(1/3))))/.{p->a2-3/8a3^2,q->a1-1/2a2 a3+a3^3/8,r->a0-a1 a3/4+a2 a3^2/16-3/256 a3^4}/.x->(z+a3/4);

eqn3=P^2-Q^2/.{P->x^2+(1/2)u,Q->(Sqrt[u-p])x-(q/(2(Sqrt[u-p])))}/.u->(p/3)-(((1-I (Sqrt[3])) (-(p^2)-12 r))/(3 (2^(2/3)) (((-2 (p^3)-27 (q^2)+72 p r+(Sqrt[4 (((-(p^2)-12 r))^3)+(((-2 (p^3)-27 (q^2)+72 p r))^2)])))^(1/3))))+(((1+I (Sqrt[3])) (((-2 (p^3)-27 (q^2)+72 p r+(Sqrt[4 (((-(p^2)-12 r))^3)+(((-2 (p^3)-27 (q^2)+72 p r))^2)])))^(1/3)))/(6 (2^(1/3))))/.{p->a2-3/8a3^2,q->a1-1/2a2 a3+a3^3/8,r->a0-a1 a3/4+a2 a3^2/16-3/256 a3^4}/.x->(z+a3/4);

eqns={eqn1,eqn2,eqn3};

Coefficient[eqn1,z^4]

Coefficient[#,z^3]&/@eqns

Coefficient[#,z^2]&/@eqns

Simplify[Coefficient[#,z]&/@eqns]

FullSimplify[(#/.z->0)&/@eqns]//Timing

(Table[a0-(#/.z->0)/.Thread[{a0,a1,a2,a3}->Table[Random[Real,{-10,10}],{4}]],{10}]//Chop)&/@eqns

Collect[Expand[Simplify[4(u-p)((1/4)(u^2)-r)-q^2/.{p->a2-3/8a3^2,q->a1-1/2a2 a3+a3^3/8,r->a0-a1 a3/4+a2 a3^2/16-3/256 a3^4},(a0|a1|a2|a3)∈Reals]],{u^3,u^2,u}]

-(a1^2)+4 a0 a2-((3 a0 (a3^2))/2)+((a1 (a3^3))/8)-((a2 (a3^4))/64)+((a3^6)/512)+(-4 a0+a1 a3-((a2 (a3^2))/4)+((3 (a3^4))/64)) u+(-a2+((3 (a3^2))/8)) (u^2)+(u^3)

Collect[Expand[%/.u->y-a3^2/8],{y^3,y^2,y}]

Check

QuarticRoots[c_List]:=Module[{a0,a1,a2,a3,y,y1,r,d,e},
{a3,a2,a1,a0}=c;
y1=y/.
FindRoot[y^3-a2 y^2+(a1 a3-4a0)y+(4a2 a0 -a1^2-a3^2 a0)==0,{y,1}];
r=Sqrt[a3^2/4-a2+y1];
d=If[r==0,
Sqrt[3a3^2/4-2a2+2Sqrt[y1^2-4a0]],
Sqrt[3a3^2/4-r^2-2a2+(4a3 a2-8a1-a3^3)/(4r)]
];
e=If[r==0,
Sqrt[3a3^2/4-2a2-2Sqrt[y1^2-4a0]],
Sqrt[3a3^2/4-r^2-2a2-(4a3 a2-8a1-a3^3)/(4r)]
];
{-a3/4+r/2+d/2,-a3/4+r/2-d/2,-a3/4-r/2+e/2,-a3/4-r/2-e/2}
]

With[{a0=1,a1=2,a2=3,a3=4},
{y1=y/.
FindRoot[y^3-a2 y^2+(a1 a3-4a0)y+(4a2 a0 -a1^2-a3^2 a0)==0,{y,1}],
x/.{ToRules[NRoots[x^4+a3 x^3+a2 x^2+a1 x+a0==0,x]]}//Sort,
QuarticRoots[{4,3,2,1}]//Sort,
Flatten[(x/.{ToRules[NRoots[x^2+1/2(a3+#Sqrt[a3^2-4a2+4y1])x+1/2(y1+# Sqrt[y1^2-4a0])==0,x]]})&/@{-1,1}]//Sort
}//Chop
]//ColumnForm

Explicit Resolvent

a3=3;a2=2;a1=1;a0=4;

Roots[z^4+a3 z^3+a2 z^2+a1 z+a0==0,z,Quartics->False,Cubics->False]

y1=y/.{ToRules[Roots[y^3-a2 y^2+(a1 a3-4a0)y+(4a2 a0-a1^2-a3^2 a0)==0,y,Cubics->False]]}

RootReduce[{ToRules[Roots[#==0,x]]&/@(Function[y1,x^2+(1/2)(a3-(Sqrt[a3^2-4a2+4y1]))x+((2 a1+y1 (-a3+(Sqrt[-4 a2+(a3^2)+4 y1])))/(2 (Sqrt[-4 a2+(a3^2)+4 y1])))]/@y1)}]

RootReduce[{ToRules[Roots[#==0,x]]&/@(Function[y1,x^2+(1/2)(a3-(Sqrt[a3^2-4a2+4y1]))x+(1/2)(y1-(Sqrt[y1^2-4a0]))]/@y1)}]

r=Sqrt[a3^2/4-a2+y1];
d=Sqrt[3/4a3^2-r^2-2a2+(4a3 a2-8a1-a3^3)/(4r)];
e=Sqrt[3/4a3^2-r^2-2a2-(4a3 a2-8a1-a3^3)/(4r)];

RootReduce[{-a3/4+r/2+d/2,-a3/4+r/2-d/2,-a3/4-r/2+e/2,-a3/4-r/2-e/2}]

{a3,a2,a1,a0,y1}=.

FullSimplify[CoefficientList[Expand[(x-(-a3/4+r/2+d/2))(x-(-a3/4+r/2-d/2))],x]]

Collect[FullSimplify[Expand[(x-(-a3/4+r/2+d/2))(x-(-a3/4+r/2-d/2))]],{1,x,x^2}]

FullSimplify[(1/2) (a3-(Sqrt[-4 a2+(a3^2)+4 y1]))-(( (4 a2-(a3^2)-4 y1+a3 (Sqrt[-4 a2+(a3^2)+4 y1])))/(2 (Sqrt[-4 a2+(a3^2)+4 y1])))]

FullSimplify[Expand[Solve[y1^3-a2 y1^2+(a1 a3-4a0)y1+(4a2 a0-a1^2-a3^2 a0)==0,a0]]]

((2 a1-a3 y1+y1 (Sqrt[-4 a2+(a3^2)+4 y1]))/(2 (Sqrt[-4 a2+(a3^2)+4 y1])))

Cancel[Expand[((2 a1-a3 y1+y1 (Sqrt[-4 a2+(a3^2)+4 y1]))/(2 (Sqrt[-4 a2+(a3^2)+4 y1])))]]

(y1/2)+(1/2)(((2a1-a3 y1)/(Sqrt[-4 a2+(a3^2)+4 y1])))

FullSimplify[(((2a1-a3 y1)^2)/(-4 a2+(a3^2)+4 y1))]

FullSimplify[y1^2-4a0/.a0->(((a1^2)-a1 a3 y1+(a2-y1) (y1^2))/(4 a2-(a3^2)-4 y1))]

Faucette Relations

Collect[(x-α)(x-β)(x-γ),x]

Solve[{(-x1^2*x2*x3-x1*x2^2*x3-x1*x2*x3^2)==r,(-x1^2-x1*x2-x2^2-x1*x3-x2*x3-x3^2)==p,(x1^2*x2+x1*x2^2+x1^2*x3+2*x1*x2*x3+x2^2*x3+x1*x3^2+x2*x3^2)==q},{x1,x2,x3}]

{x1,x2,x3,x4}=x/.{ToRules[Roots[x^4+p x^2+q x+r==0,x,Quartics->False]]}

Simplify[x1+x2+x3+x4]

Simplify/@{(x1+x2)(x3+x4)+(x1+x2)^2 ,
(x1+x3)(x2+x4)+(x1+x3)^2 ,
(x1+x4)(x2+x3)+(x2+x3)^2 }

{α,β,γ}={(x1+x2)(x3+x4),(x1+x3)(x2+x4),(x1+x4)(x2+x3)};

h[x_]:=(x-α)(x-β)(x-γ)

Collect[Simplify[h[x]],x]