CODEWITHSUNDEEP
plotwolfram-mathematicaequation
Elliot
Elliot

Reputation: 5541

How do you solve for the positive roots of a function and graph them as points on a plot of the function in mathematica?

I am attempting to graph the following function and indicate on the plot where the function passes 45 degree slope. I have been able to graph the function itself using the following code:

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]

I need to display the point on each curve where the slope exceeds 45 degrees. However, I have thus far been unable to even solve for the numbers, due to something odd about the hadling of tables in the Solve and Reduce functions. I tried: 

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

But I apparently can't do this with this kind of function, and I am not sure how to add these results to the plot so that each line gets a mark where it crosses. Does anyone know how to set this up?

Upvotes: 1

Views: 354

Answers (2)

Daniel Lichtblau
Daniel Lichtblau

Reputation: 6884

Could find the points via:

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

Out[12]= {0.623422, 0.415615, 0.311711, 0.249369, 0.207807, 0.178121, \ 0.155856}

Here we put together the list of relevant points.

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

Can now plot in any number of ways. Here is one such.

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

Show[p1, p2]

(Being new to this modern world-- or rather, of an age associated with an earlier civilization-- I do not know how to paste in an image.)

(Okay, thanks Leonid. I think I have an image and also indented code.)

(But why are we talking in parentheses??)

enter image description here Daniel Lichtblau Wolfram Research

Edit: I did not much like the picture I gave. Here is one I think is more descriptive.

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]

enter image description here

Upvotes: 2

Leonid Shifrin
Leonid Shifrin

Reputation: 22579

Here is your code, for completeness, with plot parameters slightly modified to zoom into the region of interest:

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

Here is the code to get the solutions (h-coordinates):

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}

Now produce the plot:

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

Finally, combine the plots:

Show[{plot, points}]

enter image description here

Edit:

Responding to the request of cutting plots at the found points - here is one way:

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

and this should be executed after the solutions have been found.

Upvotes: 5

Related Questions