1
$\begingroup$

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.

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

2 Answers 2

1
$\begingroup$

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

Fist, your polynomial:

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}];
  
  quadrErg[c2_, 
    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.

$\endgroup$
0
$\begingroup$

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.

$\endgroup$
0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.