Ebene Quadriken: Kegelschnitte

Länge[
        v_] := (Sqrt[(∑_(k = 1)^(Length[v]))v[[k]]^2])

Ellipse

P = {x, y}
(Subscript[F, 1]) = {-e, 0}
(Subscript[F, 2]) = {e, 0}

gleichung1 = 
      Länge[P - (Subscript[F, 1])] + Länge[P - (Subscript[F, 2])] == 
        2  a

\(gleichung2 = Map[#\^2 &, gleichung1]\)

gleichung3 = Map[Expand, gleichung2]

gleichung4 = 
      Map[# - (2 (e^2) + 2 (x^2) + 2 (y^2)) &, gleichung3]

\(gleichung5 = Map[#\^2 &, gleichung4]\)

gleichung6 = 
      Map[# - (((4 (a^2) - 2 (e^2) - 2 (x^2) - 2 (y^2)))^2) &, 
        gleichung5]

gleichung7 = Map[Factor, gleichung6]

\(gleichung8 = 
      Map[#\/\(16 \( a\^2\) \((a\^2 - e\^2)\)\) &, gleichung7]\)

gleichung9 = 
      Map[Factor, Collect[gleichung8[[1]], {x, y}]]

Drehungen

E // N

Unprotect[C, E]; Remove[C, E];

gleichung = A (x^2) + B x y + C (y^2) + D x + E y + F

drehmatrix[α_] := {{Cos[α], -Sin[α]}, {Sin[α], Cos[α]}}

{X, Y} == drehmatrix[α] . {x, y}

regel = 
      MapThread[
        Rule, {{x, y}, Transpose[drehmatrix[α]] . {X, Y}}]

GLEICHUNG = Collect[gleichung /. regel, {X, Y}]

Coefficient[gleichung /. regel, X Y]

TrigReduce[Coefficient[gleichung /. regel, X Y]]

TrigExpand[%]

Solve[
      Coefficient[gleichung /. regel, X Y] == 0, α]

Solve[
      TrigReduce[Coefficient[gleichung /. regel, X Y]] == 
        0, α]

Solve[
      TrigReduce[Coefficient[gleichung /. regel, X Y]] == 
          0 /. α -> (β/2), β]

Funktion zur Bestimmung des Drehwinkels

Drehwinkel[quadrik_, {x_, y_}] := 
(π/4) /; 
          Coefficient[quadrik, (y^2)] == 
            Coefficient[quadrik, (x^2)];
Drehwinkel[quadrik_, {x_, y_}] := (1/2) 
        ArcTan[Coefficient[quadrik, 
              x y]/(Coefficient[quadrik, (y^2)] - 
                Coefficient[quadrik, (x^2)])]

Bestimmung der Invarianten

GLEICHUNG

Coefficient[GLEICHUNG, X Y]^2 - 
      4  Coefficient[GLEICHUNG, (Y^2)] Coefficient[GLEICHUNG, (X^2)]

Coefficient[GLEICHUNG, X Y]^2 - 
        4  Coefficient[GLEICHUNG, (Y^2)] Coefficient[GLEICHUNG, (X^2)] // 
      TrigReduce

Funktion zur Bestimmung des Typus

Typus[quadrik_, {x_, y_}] := 
      Module[{s = 
            Sign[Coefficient[quadrik, x y]^2 - 
                4  Coefficient[quadrik, (y^2)] 
                  Coefficient[quadrik, (x^2)]]}, 
If[
          s == -1, "Ellipse", 
          If[s == 
              1, "Hyperbel", "Parabel"]]
]

Beispiel 1

quadrik = x y - 1

Needs["Graphics`ImplicitPlot`"]

ImplicitPlot[quadrik == 0, {x, -5, 5}, {y, -5, 5}]

Drehwinkel[quadrik, {x, y}]

Typus[quadrik, {x, y}]

(Subscript[q, 2]) = 
      Expand[quadrik /. regel /. α -> (π/4)]

ImplicitPlot[(Subscript[q, 2]) == 0, {X, -5, 5}, {Y, -5, 5}]

(Subscript[q, 3]) = 
      Expand[quadrik /. 
            regel /. α -> -(π/4)]

ImplicitPlot[(Subscript[q, 3]) == 0, {X, -5, 5}, {Y, -5, 5}]

Beispiel 2

quadrik = (x^2) + (y^2) - x y - 1

ImplicitPlot[quadrik == 0, {x, -5, 5}, {y, -5, 5}]

Drehwinkel[quadrik, {x, y}]

Typus[quadrik, {x, y}]

(Subscript[q, 2]) = 
      Expand[quadrik /. regel /. α -> (π/4)]

ImplicitPlot[(Subscript[q, 2]) == 0, {X, -5, 5}, {Y, -5, 5}]

(Subscript[q, 3]) = 
      Expand[quadrik /. 
            regel /. α -> -(π/4)]

ImplicitPlot[(Subscript[q, 3]) == 0, {X, -5, 5}, {Y, -5, 5}]

Beispiel 3

quadrik = (x^2) + (y^2) - 2  x y - x

ImplicitPlot[quadrik == 0, {x, -5, 5}, {y, -5, 5}, 
      PlotPoints -> 100]

Drehwinkel[quadrik, {x, y}]

Typus[quadrik, {x, y}]

(Subscript[q, 2]) = 
      Expand[quadrik /. regel /. α -> (π/4)]

ImplicitPlot[(Subscript[q, 2]) == 0, {X, -5, 5}, {Y, -5, 5}]

(Subscript[q, 3]) = 
      Expand[quadrik /. 
            regel /. α -> -(π/4)]

ImplicitPlot[(Subscript[q, 3]) == 0, {X, -5, 5}, {Y, -5, 5}]

Beispiel 4

quadrik = 
      2  (x^2) + 5  (y^2) - 12  x y + 7  x - (3/7) y + 13

ImplicitPlot[quadrik == 0, {x, -5, 5}, {y, -5, 5}, 
      PlotPoints -> 100]

Drehwinkel[quadrik, {x, y}]

N[%]

Typus[quadrik, {x, y}]

(Subscript[q, 2]) = 
      Expand[quadrik /. regel /. α -> 
            Drehwinkel[quadrik, {x, y}]]

(Subscript[q, 2]) // FullSimplify

% // Expand

ImplicitPlot[(Subscript[q, 2]) == 0, {X, -5, 5}, {Y, -5, 5}]

Polarkoordinatendarstellung von Kegelschnitten

Ellipse

ellipse1 = ((((x - e))^2)/(a^2)) + ((y^2)/(b^2)) - 1

ellipse2 = ellipse1 /. {b -> (Sqrt[(a^2) - (e^2)])}

ellipse3 = 
      ellipse2 /. {x -> r Cos[ϕ], 
          y -> r Sin[ϕ]}

Solve[ellipse3 == 0, r]

ellipse4 = Factor[ellipse3]

ellipse4 = 
      Factor[ellipse3 /. 
          Sin[ϕ] -> (Sqrt[1 - Cos[ϕ]^2])]

Solve[ellipse4 == 0, r]

Hyperbel

hypebel1 = ((((x - e))^2)/(a^2)) - ((y^2)/(b^2)) - 1

hypebel2 = hypebel1 /. {b -> (Sqrt[(e^2) - (a^2)])}

hypebel3 = 
      hypebel2 /. {x -> r Cos[ϕ], 
          y -> r Sin[ϕ]}

Solve[hypebel3 == 0, r]

hypebel4 = Factor[hypebel3]

hypebel4 = 
      Factor[hypebel3 /. 
          Sin[ϕ] -> (Sqrt[1 - Cos[ϕ]^2])]

Solve[hypebel4 == 0, r]

Einige graphische Beispiele

r = (1/(1 - 0.9  Cos[ϕ]))

plot1 = 
      ParametricPlot[{r Cos[ϕ], r Sin[ϕ]}, {ϕ, 0, 
          2  π}]

r = (1/(1 - 1.2  Cos[ϕ]))

plot2 = 
      ParametricPlot[{r Cos[ϕ], r Sin[ϕ]}, {ϕ, 0, 
          2  π}]

r = (1/(1 - 1.0  Cos[ϕ]))

plot3 = 
      ParametricPlot[{r Cos[ϕ], r Sin[ϕ]}, {ϕ, 0, 
          2  π}]

Show [plot1, plot2, plot3, 
      PlotRange -> {{-0.5, 15}, {-5, 5}}, 
      AspectRatio -> Automatic]