Mathematica：一般的な接線のFindRoot

Question

私はこのquestionにちょっと戻って、解決に手伝ってくれました。私は幾分容認できるアプローチに着きましたが、それでも私が望む場所にはまだまだありません。 f1[x]とg1[y]という2つの関数があり、共通接線の値をxとyとしたいとします。私は、少なくとも以下で例えば接線のいずれかのxとyを決定することができます。しかし、あなたはxのやや大きい値で別の共通の接線が存在することがプロットから気づくとyます

f1[x_]:=(5513.12-39931.8x+23307.5x^2+(-32426.6+75662.x-43235.4x^2)Log[(1.-1.33333x)/(1.-1.x)]+x(-10808.9+10808.9x)Log[x/(1.-1.x)])/(-1.+x) 
g1[y_]:=(3632.71+3806.87y-51143.6y^2+y(-10808.9+10808.9y)Log[y/(1.-1.y)]+(-10808.9+32426.6y-21617.7y^2)Log[1.-(1.y)/(1.-1.y)])/(-1.+y) 

Show[ 
Plot[f1[x],{x,0,.75},PlotRange->All], 
Plot[g1[y],{y,0,.75},PlotRange->All] 
] 

Chop[FindRoot[ 
{ 
(f1[x]-g1[y])/(x-y)==D[f1[x],x]==D[g1[y],y] 
}, 
{x,0.0000001},{y,.00000001} 
] 
[[All,2]] 
] 

（例えば、x〜4およびy〜5）。さて、興味深いことに、私は少し、以下のようなものにf1[x]とg1[y]については、上記の式を変更する場合：

f2[x_]:=(7968.08-59377.8x+40298.7x^2+(-39909.6+93122.4x-53212.8x^2)Log[(1.-1.33333x)/(1.-1.x)]+x(-13303.2+13303.2x)Log[x/(1.-1.x)])/(-1.+x) 
    g2[y_]:=(5805.16-27866.2y-21643.y^2+y(-13303.2+13303.2y)Log[y/(1.-1.y)]+(-13303.2+39909.6y-26606.4y^2)Log[1.-(1.y)/(1.-1.y)])/(-1.+y) 

    Show[ 
    Plot[f2[x],{x,0,.75},PlotRange->All], 
    Plot[g2[y],{y,0,.75},PlotRange->All] 
    ] 

    Chop[FindRoot[ 
    { 
    (f2[x]-g2[y])/(x-y)==D[f2[x],x]==D[g2[y],y] 
    }, 
    {x,0.0000001},{y,.00000001} 
    ] 
    [[All,2]] 
    ] 

、共通の接線を決定するために、同じ方法を使用し、Mathematicaはxの大きな値を見つけるために選択し、yのため正の傾斜接線。

最後に私の質問は、Mathematicaに共通の正接の値の高い値と低い値の両方を見つけさせ、リストプロットを作成するのと同様の方法でこれらの値を保存できるのでしょうか？上記の関数fとgはすべて別の変数の複雑な関数で、zです。私は現在、zの関数として2つの接線の点（2つのxと2つのy）をプロットするために次のようなものを使用しています。

ex[z_]:=Chop[FindRoot[ 
{ 
(f[x,z]-g[y,z])/(x-y)==D[f[x],x]==D[g[y],y] 
}, 
{x,0.0000001},{y,.00000001} 
] 
[[All,2]] 
] 

ListLinePlot[ 
Table[{ex[z][[i]],z},{i,1,2},{z,1300,1800,10}] 
] 

Answer 1

OK、それでは、すぐにあなたがこれまでに何をやったか書き直してみましょう：

をごf1とg1を使用して、我々は、プロット

plot = Plot[{f1[x], g1[x]}, {x, 0, .75}] 

と第一を持っています共有接線：

sol1 = Chop[FindRoot[{(f1[x] - g1[y])/(x - y) == D[f1[x], x] == D[g1[y], y]}, 
    {x, 0.0000001}, {y, .00000001}]] 

