# Shading a sinusoidal plot at specific regions and animating it

Here's the output that I wish to have:

I have tried to use this code, to finish almost 75% of the work. How to get the final result?

f[\[Alpha]_, a_] := 5*(Sin[\[Alpha]*a]/(\[Alpha]*a)) + Cos[\[Alpha]*a]

Block[{a = 1}, Plot[Sin[\[Alpha]*a]/(\[Alpha]*a), {\[Alpha], -12, 12}, Ticks -> {Range[-4*Pi, 4*Pi, Pi], Automatic}]]

Block[{a = 1}, Plot[Cos[\[Alpha]*a], {\[Alpha], -12, 12}, Ticks -> {Range[-4*Pi, 4*Pi, Pi], Automatic}, AspectRatio -> 1/2]]

test = Plot[f[\[Alpha], 1], {\[Alpha], -13, 13}, Ticks -> {Range[-4*Pi, 4*Pi, Pi], Automatic}]

Show[test, Graphics[{Dashed, Line[{{-13, 1}, {13, 1}}]}], Graphics[{Dashed, Line[{{-13, -1}, {13, -1}}]}]]


I also wish to animate the plot. Any help in this regard would be beneficial!

• Hi codebpr, what is k in your last image, and what parameter do you want to animate?
– alex
Apr 6, 2023 at 8:29
• I wished to show the wave in motion. k is akin to \[Alpha] Apr 6, 2023 at 12:09

I hope the following code will work for you. You can find many resources on how to animate from a Manipulate, but using the Plotter function you can either generate a table of 'frames' and then Rasterize and animate, or some other method you prefer.

In the following code you can manipulate both the lower and upper solutions as well as the coefficient for your function.

Clear[f, Plotter]
f[\[Alpha]_, a_] := 5*(Sin[\[Alpha]*a]/(\[Alpha]*a)) + Cos[\[Alpha]*a];

Plotter[val_ : 1, roots_ : {-1, 1}] :=
Block[{x, solsRange, sols, pos, intervals, diffs},
solsRange = {-5 \[Pi], 5 \[Pi]}; (*
region to look for solutions of the function *)
sols = Sort[Flatten[{
{x, roots[[1]]} /.
NSolve[f[x, val] == roots[[1]] &&
solsRange[[1]] <= x <= solsRange[[2]], x],
{x, roots[[2]]} /.
NSolve[f[x, val] == roots[[2]] &&
solsRange[[1]] <= x <= solsRange[[2]], x]}, 1]](*
assumes that two solutions are needed,
but you can expand it or generalise with MapThread *);
diffs = Abs@Differences[sols[[;; , 2]], 1];
pos = Flatten[
Position[diffs, Select[Union[diffs], # != 0 &][[1]]]]; (*
finds the points where there is discontinuity between solutions*)
intervals = MapThread[sols[[{#, # + 1}]] &, {pos}]; (*
generates the intervals for the rectangles *)

Plot[f[\[Alpha], val], {\[Alpha], -13, 13},
Ticks -> {Range[-4*Pi, 4*Pi, Pi], Automatic}, PlotStyle -> Orange,
Prolog -> {LightBlue, EdgeForm[Thin],
Apply[Rectangle, #] & /@ intervals},
Epilog -> {Gray, Dashed,
Line[{{solsRange[[1]], roots[[1]]}, {solsRange[[2]],
roots[[1]]}}],
Line[{{solsRange[[1]], roots[[2]]}, {solsRange[[2]],
roots[[2]]}}]}] (* plots *)]


If you want to also show the other two plots you can also wrap them all under a Grid.

Manipulate[
Grid@{{Plot[Sin[\[Alpha]*val]/(\[Alpha]*val), {\[Alpha], -12, 12},
Ticks -> {Range[-4*Pi, 4*Pi, Pi], Automatic}]}, {Plot[
Cos[\[Alpha]*val], {\[Alpha], -12, 12},
Ticks -> {Range[-4*Pi, 4*Pi, Pi], Automatic},
AspectRatio -> 1/2]}, {Plotter[val, {root1, root2}]}}, {val, 1,
3}, {{root1, -1}, -2, 0}, {{root2, 1}, 0, 2}]


Let me know if this answered your question. If you want to Export it, then you can find many good resources on SE. Good luck! :)

Clear["Global*"];
f[α_, a_] := 5*(Sin[α*a]/(α*a)) + Cos[α*a];
{lower, upper} = {-1, 1};
intervals =
Reduce[{lower <= f[α, 1] <= upper, -13 <= α <=
13}, α];
filling =
Plot[{f[α, 1], f[α, 1]}, α ∈
ImplicitRegion[intervals, {α}],
Filling -> {1 -> Top, 2 -> Bottom}, FillingStyle -> Cyan,
PlotStyle -> None];
Plot[f[α, 1], {α, -13, 13},
Ticks -> {Range[-4*Pi, 4*Pi, Pi], Automatic}, PlotStyle -> Blue,
Prolog -> {First@filling, Dashed, InfiniteLine[{0, lower}, {1, 0}],
InfiniteLine[{0, upper}, {1, 0}]}]
`