%mathpiper,def="YacasYacasPSolve"

Rulebase("YacasPSolve",{uni});

Rule("YacasPSolve",1,1,IsUniVar(uni) And Degree(uni) = 0)
    {};

Rule("YacasPSolve",1,1,IsUniVar(uni) And Degree(uni) = 1)
    -Coef(uni,0)/Coef(uni,1);


Rule("YacasPSolve",1,1,IsUniVar(uni) And Degree(uni) = 2)
    [
     Local(a,b,c,d,q,r);
     c:=Coef(uni,0);
     b:=Coef(uni,1);
     a:=Coef(uni,2);
     d:=b*b-4*a*c;
     q:=Sqrt(d)/(2*a);
     // Removed to avoid excessive time RadSimp takes for larger numbers
     // If(Im(q) != 0,
     //     q := Complex(RadSimp(Re(q)), RadSimp(Im(q))),
     //     q := RadSimp(q));
     r:=-b/(2*a);
     If(InVerboseMode(),[ Tell("   ",{c,b,a,d}); Tell("   ",{q,r}); ]);
     {r+q,r-q};
    ];


Rule("YacasPSolve",1,1,IsUniVar(uni) And Degree(uni) = 3 )
    [
     Local(p,q,r,w,ww,a,b);
     Local(coef0,coef1,coef3,adjust);

/* Get coefficients for a new polynomial, such that the coefficient of
   degree 2 is zero:
   Take f(x)=a0+a1*x+a2*x^2+a3*x^3 and substitute x = x' + adjust
   This gives g(x) = b0+b1*x+b2*x^2+b3*x^3 where
   b3 = a3;
   b2 = 0 => adjust = (-a2)/(3*a3);
   b1 = 2*a2*adjust+3*a3*adjust^2+a1;
   b0 = a2*adjust^2+a3*adjust^3+adjust*a1+a0;

   After solving g(x') = 0, return x = x' + adjust.
*/

     adjust := (-Coef(uni,2))/(3*Coef(uni,3));
     coef3 := Coef(uni,3);
     coef1 := 2*Coef(uni,2)*adjust+3*Coef(uni,3)*adjust^2+Coef(uni,1);
     coef0 := Coef(uni,2)*adjust^2+Coef(uni,3)*adjust^3+
              adjust*Coef(uni,1)+Coef(uni,0);

     p:=coef3;
     q:=coef1/p;
     r:=coef0/p;
    w:=Complex(-1/2,Sqrt(3/4));
    ww:=Complex(-1/2,-Sqrt(3/4));

/* Equation is xxx + qx + r = 0 */
/* 	Let x = a + b
	a^3 + b^3 + 3(aab + bba) + q(a + b) + r = 0
	a^3 + b^3 + (3ab+q)x + r = 0

	Let 3ab+q = 0. This is permissible, for we can still find a+b == x

	a^3 + b^3 = -r
	(ab)^3 = -q^3/27

        So a^3 and b^3 are the roots of t^2 + rt - q^3/27 = 0

	Let
                a^3 = -r/2 + Sqrt(q^3/27+ rr/4)
                b^3 = -r/2 - Sqrt(q^3/27+ rr/4)
	Therefore there are three values for each of a and b.
	Clearly if ab = -q/3 is true then (wa)(wwb) == (wb)(wwa) == -q/3
*/

  a:=(-r/2 + Sqrt(q^3/27+ r*r/4))^(1/3);
  b:=(-r/2 - Sqrt(q^3/27+ r*r/4))^(1/3);

  {a+b+adjust,w*a+ww*b+adjust,ww*a+w*b+adjust};
];

