Hauptachsentransformation

Beispiel n=2

A = {{0, 1}, {1, 0}}

Eigensystem[A]

Q = 2  (Subscript[x, 1]) (Subscript[x, 2]) - 2

Needs["Graphics`ImplicitPlot`"]

ImplicitPlot[Q == 0, {(Subscript[x, 1]), -5, 5}, {(Subscript[x, 2]), -5, 5}]

(Subscript[Q, 2]) = 
      Q /. {(Subscript[x, 1]) -> (1/(Sqrt[2])) ((Subscript[y, 1]) + (Subscript[y, 2])), 
            (Subscript[x, 2]) -> (1/(Sqrt[2])) (-(Subscript[y, 1]) + (Subscript[y, 2]))} // 
        Expand

ImplicitPlot[
      (Subscript[Q, 2]) == 0, {(Subscript[y, 1]), -5, 5}, {(Subscript[y, 2]), -5, 5}]

mit Verschiebungsterm

(Subscript[Q, 3]) = 2  (Subscript[x, 1]) (Subscript[x, 2]) - (Subscript[x, 1]) + 2  (Subscript[x, 2]) - 2

ImplicitPlot[
      (Subscript[Q, 3]) == 0, {(Subscript[x, 1]), -5, 5}, {(Subscript[x, 2]), -5, 5}]

(Subscript[Q, 4]) = 
      (Subscript[Q, 3]) /. {(Subscript[x, 1]) -> (1/(Sqrt[2])) ((Subscript[y, 1]) + (Subscript[y, 2])), 
            (Subscript[x, 2]) -> (1/(Sqrt[2])) (-(Subscript[y, 1]) + (Subscript[y, 2]))} // 
        Expand

ImplicitPlot[
      (Subscript[Q, 4]) == 0, {(Subscript[y, 1]), -5, 5}, {(Subscript[y, 2]), -5, 5}]

Beispiel n=3

A = {{1, -3, 1}, {-3, 11, 1}, {1, 1, 9}}

CharacteristicPolynomial[A, t]

sys = Eigensystem[A]

Table[Norm[sys[[2, k]]], {k, 3}]

T = 
      Transpose[
        Table[sys[[2, k]]/Norm[sys[[2, k]]], {k, 3}]]

Transpose[T]

Inverse[T]

Q = 
      ((Subscript[x, 1])^2) + 11  ((Subscript[x, 2])^2) + 9  ((Subscript[x, 3])^2) - 6  (Subscript[x, 1]) (Subscript[x, 2]) + 
        2  (Subscript[x, 1]) (Subscript[x, 3]) + 2  (Subscript[x, 2]) (Subscript[x, 3]) - 1

Needs["Graphics`ContourPlot3D`"]

ContourPlot3D[
      Q, {(Subscript[x, 1]), -2, 2}, {(Subscript[x, 2]), -2, 2}, {(Subscript[x, 3]), -2, 2}, 
      PlotPoints -> 7]

MapThread[
      Rule, {{(Subscript[x, 1]), (Subscript[x, 2]), (Subscript[x, 3])}, T . {(Subscript[y, 1]), (Subscript[y, 2]), (Subscript[y, 3])}}]

Q /. MapThread[
        Rule, {{(Subscript[x, 1]), (Subscript[x, 2]), (Subscript[x, 3])}, T . {(Subscript[y, 1]), (Subscript[y, 2]), (Subscript[y, 3])}}]

(Subscript[Q, 2]) = 
      Q /. MapThread[Rule, {{(Subscript[x, 1]), (Subscript[x, 2]), (Subscript[x, 3])}, T . {(Subscript[y, 1]), (Subscript[y, 2]), (Subscript[y, 3])}}] // 
        Expand

ContourPlot3D[
      (Subscript[Q, 2]), {(Subscript[y, 1]), -2, 2}, {(Subscript[y, 2]), -2, 2}, {(Subscript[y, 3]), -2, 2}, 
      PlotPoints -> 5]

mit Verschiebungsterm

(Subscript[Q, 3]) = 
      ((Subscript[x, 1])^2) + 11  ((Subscript[x, 2])^2) + 9  ((Subscript[x, 3])^2) - 6  (Subscript[x, 1]) (Subscript[x, 2]) + 
        2  (Subscript[x, 1]) (Subscript[x, 3]) + 2  (Subscript[x, 2]) (Subscript[x, 3]) - 6  (Subscript[x, 1]) + 2  (Subscript[x, 2]) + 2  (Subscript[x, 3]) - 
        1

