(* ::Package:: *)

(* ::Chapter:: *)
(*prolog*)


CompleteSquare::usage = "Factors an even-ordered polynomial function into a square polynomial plus a constant"


Begin["`Private`"]


(* ::Chapter::Closed:: *)
(*main code*)


ClearAll[CompleteSquare];
CompleteSquare /: MakeBoxes[CompleteSquare[expr_], TraditionalForm] := MakeBoxes[CalculateBoxForm[Localize["complete the square",27151], expr], TraditionalForm]

CompleteSquare[lhs_ == rhs_] := With[{res = CompleteSquare[lhs - rhs]}, res == 0 /; FreeQ[res, CompleteSquare]]

CompleteSquare[a_. x_?usersymbolQ^2 + b_. x_?usersymbolQ y_?usersymbolQ + c_. y_?usersymbolQ^2 + d_.] /;
	VectorQ[{a, b, c, d}, NumericQ] := a (x + (b y)/(2 a))^2 + (4 a d - b^2 y^2 + 4 a c y^2)/(4 a)

CompleteSquare[p_] := Block[{vars = VarList[p], isQuadraticQ, csq},
  	isQuadraticQ = !NumericQ[p] && PolynomialQ[p, vars] && Max[Exponent[p, vars]] > 1 && biQuadraticQ[p, vars];
  	csq = p //. {
  			a_. x_Symbol^q_ + b_. x_Symbol^r_. + c_. :> a (x^r + b/(2 a))^2 + (4 a c - b^2)/(4 a) /; 2r == q && FreeQ[{a, b, c, r, q}, Alternatives @@ vars],
  			a_. x_Symbol^q_ + b_. x_Symbol^r_. :> a (x^r + b/(2 a))^2 + -b^2/(4 a) /; 2r == q && FreeQ[{a, b, r, q}, Alternatives @@ vars]
  		};
  	csq /; isQuadraticQ && p == Expand[csq]
]


(*
In[77]:= CompleteSquare[x^2 - 6 x + 13]
Out[77]= 4 + (-3 + x)^2

In[69]:= CompleteSquare[x^4 - 10 x^2 + 1]
Out[69]= -24 + (-5 + x^2)^2

In[76]:= CompleteSquare[x^2 - 6 x + 12 - y - y^2]
Out[76]= 13/4 + (-3 + x)^2 - (1/2 + y)^2

In[104]:= CompleteSquare[-x^2 + 12 x]
Out[104]= 36 - (-6 + x)^2

In[46]:= CompleteSquare[2 x^2 - 3 x y + 4 y^2 + 6 x - 3 y - 4 == 0]
Out[46]= -(145/16) + 2 (3/2 + x)^2 + 4 (-(3/8) + y)^2 - 3 x y == 0
*)


biQuadraticQ[expr_, vars_] := TrueQ @ Apply[And, Exponent[Subtract @@ Eliminate[{expr == 0, t - #^Exponent[expr, #] == 0}, #], t] == 2 & /@ vars]


(*
In[98]:= biQuadraticQ[x^3 - 4 x^2 + 6 x - 24]
Out[98]= False

In[99]:= biQuadraticQ[x^4 - 4 x^2 - 24]
Out[99]= True

In[104]:= biQuadraticQ[x^4 - 4 x^2 - 24 + y^6 - 5 y^3 + 1]
Out[104]= True
*)


ReciprocalPolynomial /: MakeBoxes[ReciprocalPolynomial[expr_, z_], TraditionalForm] := MakeBoxes[CalculateBoxForm[Localize["reciprocal polynomial",27152], expr], TraditionalForm]
ReciprocalPolynomial[poly_, z_] /; PolynomialQ[poly, z] := Conjugate[Reverse[CoefficientList[poly, z]]].(z^Range[0, Exponent[poly, z]])


(* ::Chapter:: *)
(*epilog*)


End[]