(* {x -> 0.00840489, y -> 0.105801} *) 

はあなたの方程式あなたを

Show[plot, Graphics[Point[{l1[0], l1[1]}]], 
    ParametricPlot[l1[t], {t, -1, 2}], 
    PlotRange -> {{-.2, .4}, {-10000, 10000}}] 

---

私は簡単に（私自身のために）注意して使用していることを接線をプロットすることができ、

l1[t_] = (1 - t) {x, f1[x]} + t {y, g1[y]} /. sol1 

、関数を定義します を使用してください（例えば、上記のsol1を生成する場合）図10は、f1の接線がx の接線がある点でg1の接線yすなわち、

LogicalExpand[{x, f[x]} + t {1, f'[x]} == {y, g[y]} && f'[x] == g'[y]] 

---

共有接線がどこにあるかを調べるために、あなたはManipulateを使用することができます。

ためeyeballed値を使用して

のようなものを生成

Manipulate[Show[plot, ParametricPlot[{x, f1[x]} + t {1, f1'[x]}, {t, -1, 1}]], 
     {x, 0, .75, Appearance -> "Labeled"}] 

xおよびy、あなたは

sol = Chop[Table[ 
    FindRoot[{(f1[x] - g1[y])/(x - y) == D[f1[x], x] == D[g1[y], y]}, 
    {x, xy[[1]]}, {y, xy[[2]]}], {xy, {{0.001, 0.01}, {0.577, 0.4}}}]] 

を使用して、実際のソリューションは、このプロセスCOU

l[t_] = (1 - t) {x, f1[x]} + t {y, g1[y]} /. sol 

その後、

Show[plot, Graphics[Point[Flatten[{l[0], l[1]}, 1]]], 
ParametricPlot[l[t], {t, -1, 2}, PlotStyle -> Dotted]] 

---

を使用して、2本の接線を定義得ることができます自動化されていますが、効率的に行う方法がわかりません。

Answer 2

方程式を解く{x, y}の見積もりを見つけるには、それらをContourPlotにプロットし、交差点を探します。

f1[x_]:=(5513.12-39931.8 x+23307.5 x^2+(-32426.6+75662. x- 
    43235.4 x^2)Log[(1.-1.33333 x)/(1.-1.x)]+ 
    x(-10808.9+10808.9 x) Log[x/(1.-1.x)])/(-1.+x) 
g1[y_]:=(3632.71+3806.87 y-51143.6 y^2+y (-10808.9+10808.9y) Log[y/(1.-1.y)]+ 
    (-10808.9+32426.6 y-21617.7 y^2) Log[1.-(1.y)/(1.-1.y)])/(-1.+y) 

plot = ContourPlot[{f1'[x] == g1'[y], f1[x] + f1'[x] (y - x) == g1[y]}, 
    {x, 0, 1}, {y, 0, 1}, PlotPoints -> 40] 

たとえば、あなたが2つの交点は区間(0,1)である見ることができるように。その後、グラフからポイントを読み取るとFindRootの値を出発物質としてこれらを使用することができます。

seeds = {{.6,.4}, {.05, .1}}; 
sol = FindRoot[{f1'[x] == g1'[y], f1[x] + f1'[x] (y - x) == g1[y]}, 
    {x, #1}, {y, #2}] & @@@ seeds 

ゾルからポイントのペアを取得するには、あなたがReplaceAllを使用することができます。

points = {{x, f1[x]}, {y, g1[y]}} /. sol 

(* 
==> {{{0.572412, 19969.9}, {0.432651, 4206.74}}, 
     {{0.00840489, -5747.15}, {0.105801, -7386.68}}} 
*) 

これらのことを表示するには正しいのポイントは以下のとおりです。

Show[Plot[{f1[x], g1[x]}, {x, 0, 1}], 
{ParametricPlot[#1 t + (1 - t) #2, {t, -5, 5}, PlotStyle -> {Gray, Dashed}], 
    Graphics[{PointSize[Medium], Point[{##}]}]} & @@@ points]