How to determine the shape of real quadric surfaces? Use discriminants?

Let $$a x^2+2 b x y+c y^2+2 d x+2 e y+f=0$$ be the implicit equation that defines a conic section , where $$a,b,c,d,e,f$$ are real numbers.

I have known from wikipedia how to use 2 discriminants to determine what does the conic section look like.

The code written by me is as follows:

Clear["Global*"];
a = 1; b = 2; c = 3; d = 4; e = 5; f = 6;
ConicSection[a_, b_, c_, d_, e_, f_] :=
Module[{matrix, firstDiscriminant, secondDiscriminant, expr},
matrix = {{a, b, d}, {b, c, e}, {d, e, f}};
expr = Map[Times @@ # &, Tuples[{x, y, 1}, 2]] . Flatten[matrix];
firstDiscriminant = Det@matrix; secondDiscriminant = b^2 - a*c;
Return[{matirx, firstDiscriminant, secondDiscriminant, expr}];];
{matrix, firstDiscriminant, secondDiscriminant, expr} =
ConicSection[a, b, c, d, e, f];
getConclusion[firstDiscriminant_, secondDiscriminant_] :=
Module[{},
If[secondDiscriminant < 0 && firstDiscriminant != 0,
Print["the curve either has no real points, or is an ellipse or a \
circle."]];
If[secondDiscriminant < 0 && firstDiscriminant == 0,
Print["the curve is reduced to a single point."]];
If[secondDiscriminant == 0 && firstDiscriminant != 0,
Print["the curve is a parabola"]];
If[secondDiscriminant == 0 && firstDiscriminant == 0,
Print["a double line or two parallel lines."]];
If[secondDiscriminant > 0 && firstDiscriminant != 0,
Print["the curve is a hyperbola"]];
If[secondDiscriminant > 0 && firstDiscriminant == 0,
Print["a pair of intersecting lines."]];]
getConclusion[firstDiscriminant, secondDiscriminant];
ContourPlot[expr == 0, {x, -10, 10}, {y, -10, 10}]


Yes, the programme looks good enough, adding extra Algebraic fingerprint like centrifugation rate seems better.

My question is:

Let $$P(x,y,z)$$ be a polynomial of degree two in three variables that defines a real quadric surface.

How to use Mathematica to determine the shape of real quadric surfaces?

One demonstration with Manipulate is better.

Any help would be appreciated.

• Could use Eigenvalues on the matrix that gives the quadratic part. Sep 15, 2023 at 14:32

Note your formula does define a curve in "D, not a surface in 3D. Anyway, the following procedure can be applied in both cases.

poly = a x^2 + 2  b  x y + c  y^2 + 2 d  x + 2 e y + f /. {a -> 1,
b -> 2, c -> 3, d -> 4, e -> 5, f -> 6}

6 + 8 x + x^2 + 10 y + 4 x y + 3 y^2


To determine the form of the quadrip, I think the easiest way is to to make a coordinate transformation to main axis. Then the behavior can be read from the coefficients of the quadratic terms. The transformation can be done with the procedure below. It takes a polynomial 2. order and returns the same polynomials with main axis variables (note, the determinant of the quadratic coefficient must not be zero):

hauptAT[poly_] :=
Module[{var = Variables[poly], quadrErg, lin, x1, x2, x3, a1, a2,
a3 , ev, poly1, var2, c, n},
n = Length[var];
as = Table[a[i], {i, n}];

c1_] := (lin =
Select[Coefficient[(var . c2 . var+ c1.var /.
Thread[var -> (var - as)]), # ],
FreeQ[Alternatives @@ var]] & /@ var;
as /. Solve[lin == 0, as][[1]]);

var2 = Outer[Times, var, var];
c2 = Map[If[MatchQ[#, _^2], 1, 1/2] Coefficient[poly, #] & ,
var2, {2}];

ev = Eigenvectors[c2] // N;
poly1 =
poly  /. Thread[var -> Transpose[ev] . var] // Expand // Chop;

c2 = Map[If[MatchQ[#, _^2], 1, 1/2] Coefficient[poly1, #] & ,
var2, {2}];
c1 = Coefficient[poly1, #] & /@ var;
poly1 /. Thread[var -> (var - quadrErg[c2, c1])]  // Expand// Chop
]

poly1 = hauptAT[poly]

131. + 5.8541 x^2 - 0.854102 y^2


If the constant term is positive, multiply by: -1

-poly

-131. - 5.8541 x^2 + 0.854102 y^2


This corresponds to the equation:

- 5.8541 x^2 + 0.854102 y^2 == 131


Now, if both coefficients on the right side are positive, we have an ellipse. If One is negative, a hyperbola: Extreme cases appear if the constant term is zero. Then if the both coefficients have the same sign, only the origin is a solution, if they differ, we have 2 crossing lines.

I dont' find that, so I implement one by myself.

$$\color{red}{\text{But it fails on some cases, e.g.} P(x,y,z)=x^2+y^2-z}$$

Any help would be appreciated.

ConvertPolynomialToQuadraticForm[polynomial_, variables_List] :=
Module[{rules, matrixSize, matrix},
rules = CoefficientRules[polynomial, variables];
matrixSize = Length[variables];
matrix = ConstantArray[0, {matrixSize, matrixSize}];
Do[With[{num = rules[[ruleIndex, 1]],
coeff = rules[[ruleIndex, 2]]},
singleVariablePos = Position[num, 2];
If[Length[singleVariablePos] > 0,
matrix[[singleVariablePos[[1, 1]], singleVariablePos[[1, 1]]]] =
coeff;
Continue[]];
pos = Position[num, 1];
matrix[[pos[[1, 1]], pos[[2, 1]]]] = coeff/2;
matrix[[pos[[2, 1]], pos[[1, 1]]]] = coeff/2;], {ruleIndex,
Length[rules]}];
matrix];
polynomialDegree[expr_] :=
Max[0, Max[Total@*First /@ CoefficientRules[expr]]];
Q4[x_, y_, z_, t_] := Module[{d}, d = 2;
t^d*P[x/t, y/t, z/t] // FullSimplify // Expand];
Q3[x_, y_, z_] :=
Module[{Q4ins}, Q4ins = Q4[x, y, z, t]; Q4ins /. {t -> 0}];

getConclusion[Delta3_, Delta4_] := Module[{},
If[Delta4 == 0,
Print["the surface has a singular point, possibly at infinity. If \
there is only one singular point, the surface is a cylinder or a \
cone. If there are several singular points the surface consists of \
two planes, a double plane or a single line."]];
If[Delta4 > 0 && Delta3 != 0,
Print["the surface is a paraboloid, which is hyperbolic"]];
If[Delta4 > 0 && Delta3 == 0,
Print["the surface is one-sheet hyperboloid."]];
If[Delta4 < 0 && Delta3 != 0,
Print["the surface is a paraboloid, which is elliptic"]];
If[Delta4 < 0 && Delta3 == 0,
Print["the surface is either an ellipsoid or a two-sheet \
hyperboloid???????WHICH ONE DOES IT IS????"]];
If[Delta4 > 0,
Print["this is a ruled surface that has a negative Gaussian \
curvature at every point."]];
If[Delta4 < 0,
Print["it has a positive Gaussian curvature at every point."]];
]

P[x_, y_, z_] :=
x^2 + 2 y^2 + 3 z^2 + 4 x*y + 5 x*z + 6 y*z + 7 x + 8 y + 9 z + 10;
Q4Instance = Q4[x, y, z, t];
Q3Instance = Q3[x, y, z];
PInstance = P[x, y, z];
Delta4 = Det@ConvertPolynomialToQuadraticForm[Q4Instance, {x, y, z, t}]
Delta3 = Det@ConvertPolynomialToQuadraticForm[Q3Instance, {x, y, z}]
getConclusion[Delta3, Delta4];
ContourPlot3D[
PInstance == 0, {x, -10, 10}, {y, -10, 10}, {z, -10, 10}]
`

Yes, the programme looks good enough, adding extra useful Algebraic fingerprint seems better.