Mathematica: FindRoot для общей касательной

Question

Я задал этот вопрос некоторое время назад, что помогло найти решение.Я пришел к несколько приемлемому подходу, но все еще не полностью, где я хочу это.Предположим, что есть две функции f1[x] и g1[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 и y (скажем, 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 находила как высокие, так и низкие значения x и y для общей касательнойи хранить эти значения таким же образом, что позволяет мне составить список списка?Функции f и g выше - все это сложные функции другой переменной z, и в настоящее время я использую что-то вроде следующего для построения точек касания (должно быть две x и две y) какфункция z.

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

Чтобы найти оценки для {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]

Как видите, в интервале (0,1) есть 2 точки пересечения. Затем вы можете считать точки с графика и использовать их в качестве начальных значений для 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

Чтобы получить пары очков из sol, вы можете использовать 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]

Answer 2

Хорошо, давайте быстро перепишем то, что вы уже сделали:

Используя ваши 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} *)

Определить функцию

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

затем вы можете построить касательные с помощью

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

---

Я кратко отмечаю (ради меня), что уравнения, которые вы использовали (например, для генерации sol1 выше) исходить из того, что касательная линия для f1 в x тангенциально достигает g1 в некоторый момент y, т.е.

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

---

Чтобы выяснить, где находятся общие касательные, вы можете использовать Manipulate:

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}}}]]

определить две касательные линии, используя

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]]

---

Этот процесс может быть автоматизирован, но я не уверен, как это сделать эффективно.