# Can I get the given plot without calculating the roots numerically? Is it possible to use Manipulate/Animate to get a continuous line of the points?

I have two functions $$F(x,y)$$ and $$G(x,y)$$ for $$0 and $$-1\leq y \leq1$$. Given a specific value of $$y$$, I want to find those values of $$x$$ for which we have $$F=0$$ and $$G\neq \pm 1$$.

For example, for $$y=-1$$, using NSolve, I get

y := -1;

F := -((3 Sin[3 x])/(2 x)) -  Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/ x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2];

G := Cos[3 x] + ((1 + 2 x Cot[2 x] - x Cos[y] Csc[x] Sec[x]) Sin[ 3 x])/(2 x);

NSolve[F == 0 && 0 < x < 3 , x]
(*{{x -> 1.0472}, {x -> 1.12061}, {x -> 1.37163}, {x -> 1.88921}, {x ->  2.0944}}*)

NSolve[G == 1 && 0 < x < 3 , x]
(*{{x -> 0.510074}, {x -> 1.30826}, {x -> 1.5708}, {x -> 2.0944}, {x ->  2.44336}}*)

NSolve[G == -1 && 0 < x < 3 , x]
(* {{x -> 0.898222}, {x -> 1.0472}, {x -> 1.5708}, {x -> 1.86278}, {x ->  2.86912}} *)


hence, desired roots for $$x$$ are  { {x -> 1.12061}, {x -> 1.37163}, {x -> 1.88921} }. Then, I can show these points together with my original functions $$F$$ and $$G$$, using this code

p1 := Plot[{F, G}, {x, 0, 3}, PlotRange -> {-1, 2}, PlotPoints -> 300, PlotLegends -> "Expressions", AxesLabel -> Automatic];

p2 = ListPlot[{  {1.1206084032394001,   1.5 }   , {1.3716304436307527,  1.5   } , {1.889214526133747  ,   1.5  }     },  PlotMarkers -> {"\[Diamond]", Large}, PlotStyle -> Red]  ;

Show[{p1, p2}, PlotRange -> All]



as this picture

I have two questions:

Is there any way to get this picture without calculating the precise values of the roots (which we did byNSolve)? I mean something like using a conditional plot.

If the answer to the above question is YES, then, is it possible to use Manipulate/ Animate to get a continuous line of these red points when $$y$$ changes from $$-1$$ to $$1$$?

Ex. 1

F := -((3 Sin[3 x])/(2 x)) + Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/ x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2];

G := Cos[3 x] + (2 Sin[3 x])/x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x];

