1. 2. 3. で2次曲線を変形し、標準形の焦点を求めました。今回はその変形を逆にたどって任意の2次曲線の焦点を求めます。
行列 A, F および定数 c を変えることにより、任意の行列（放物線は未対応）について実行可能です。
概要☟
1. 2. 3. で2次曲線を変形し、標準形の焦点を求めました。今回はその変形を逆にたどって任意の2次曲線の焦点を求めます。
行列 A, F および定数 c を変えることにより、任意の行列（放物線は未対応）について実行可能です。
概要☟
|
|
    
|
コメントをお書きください
math (月曜日, 09 11月 2020 19:24)
(* 標準形への 変換 拝読致しました.
「クリープのない コ-ヒーなんて」
「焦点 F1,F2 の ない 双曲線なんて」
「漸近線の ない 双曲線なんて」
「主軸の ない 双曲線なんて」
「共軛の ない 双曲線なんて」
「直交載線の ない 双曲線なんて」
「鉄鉢の中へも霰」 山頭火
「＿＿＿＿＿のない 双曲線なんて」*)
(*今 焦点 を 拝見*)
(* 以下を 評価願います;*)
Needs["Graphics`ImplicitPlot`"]
f[x_, y_] := -59 + 292 x + 64 x^2 - 364 y - 200 x y + 64 y^2 //
Evaluate
{f[x, y] == 0, \!\(TraditionalForm\`\(-
\*FractionBox[\(1\), \(16\)]\)\ \((32\ x + \((6\
\*SqrtBox[\(41\)] - 50)\)\ y - 3\
\*SqrtBox[\(41\)] + 73)\)\ \((\(-\(32\ x\)\) + \((50 + 6\
\*SqrtBox[\(41\)])\)\ y - 3\
\*SqrtBox[\(41\)] - 73)\)\) == 0,
292 x + 64 x^2 - 364 y - 200 x y + 64 y^2 == -1984,
292 x + 64 x^2 - 364 y - 200 x y + 64 y^2 == -1984 + 694};
CtoAs = ImplicitPlot[%, {x, -9, 8}, {y, -9, 15},
PlotStyle -> {{Thickness[0.0102],
RGBColor[1, 0, 0]}, {Thickness[0.001],
RGBColor[0.3, 0, 0.5]}, {Thickness[0.0071],
RGBColor[0.3, 1, 0.5]}, {Thickness[0.0071],
RGBColor[0.3, 0.4, 0.5]}}, PlotPoints -> 200 - 100,
AspectRatio -> Automatic, PlotPoints -> 276 - 100,
GridLines -> Automatic]
Print[Style[" 漸近線は 特異点を求めて
[其の解消を我慢し] の手法 が在りmath
ので 是非 再考願います!^(2020)", 19, Red]]
Print[Style[" 再掲 ; \[FilledCircle]特異点の解消\[FilledCircle] [由宇町生誕の町 と]",
19 + 4, Magenta]]
{-((3 (6067 + 73 Sqrt[3977] + 2790 t + 82 Sqrt[3977] t + 819 t^2 +
9 Sqrt[3977] t^2))/(32 (-155 - 18 t + 9 t^2))), -((
2 (428 - 3 Sqrt[3977] - 36 t + 3 Sqrt[3977] t + 18 t^2))/(-155 -
18 t + 9 t^2))};
pa0 = ParametricPlot[%, {t, -12, 1}]
pa1 = ParametricPlot[%%, {t, -3, 2}]
f[%%%[[1]], %%%[[2]]] // FullSimplify
% == 0 // TraditionalForm
Show[CtoAs, pa1, PlotRange -> All]
Print[Style[" \[FilledCircle]媒介変数表示 非 ウッソ-\[FilledCircle]", 69 - 33,
Magenta]]
{-4, 3, 1, -2};
{F1, F2} = {{%[[1]], %[[2]]}, {%[[3]], %[[4]]}}
Focus = ListPlot[%, PlotStyle -> {Magenta, PointSize[0.05]},
PlotRange -> All];
Show[CtoAs, Focus];
{x, y} == F1 + t*(F1 - F2)
Eliminate[%, t];
%[[2]] - %[[1]]
H1H2 = ImplicitPlot[{% == 0, 20 + 10 x - 10 y == 0}, {x, -9,
8}, {y, -9, 15},
PlotStyle -> {{Thickness[0.01], RGBColor[0.3, 0.4, 0.5]}},
PlotStyle -> {{Thickness[0.001], RGBColor[0.13, 1, 0.15]}},
PlotPoints -> 2*69, AspectRatio -> Automatic, PlotPoints -> 194,
GridLines -> Automatic];
Show[CtoAs, Focus, H1H2]
% // Timing
SessionTime[] (*このカーネルセッションが始まってからの秒数：*)
Print[Style[" \[FilledCircle]とほほ\[FilledCircle]
［感］情けなく、みじめに感じている時などに発する語", 69 - 33 - 19, Blue]]
Print[Style[" Mathematica Standard 12 日本語DL 版 ［サービス・バンドル］
469,000 円
Mathematica Standard 12 日本語DL 版 ［サービス・プラス・バンドル］
515,900 円
（2019 年10 月1 日改定料金） ", 69 - 33 - 18, Red]]
(***************************************)
小林 (火曜日, 10 11月 2020 09:45)
math さん
ImplicitPlot が相変わらず動きません。今回はContourPlotでもダメでした。
媒介変数は、Eliminate で確かめることが出来ました。驚きです。
本ブログでは、次回は、媒介変数の導入について書きたいと思います。
ところで、啓林館のHPに 西元先生 のお名前がありましたが、
math さんはお知り合いですか？
math (火曜日, 10 11月 2020 11:29)
>ところで、啓林館のHPに 西元先生 のお名前がありましたが、
謦咳に 接した ことは ありません。
啓林館のHP で 屡拝見...
其の 趣味は 自制しておりますが
授業を「覗いて 視 タイ」と おもったことは ∃n デス ハイ
[[心中思うダケ でも 罪=Sin に なる らしい...]]
マジ ↓は よく使います [高次元の2次超曲面の際も] ;
A = {{64, -100}, {-100, 64}};
% // TraditionalForm
Eigensystem[A]
%[[2]]
%[[1]].%[[2]](*の確認 [念のため 嘘をついていないか疑い]*)
[瞬時に叶う]媒介変数表示して 其れの 使い道も多々∃...
◆微分幾何學への 道◆ も ヒラケ math ハイ
[授業 諸々校務 部活 etc で 多忙を極めておられ
其の合間にmathematica 駆使ですね..]
>ImplicitPlot が相変わらず動きません。
何故 無くした かっ! と 思うほど有用です...
旧 ver を 「ちょうだい!^(2020).....」
と ネダレバ 叶えば E--------のに...
横から 覗いておられる 同僚諸氏 にも 懇願し...
math (火曜日, 10 11月 2020 15:35)
（*＞ImplicitPlot が相変わらず動きません。
何故 無くした かっ! と 思慮の無さを 怒髪天です.＊）
f[x_, y_] := -59 + 292 x + 64 x^2 - 364 y - 200 x y + 64 y^2 //
Evaluate
CtoAs = ContourPlot[{f[x, y] == 0, \!\(TraditionalForm\`\(-
\*FractionBox[\(1\), \(16\)]\)\ \((32\ x + \((6\
\*SqrtBox[\(41\)] - 50)\)\ y - 3\
\*SqrtBox[\(41\)] + 73)\)\ \((\(-\(32\ x\)\) + \((50 + 6\
\*SqrtBox[\(41\)])\)\ y - 3\
\*SqrtBox[\(41\)] - 73)\)\) == 0,
292 x + 64 x^2 - 364 y - 200 x y + 64 y^2 == -1984,
292 x + 64 x^2 - 364 y - 200 x y + 64 y^2 == -1984 + 694}, {x, -9,
15}, {y, -9, 15}]
Print[Style[" 等高線 達 も 視たい!^(2020)
「知る権利 行使せむ とて ス なり」\[DownArrow]
英雄でなくとも 色を好む", 69 - 33 - 19, Red]]
contourMap =
ContourPlot[f[x, y], {x, -9, 15}, {y, -9, 15}, Contours -> 69,
ContourShading -> {Purple, Blue, Cyan, Green, Yellow, Pink, Orange,
Red}]
Print[Style[" 直交載線 達 も 微分方程式を解き 視たい!^(2020)
「知る権利 行使せむ とて ス なり を 禁じてはならぬ」", 69 - 33 - 18, Blue]]
{-4, 3, 1, -2};
{F1, F2} = {{%[[1]], %[[2]]}, {%[[3]], %[[4]]}}
Focus = ListPlot[%, PlotStyle -> {Magenta, PointSize[0.05]},
PlotRange -> All];
Show[CtoAs, Focus]
{x, y} == F1 + t*(F1 - F2)
Eliminate[%, t];
%[[2]] - %[[1]]
H1H2 = ContourPlot[% == 0, {x, -9, 8}, {y, -9, 15}];
Show[CtoAs, Focus, H1H2(*,contourMap*), AspectRatio -> Automatic,
GridLines -> Automatic]
小林 (木曜日, 12 11月 2020 19:48)
math 様
Eigensystem 便利ですね。ありがとうございました。
グラフィックも動きました。
また、記事にさせてください。
math (土曜日, 14 11月 2020 23:28)
(* 転がっている 問題 FAQ ；
2/(1 + Sqrt[2] + Sqrt[3])
の分母を有理化しなさい;
[時には (分母に)無理数がない 娘 のように]
多様な発想がありますが.....
●共軛● を前面に明記した方法を↓に記します;*)
1 + Sqrt[2] + Sqrt[3]
MinimalPolynomial[%, x]
Factor[%, Extension -> {%%}]
s = Solve[% == 0, x]
pro = Product[x /. s[[k]], {k, 1, 4 - 1}]
1 + Sqrt[2] + Sqrt[3]
Sitaisiki = 2/%
{(Numerator[%])*(pro), ((Denominator[%])*(pro))}
% // FullSimplify
%[[1]]/%[[2]]
Sitaisiki == % // FullSimplify
Tenmatu = %% // TraditionalForm
N[{Sitaisiki, %}, 69]
https://userdisk.webry.biglobe.ne.jp/020/691/47/N000/000/000/127988895240716210305_index_gr_1_20100723214232.gif
math (月曜日, 16 11月 2020 09:22)
> 10 月 22 日, 2020 年
> Mathematica は大抵のことは期待以上の計算をしてくれますが、分母の有理化は苦手のようです。
気まぐれ で やるとき もあります
一例:
1/(Sqrt[3]+2^(1/2)-5^(1/2))//FullSimplify
(これを 最小多項式を求める 正面突破の手法で も どうぞ:)
FullSimplifyはフェルマ(Fermat)の最終定理を知っている：
FullSimplify[x^n+y^n==z^n,Element[x|y|z|n,Integers]&&n>2&&x y z!=0]
小林 (月曜日, 16 11月 2020 12:24)
math 様
新しい問題提起、ありがとうございました。
この週末は、部活でつぶれたため、更新が出来ませんでした。
媒介変数の方は、出来ました。
更新が遅くて申し訳ありません。