ContourPlot3D[
      (Subscript[Q, 3]), {(Subscript[x, 1]), -2, 2}, {(Subscript[x, 2]), -2, 2}, {(Subscript[x, 3]), -2, 2}, 
      PlotPoints -> 5]

(Subscript[Q, 4]) = 
      (Subscript[Q, 3]) /. MapThread[Rule, {{(Subscript[x, 1]), (Subscript[x, 2]), (Subscript[x, 3])}, T . {(Subscript[y, 1]), (Subscript[y, 2]), (Subscript[y, 3])}}] // 
        Expand

ContourPlot3D[
      (Subscript[Q, 4]), {(Subscript[y, 1]), -2, 2}, {(Subscript[y, 2]), -2, 2}, {(Subscript[y, 3]), -2, 2}, 
      PlotPoints -> 5]

ohne Normierung

T = Transpose[Table[sys[[2, k]], {k, 3}]]

54*Inverse[T]

(Subscript[Q, 5]) = 
      Q /. MapThread[Rule, {{(Subscript[x, 1]), (Subscript[x, 2]), (Subscript[x, 3])}, T . {(Subscript[y, 1]), (Subscript[y, 2]), (Subscript[y, 3])}}] // 
        Expand

mit Verschiebungsterm

(Subscript[Q, 6]) = 
      (Subscript[Q, 3]) /. MapThread[Rule, {{(Subscript[x, 1]), (Subscript[x, 2]), (Subscript[x, 3])}, T . {(Subscript[y, 1]), (Subscript[y, 2]), (Subscript[y, 3])}}] // 
        Expand

ContourPlot3D[
      (Subscript[Q, 6]), {(Subscript[y, 1]), -2, 2}, {(Subscript[y, 2]), -2, 2}, {(Subscript[y, 3]), -2, 2}, 
      PlotPoints -> 7]

Beispiel n=4

A = {{1, -3, 1, 0}, {-3, 11, 1, 0}, {1, 1, 9, 0}, {0, 0, 0, 
          0}}

sys = Eigensystem[A]

T = 
      Transpose[
        Table[sys[[2, k]]/Norm[sys[[2, k]]], {k, 4}]]

Q = 
      ((Subscript[x, 1])^2) + 11  ((Subscript[x, 2])^2) + 9  ((Subscript[x, 3])^2) - 6  (Subscript[x, 1]) (Subscript[x, 2]) + 
        2  (Subscript[x, 1]) (Subscript[x, 3]) + 2  (Subscript[x, 2]) (Subscript[x, 3])

(Subscript[Q, 2]) = 
      Q /. MapThread[
            Rule, {{(Subscript[x, 1]), (Subscript[x, 2]), (Subscript[x, 3]), (Subscript[x, 4])}, T . {(Subscript[y, 1]), (Subscript[y, 2]), (Subscript[y, 3]), (Subscript[y, 4])}}] // 
        Expand

Beispiel n=4 ohne schöne Eigenwerte

A = {{1, -3, 1, 0}, {-3, 11, 1, 0}, {1, 1, 9, 2}, {0, 0, 2, 
          0}}

P = CharacteristicPolynomial[A, t]

Solve[P == 0, t]

NSolve[P == 0, t]

sys = Eigensystem[A]

T = 
      Transpose[
        Table[sys[[2, k]]/Norm[sys[[2, k]]], {k, 4}]]

Q = 
      ((Subscript[x, 1])^2) + 11  ((Subscript[x, 2])^2) + 9  ((Subscript[x, 3])^2) - 6  (Subscript[x, 1]) (Subscript[x, 2]) + 
        2  (Subscript[x, 1]) (Subscript[x, 3]) + 2  (Subscript[x, 2]) (Subscript[x, 3]) + 4  (Subscript[x, 3]) (Subscript[x, 4])

Q /. 
          MapThread[
            Rule, {{(Subscript[x, 1]), (Subscript[x, 2]), (Subscript[x, 3]), (Subscript[x, 4])}, T . {(Subscript[y, 1]), (Subscript[y, 2]), (Subscript[y, 3]), (Subscript[y, 4])}}] // 
        N // Expand

Q /. 
            MapThread[
              Rule, {{(Subscript[x, 1]), (Subscript[x, 2]), (Subscript[x, 3]), (Subscript[x, 4])}, 
                T . {(Subscript[y, 1]), (Subscript[y, 2]), (Subscript[y, 3]), (Subscript[y, 4])}}] // N // Expand // 
      Chop