/*
How to solve the quartic equation?

The equation is x^4 + a1 x^3 + a2 x^2 + a3 x + a4 = 0.
The idea is to write the left-hand side as the difference of two
squares: (x^2 + p x + q)^2 - (s x + t)^2.
Eliminating the parentheses and equation coefficients yields four
equations for the four unknowns p, q, s and t:
  a1 = 2p              (1)
  a2 = p^2 + 2q - s^2  (2)
  a3 = 2pq - 2st       (3)
  a4 = q^2 - t^2       (4)
From the first equation, we find that p = a1/2. Substituting this in
the other three equations and rearranging gives
  s^2 = a1^2/4 - a2 + 2q   (5)
  2st = a1 q - a3          (6)
  t^2 = q^2 - a4           (7)
We now take the square (6) and substitute (5) and (7):
  4 (a1^2/4 - a2 + 2q) (q^2 - a4) = (a1 q - a3)^2  <==>
  8 q^3 - 4 a2 q^2 + (2 a1 a3 - 8 a4) q + 4 a2 a4 - a1^2 a4 - a3^2 = 0.
Miraculously, we got a cubic equation for q. Suppose we can solve this
equation. We can then compute t from (7): t = sqrt(q^2 - a4). If t is
nonzero, we can compute s from (6). Note that we cannot compute s from
(5), since we introduced an extra solution when squaring (6). However,
if t is zero, then no extra solution was introduced and we can safely
use (5). Having found the values of p, q, s and t, we can factor the
difference of squares and solve the quartic:
  x^4 + a1 x^3 + a2 x^2 + a3 x + a4 = (x^2 + p x + q)^2 - (s x + t)^2
                 = (x^2 + p x + q + s x + t) (x^2 + p x + q - sx - t).
The four roots of the quartic are the two roots of the first quadratic
factor plus the two roots of the second quadratic factor.
*/

Rule("YacasPSolve",1,1,IsUniVar(uni) And Degree(uni) = 4 )
[
    Local(coef4,a1,a2,a3,a4,y,y1,z,t,s);

    coef4:=Coef(uni,4);
    a1:=Coef(uni,3)/coef4;
    a2:=Coef(uni,2)/coef4;
    a3:=Coef(uni,1)/coef4;
    a4:=Coef(uni,0)/coef4;

    /* y1 = 2q, with q as above. */
    y1:=First(YacasPSolve(y^3-a2*y^2+(a1*a3-4*a4)*y+(4*a2*a4-a3^2-a1^2*a4),y));
    t := Sqrt(y1^2/4-a4);
    If(t=0, s:=Sqrt(y1+a1^2/4-a2), s:=(a1*y1-2*a3)/(4*t));
    Concat(YacasPSolve(z^2+(a1/2+s)*z+y1/2+t,z),
           YacasPSolve(z^2+(a1/2-s)*z+y1/2-t,z));
];

Function("YacasPSolve",{uni,var}) [
     Local(u, factors, f, r, s);

     u := MakeUni(uni, var);

     If(Type(u) = "UniVariate" And (And @ (Lambda({x}, IsNumber(x) Or IsRational(x)) /@ u[3])), [
         Local(coeffs);
         coeffs := Rationalize(u[3]);
         coeffs := If(Length(coeffs) > 1, 
                       Lcm(Denominator /@ coeffs) * coeffs, 
                       (Denominator /@ coeffs) * coeffs);
         DestructiveReplace(u, 3, coeffs);
         factors := If(Degree(u)>0, 
                        Factors(NormalForm(u)), 
                        {NormalForm(u), 1});
     ], [
         factors := {{uni, 1}};
     ]);

     r := {};
     ForEach(f, factors) [
         s := YacasPSolve(MakeUni(f[1],var));
         r := Union(r, If(IsList(s), s, {s}));
     ];

     If(Length(r) = 1, r[1], r);
];

%/mathpiper



%mathpiper_docs,name="YacasPSolve",categories="User Functions;Solvers (Symbolic)"
*CMD YacasPSolve --- solve a polynomial equation
*STD
*CALL
	YacasPSolve(poly, var)

*PARMS

{poly} -- a polynomial in "var"

{var} -- a variable

*DESC

This commands returns a list containing the roots of "poly",
considered as a polynomial in the variable "var". If there is only
one root, it is not returned as a one-entry list but just by
itself. A double root occurs twice in the result, and similarly for
roots of higher multiplicity. All polynomials of degree up to 4 are
handled.

*E.G.

In> YacasPSolve(b*x+a,x)
Result: -a/b;
In> YacasPSolve(c*x^2+b*x+a,x)
Result: {(Sqrt(b^2-4*c*a)-b)/(2*c),(-(b+
	Sqrt(b^2-4*c*a)))/(2*c)};

*SEE Solve, Factor
%/mathpiper_docs
