Как вы решаете для положительных корней функции и отображать их в виде точек на графике функции в Mathematica?

Question

Я пытаюсь построить график следующей функции и указать на графике, где функция проходит 45-градусный наклон.Я смог построить график самой функции, используя следующий код:

T = 170 Degree;
f[s_, d_] = Normal[Series[Tan[T - (d*s)], {s, 0, 4}]];
r[h_, d_] = Simplify[Integrate[f[s, d], {s, 0, h}]];
a[h_] = Table[r[h, d], {d, 1, 4, .5}];
Plot[a[h], {h, 0, 4}, PlotRange -> {{0, 4}, {0, -4}}, AspectRatio -> 1]

Мне нужно отобразить точку на каждой кривой, где угол наклона превышает 45 градусов.Тем не менее, я до сих пор не смог найти даже числа, из-за чего-то странного в разборе таблиц в функциях Solve и Reduce.Я попытался:

Reduce[{a'[h] == Table[-1, {Dimensions[a[h]][[1]]}], h >= 0}, h]

Но я, очевидно, не могу сделать это с помощью такого рода функций, и я не уверен, как добавить эти результаты в график, чтобы каждая линия получила отметку в месте пересечения.Кто-нибудь знает, как это настроить?

Answer 1

Вот ваш код, для полноты, с немного измененными параметрами графика для увеличения области интереса:

Clear[d,h,T,f,r,a];
T = 170 Degree;
f[s_, d_] = Normal[Series[Tan[T - (d*s)], {s, 0, 4}]];
r[h_, d_] = Simplify[Integrate[f[s, d], {s, 0, h}]];
a[h_] = Table[r[h, d], {d, 1, 4, .5}];

plot = Plot[a[h], {h, 0, 4}, PlotRange -> {{0, 0.8}, {0, -0.5}}, 
 AspectRatio -> 1, Frame -> {False, True, True, False}, 
 FrameStyle -> Directive[FontSize -> 10], 
 PlotStyle -> {Thickness[0.004]}]

Вот код для получения решения (h-координаты):

In[42]:= solutions = Map[Reduce[{D[#, h] == -1, h >= 0}, h] &, a[h]]

Out[42]= {h == 0.623422, h == 0.415615, h == 0.311711, h == 0.249369, 
   h == 0.207807, h == 0.178121, h == 0.155856}

Теперь производим сюжет:

points = ListPlot[MapIndexed[{#1, a[#1][[First@#2]]} &, solutions[[All, 2]]], 
         PlotStyle -> Directive[PointSize[0.015], Red], 
         PlotRange -> {{0, 0.8}, {0, -0.5}}, AspectRatio -> 1, 
         Frame -> {False, True, True, False}, 
         FrameStyle -> Directive[FontSize -> 10]]

Наконец, объедините графики:

Show[{plot, points}]

Edit:

Отвечая на запрос обрезки участков в найденных точках - вот один из способов:

plot = 
 With[{sols  = solutions[[All, 2]]},
  Plot[Evaluate[a[h]*UnitStep[sols - h]], {h, 0, 4}, 
   PlotRange -> {{0, 0.8}, {0, -0.5}}, AspectRatio -> 1, 
   Frame -> {False, True, True, False}, 
   FrameStyle -> Directive[FontSize -> 10], 
   PlotStyle -> {Thickness[0.004]}]]

, и это должно быть выполнено после того, как решения найдены.

Answer 2

Можно найти точки через:

slope45s = 
 h /. Map[First[Solve[D[#, h] == -1 && h >= 0, h]] &, a[h]]

Out [12] = {0,623422, 0,415615, 0,311711, 0,249369, 0,2073780, 0,178121, \ 0.155856}

Здесь мы собрали список соответствующих пунктов.

pts = Transpose[{slope45s, Tr[a[slope45s], List]}]

Теперь можно строить любым количеством способов. Вот один такой.

p2 = ListPlot[pts, PlotRange -> {{0, 4}, {0, -4}}, 
  PlotStyle -> {PointSize[.01], Red}];
p1 = Plot[a[h], {h, 0, 4}, PlotRange -> {{0, 4}, {0, -4}}, 
  AspectRatio -> 1];

Показать [p1, p2]

(Будучи новичком в этом современном мире - или, скорее, эпохи, связанной с более ранней цивилизацией - я не знаю, как вставить изображение.)

(Хорошо, спасибо Леонид. Мне кажется, у меня есть изображение и код с отступом.)

(Но почему мы говорим в скобках ??)

Даниэль Лихтблау Wolfram Research

Редактировать: Мне не очень понравилась фотография, которую я дал. Вот один, я думаю, более описательный.

makeSegment[pt_, slope_, len_] := 
 Rotate[Line[{pt + {-len/2, 0}, pt + {len/2, 0}}], ArcTan[slope]]

p2 = ListPlot[pts, PlotStyle -> {PointSize[.01], Red}];
p1 = Plot[a[h], {h, 0, 4}, PlotRange -> {{0, 2}, {0, -1}}, 
   AspectRatio -> 1];
p3 = Graphics[Map[{Orange, makeSegment[#, -1, .2]} &, pts]];

Show[p1, p2, p3, AspectRatio -> 1/2, ImageSize -> 1000]