# Is there a Mathematica function that can take only the minimum value of a parametric curve?

I have a parametric equation that loops back over itself. It is much more complex than this, but here is an example. I would like to remove the loopy "cusp" things on top. I am wondering if there is a clean way to do this, perhaps by only taking the smallest value for any given x value? I would like to extract only the bottom "half" of the curve, so there is only one spot on the curve for every value of X.

a := 3;
b = 4;
xPlot[t_] := a * t - b * Sin[t];
yPlot[t_] := a - b * -Cos[t];

ParametricPlot[{{xPlot[t], yPlot[t]}}, {t, -4 Pi, 4 Pi}, ImageSize -> Large]


• You're aware that if you restrict yourself to a == b, you'll get cycloids instead of trochoids, no? – J. M.'s technical difficulties Oct 6 '16 at 3:13
• Welcome to Mathematica.SE! I hope you will become a regular contributor. To get started, 1) take the introductory tour now, 2) when you see good questions and answers, vote them up by clicking the gray triangles, because the credibility of the system is based on the reputation gained by users sharing their knowledge, 3) remember to accept the answer, if any, that solves your problem, by clicking the checkmark sign, and 4) give help too, by answering questions in your areas of expertise. – bbgodfrey Oct 6 '16 at 11:05

a = 3;
b = 4;
xPlot[t_] := a*t - b*Sin[t];
yPlot[t_] := a - b*-Cos[t];


Using NSolve

soln = SortBy[
Thread[-4 Pi <= {t1, t2} <= 4 Pi], t1 < t2} // Flatten, {t1, t2},
Reals], #[[1, -1]] &]

(*  {{t1 -> -7.55888, t2 -> -5.00749}, {t1 -> -1.2757,
t2 -> 1.2757}, {t1 -> 5.00749, t2 -> 7.55888}}  *)

diff = (t1 /. soln // Differences)[[1]]

(*  6.28319  *)

pts = {xPlot[t1], yPlot[t1]} /. soln

(*  {{-18.8496, 4.16334}, {0., 4.16334}, {18.8496, 4.16334}}  *)

ParametricPlot[
{{xPlot[t], yPlot[t]}}, {t, -4 Pi, 4 Pi},
Epilog -> {Red, AbsolutePointSize[6], Point[pts]},
ImageSize -> Large]


Clear[t]

Show[
ParametricPlot[
{{xPlot[t], yPlot[t]}}, #] & /@ ({t,
Sequence @@ #} & /@ ({(t2 /. soln)[[1]] - diff, {t1, t2} /.
soln, (t1 /. soln)[[-1]] + diff} // Flatten //
Partition[#, 2] &)),
PlotRange -> All,
AxesOrigin -> {0, 0},
ImageSize -> Large]


• Is this a clever way of plotting the function, or does it actually create a new function without the cusps? – 888 Oct 6 '16 at 2:06
• This just plots the desired result. If you need a defined function, use Piecewise. If you have trouble with Piecewise post a question with the code that you tried. – Bob Hanlon Oct 6 '16 at 2:34

The following identifies the loops and does not plot them. First identify the crossing points.

Table[FindRoot[{xPlot[t1] == xPlot[t2], yPlot[t1] == yPlot[t2]}, {t1,
n Pi - 3/2, n Pi - 1}, {t2, n Pi + 1, n Pi + 3/2}], {n, -4, 4, 2}]
(* {{t1 -> -13.8421, t2 -> -11.2907}, {t1 -> -7.55888, t2 -> -5.00749},
{t1 -> -1.2757, t2 -> 1.2757}, {t1 -> 5.00749, t2 -> 7.55888},
{t1 -> 11.2907, t2 -> 13.8421}} *)


Then, obtain the first and last value of t between subsequent loops.

Partition[Delete[Flatten[{t1, t2} /. # & /@ %], {{1}, {-1}}], 2]
(* {{-11.2907, -7.55888}, {-5.00749, -1.2757}, {1.2757, 5.00749}, {7.55888, 11.2907}} *)


Finally, plot those regions and combine them.

Show[ParametricPlot[{xPlot[t], yPlot[t]}, {t, First@#, Last@#}] & /@ %,
PlotRange -> All, AxesOrigin -> {0, 0}, AspectRatio -> 1/10]


In response to a comment below, continuous functions of t producing the curve above can be defined by

offset = t2 /.
FindRoot[{xPlot[t1] == xPlot[t2], yPlot[t1] == yPlot[t2]}, {t1, -5/4}, {t2, 5/4}];
x2Plot[t_] :=
Block[{n = Floor[t/(2 Pi - 2 offset)]}, xPlot[Mod[t, 2 Pi - 2 offset] + 2 n Pi + offset]]
y2Plot[t_] :=
Block[{n = Floor[t/(2 Pi - 2 offset)]}, yPlot[Mod[t, 2 Pi - 2 offset] + 2 n Pi + offset]]


Then,

ParametricPlot[{{x2Plot[t], y2Plot[t]}}, {t, -4 Pi + 4 offset, 4 Pi - 4 offset},
ImageSize -> Large, AspectRatio -> 1/10]


again produces the desired curve.

A function that literally returns "only the minimum value of a parametric curve" can be defined as follows.

y3Plot[t_] := Min[yPlot[t2 /. #] & /@ Flatten@NSolve[xPlot[t2] == xPlot[t], t2, Reals]]


Then

ParametricPlot[{{xPlot[t], y3Plot[t]}}, {t, -4 Pi + offset, 4 Pi - offset},
ImageSize -> Large, AspectRatio -> 1/10]


still again produces the desired curve. This last approach is computationally slower but more general than the previous approaches.

• Thank you, but I am looking for something that creates a new continuous function that can be used for other things, not just a way to avoid plotting the loops – 888 Oct 6 '16 at 2:04
• @888 Now provided. – bbgodfrey Oct 6 '16 at 12:04

First we can get formulas for the pieces of the plot, but alas we can only solve for x in terms of y. Eliminate gives a warning about using inverse functions, but we'll still be able to use its output.

Block[{a = 3, b = 4},
Eliminate[{x == xPlot[t], y == yPlot[t]}, {t}]
];
sol = Solve[%, x]
ParametricPlot[{x, y} /. sol // Evaluate, {y, -1, 7}]
(*
{{x -> -Sqrt[7 + 6 y - y^2] - 3 ArcCos[1/4 (-3 + y)]},
{x ->  Sqrt[7 + 6 y - y^2] - 3 ArcCos[1/4 (-3 + y)]},
{x -> -Sqrt[7 + 6 y - y^2] + 3 ArcCos[1/4 (-3 + y)]},
{x ->  Sqrt[7 + 6 y - y^2] + 3 ArcCos[1/4 (-3 + y)]}}
*)


So let's pick the third one and figure out the period:

-Sqrt[7 + 6 y - y^2] + 3 ArcCos[1/4 (-3 + y)] /. y -> -1
(*  3 π  *)


Now create an appropriate periodic expression from it:

f = InverseFunction[Evaluate[-Sqrt[7 + 6 y - y^2] + 3 ArcCos[1/4 (-3 + y)] /. y -> #] &][
Abs@Mod[x, 6 π, -3 π]];

Plot[f, {x, -12 Pi, 12 Pi}, AspectRatio -> Automatic]


Here's another way to get the minimum y as a function of x, similar to @bbgodfrey's second addendum:

ymin[x_?NumericQ] := Min[yPlot[t] /. NSolve[x == xPlot[t], t, Reals]]


It's a bit slower than f above, but it produces the same graph.

Plot[ymin[x], {x, -12 Pi, 12 Pi}, AspectRatio -> Automatic]