6
$\begingroup$

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] 

enter image description here

$\endgroup$
  • $\begingroup$ You're aware that if you restrict yourself to a == b, you'll get cycloids instead of trochoids, no? $\endgroup$ – J. M. will be back soon Oct 6 '16 at 3:13
  • $\begingroup$ 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. $\endgroup$ – bbgodfrey Oct 6 '16 at 11:05
8
$\begingroup$
a = 3;
b = 4;
xPlot[t_] := a*t - b*Sin[t];
yPlot[t_] := a - b*-Cos[t];

Using NSolve

soln = SortBy[
  NSolve[{Thread[{xPlot[t1], yPlot[t1]} == {xPlot[t2], yPlot[t2]}],
     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]

enter image description here

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]

enter image description here

$\endgroup$
  • $\begingroup$ Is this a clever way of plotting the function, or does it actually create a new function without the cusps? $\endgroup$ – 888 Oct 6 '16 at 2:06
  • $\begingroup$ 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. $\endgroup$ – Bob Hanlon Oct 6 '16 at 2:34
8
$\begingroup$

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]

enter image description here

Improved Addendum

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.

Second Addendum

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.

$\endgroup$
  • $\begingroup$ 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 $\endgroup$ – 888 Oct 6 '16 at 2:04
  • $\begingroup$ @888 Now provided. $\endgroup$ – bbgodfrey Oct 6 '16 at 12:04
4
$\begingroup$

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

Mathematica graphics

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]

Mathematica graphics


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]
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.