With[{rat =  F /. {{f_ :> f}, {r : Sqrt[_] :> -r}} // Apply@Times // Expand // Simplify, F = F, G = G},  Manipulate[ Normal@Plot[{F, G}, {x, 4, 5}, PlotRange -> {-1, 1}, PlotPoints -> 500, PerformanceGoal -> "Speed",
MeshFunctions -> {Function @@ {x, rat}}, MeshStyle -> Blue,
Mesh -> {{0}}] /.   Point[p_] :> Point[p /. {x_Real, z_Real} :> {x, 0.5}] //
DeleteCases[#,  Point[{x0_, _}] /; Abs[F /. x -> x0] > 0.1  ||  Abs[G^2 -1 /. x -> x0] < 0.01 ,  Infinity ] &, {y, 1, 3}]]


Normal@Plot[{F, G}, {x, 0, 3},
PlotRange -> {-1, 2}, PlotPoints -> 300,
PlotLegends -> "Expressions", AxesLabel -> Automatic,
MeshFunctions -> {Function[x, Re@F // Evaluate]} // Evaluate,
MeshStyle -> Red, Mesh -> {{0}}] /.
Point[p_] :> Point[p /. {x_Real, y_Real} :> {x, 1.5}]


One of the roots of F is not a simple root and F does not cross zero at it; hence the mesh functions miss it.

Update

Clear[x, y];
With[{rat =
F /. {{f_ :> f}, {r : Sqrt[_] :> -r}} // Apply@Times // Expand //
Simplify, F = F, G = G},
Manipulate[
Normal@Plot[{F, G}, {x, 0, 3},
PlotRange -> {-1, 2}, PlotPoints -> 200,
PerformanceGoal -> "Speed",
MeshFunctions -> {Function @@ {x, rat}}, MeshStyle -> Red,
Mesh -> {{0}}] /.
Point[p_] :> Point[p /. {x_Real, z_Real} :> {x, 1.5}] //
DeleteCases[#,
Point[{x0_, _}] /; Abs[F /. x -> x0] > 0.1 || Abs[G^2 - 1 /. x -> x0] < 0.01,
Infinity] &,
{y, -5, 0}
]
]


Not sure why PerformanceGoal -> "Speed" is needed to get a quality plot. (Some points are dropped if "Quality" is specified, even though no points are lost if evaluated outside Manipulate.)

• To get all 5 points: rat = F /. {{f_ :> f}, {r : Sqrt[_] :> -r}} // Apply@Times // Expand // Simplify; Normal@Plot[{F, G}, {x, 0, 3}, PlotRange -> {-1, 2}, (*...*) MeshFunctions -> {Function[x, rat // Evaluate]} // Evaluate, Mesh -> {{0}}] /. Point[p_] :> Point[p /. {x_Real, y_Real} :> {x, 1.5}] // DeleteCases[#, Point[{x0_, _}] /; Abs[F /. x -> x0] > 0.1, Infinity] & Commented Jan 25, 2022 at 1:14
• @math2021 I got rid of $G=\pm1$, but for the trajectories, you would either have to calculate the zeros for all $y$ in a range or save them from each calculation & plot all the saved perhaps connected with Line[] (though if you scrub the slider back and forth quickly, you'll probably create a mess). Another issue is that around $y=-\pi$ there is only one root, so tracing three trajectories through that singularity poses a challenge. Commented Jan 25, 2022 at 14:40
• @math2021 The following calculates the trajectories of the zeros, somehow avoiding the singularity (lucky round-off error?). You asked not to numerically solve for the roots, but why not share the idea?: ics = Times @@ Subtract @@@ Flatten@NSolve[F == 0 && 0 < x < Pi && G^2 != 1 /. x -> x[y] /. y -> -2 Pi, x[-2 Pi]] == 0; x /. NDSolve[{Equal @@@ First@Solve[D[F /. x -> x[y], y] == 0, x'[y]], ics}, x, {y, -2 Pi, 0}] // ListLinePlot --- If it seems a feasible approach, we could go into it further. Commented Jan 25, 2022 at 15:22
• @math2021 The || Abs[G^2 - 1 /. x -> x0] < 0.01 (where || means Or) deletes any value of x0 where the value of G^2 at x equal to x0 is closer to 1 than 0.01. Add the same with H (or whatever) instead of G. (You can change the 0.01 if needed. Since the values generated by Plot are only roughly approximate, you have to pick a threshold.) Commented Jan 27, 2022 at 16:34

# Review

• y=-1

Except NSolve or Reduce, none of the other three methods can include all the root! We can compare the four pictures.

f[x_, y_] = -((3 Sin[3 x])/(2 x)) -
Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/
x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2];
g[x_, y_] =
Cos[3 x] + ((1 + 2 x Cot[2 x] - x Cos[y] Csc[x] Sec[x]) Sin[
3 x])/(2 x);
fig1 = Plot[f[x, -1], {x, 0, 3}, Exclusions -> {{f[x, -1] == 0}},
ExclusionsStyle -> {Directive[Green, Thin], Directive[Red, Thick]},
PlotRange -> {-2, 2},
PlotLegends -> "Expressions"]; (* Method by Edmund *)
fig2 = Plot[f[x, -1], {x, 0, 3}, MeshFunctions -> {#2 &},
Mesh -> {{0}}, MeshStyle -> Red, PlotRange -> {-2, 2},
PlotLegends -> "Expressions"];
fig3 = With[{plot = Plot[{f[x, -1], 0}, {x, 0, 3}]},
Show[plot,
Graphics[{Red,
Point[GraphicsMeshFindIntersections[plot,
GraphicsMeshAllPoints -> True]]}], PlotRange -> {-2, 2}]];
fig4 = Plot[f[x, -1], {x, 0, 3},
Epilog -> {Red,
Point[{#, 0} & /@
Evaluate@NSolveValues[{f[x, -1] == 0, 0 < x <= 3}, x]]},
PlotRange -> {-2, 2}, PlotLegends -> "Expressions"];
GraphicsGrid[{{fig1, fig2}, {fig3, fig4}}]


• y=1/2
f[x, y] /. {x -> π/3, y -> 1/2}
f[x, y] /. {x -> 2π/3, y -> 1/2}


0

Edit

Not so perfect.

Clear[F, G, fig];
F[x_, y_] = -((3 Sin[3 x])/(2 x)) -
Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/
x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2];
G[x_, y_] =
Cos[3 x] + ((1 + 2 x Cot[2 x] - x Cos[y] Csc[x] Sec[x]) Sin[
3 x])/(2 x);
fig[y_] :=
Module[{plotF, plotG, ptsF, ptsG},
plotF = Plot[{F[x, y], 0}, {x, 0, 3}, PlotStyle -> {Orange, Gray}];
ptsF =
GraphicsMeshFindIntersections[plotF,
GraphicsMeshAllPoints -> True];
plotG = Plot[{G[x, y], 0}, {x, 0, 3}, PlotStyle -> {Cyan, Gray}];
(*ptsG=GraphicsMeshFindIntersections[plotG,
GraphicsMeshAllPoints->True];*)
Show[plotG, plotF,
Graphics[{Red, Point[TranslationTransform[{0, 1.5}] /@ ptsF],
Green, Point[{{π/3, 0}, {2 π/3, 0}}]}]]];
Manipulate[fig[y], {y, -1, 1}, ControlPlacement -> Bottom]


Original

Clear[F, G];
F = -((3 Sin[3 x])/(2 x)) -
Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/
x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2];

G = Cos[3 x] + ((1 + 2 x Cot[2 x] - x Cos[y] Csc[x] Sec[x]) Sin[
3 x])/(2 x);

Reduce[{F == 0, G == 1, 0 < x <= 3, -1 <= y <= 1}, {x, y}]
Reduce[{F == 0, G == -1, 0 < x <= 3, -1 <= y <= 1}, {x, y}]


x == (2 π)/3 && -1 <= y <= 1

x == π/3 && -1 <= y <= 1

It means that if we want to get F==0,G!=1,G!=-1, we just need to exclude x == (2 π)/3 and x == π/3  in F==0.

Clear[F, G, y];
F = -((3 Sin[3 x])/(2 x)) -
Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/
x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2];
G = Cos[3 x] + ((1 + 2 x Cot[2 x] - x Cos[y] Csc[x] Sec[x]) Sin[
3 x])/(2 x);
y = -1;
Plot[{F, G}, {x, 0, 3},
Epilog -> {Dashed, InfiniteLine[{π/3, 0}, {0, 1}],
InfiniteLine[{2 π/3, 0}, {0, 1}],
Text[Style["x=π/3", Red], {π/3, 5}, {-1, -1}],
Text[Style["x=2π/3", Red], {2 π/3, 5}, {-1, -1}]}]


• Thank you very much. My question was to show those three red points (in the picture attached to the text) without calculating their precise values numerically; something like using the conditional plots (or any other ways that I am unaware of) for $F=0$ and $G\neq\pm1$. Since my problem is much more complicated in the general case, and, it is not easy to deal with them numerically; and, in the next step, manipulating those results for different values of $y$. @cvgmt Commented Jan 24, 2022 at 15:13
• Thank you for the update. Commented Jan 24, 2022 at 17:01

You may use the Exclusions option of Plot.

First define your functions with SetDelayed to prevent variable scope issues.

Clear[f, g, x, y]
f[x_, y_] := -((3 Sin[3 x])/(2 x)) -
Sqrt[-1 + (Cos[3 x] + (2 Sin[3 x])/x + (Cos[2 x] - Cos[y]) Csc[2 x] Sin[3 x])^2]
g[x_, y_] := Cos[3 x] + ((1 + 2 x Cot[2 x] - x Cos[y] Csc[x] Sec[x]) Sin[3 x])/(2 x)


The Exclusions spec for y = -1 can be satisfied by

{f[x, -1] == 0, g[x, -1] != 1 && g[x, -1] != -1}


Included in Plot

Plot[
{f[x, -1], g[x, -1]}
, {x, 0, 3}
, Exclusions -> {{f[x, -1] == 0, g[x, -1] != 1 && g[x, -1] != -1}}
, ExclusionsStyle -> {Directive[Green, Thin], Directive[Red, Thick]}
, PlotRange -> {-2, 2}
, PlotLegends -> "Expressions"
]


The red markers appear on the plot curves instead of floating. However, this is easy to Manipulate.

Manipulate[
Plot[
{f[x, my], g[x, my]}
, {x, 0, 3}
, Exclusions -> {{f[x, my] == 0, g[x, my] != 1 && g[x, my] != -1}}
, ExclusionsStyle -> {Directive[Green, Thin], Directive[Red, Thick]}
, PlotRange -> {-2, 2}
, PlotLegends -> {Inactive[f][x, my], Inactive[g][x, my]}
]
, {{my, -1, "y"}, -1, 1}
]


Note that the Exclusions spec can be used to simplify solving the x values if you want to go the Epilog route with InfiniteLine.

xvalues = NSolveValues[{f[x, -1] == 0, g[x, -1] != 1 && g[x, -1] != -1 && 0 < x < 3}, x]

{1.12061, 1.37163, 1.88921}


Then

Plot[
{f[x, -1], g[x, -1]}
, {x, 0, 3}
, Exclusions -> {{f[x, -1] == 0, g[x, -1] != 1 && g[x, -1] != -1}}
, ExclusionsStyle -> None
, PlotRange -> {-2, 2}
, PlotLegends -> "Expressions"
, Epilog -> {Red, Dashed, InfiniteLine[{#, 0}, {0, 1}] & /@ xvalues}
]
`

Hope this helps.