Find Where a Parametric Equation Overlaps [duplicate]

Question

I have a parametric equation:

r[t_] = {2.9 Cos[3.2 Pi t], Sin[4 Pi t] + 5 t};

which overlaps at a point in the $\{-x, y\}$ region of a plot.

I'm trying to figure the simplest way of finding the $\{x, y\}$ coordinates of the point of overlap, but I'm not having any luck. I do know that the point of overlap is between 0.1 < t < 0.2 and 0.4 < t < 0.5.

curve = ParametricPlot[r[t], {t, 0, 1}, AxesLabel -> {x, y}];
point = Graphics[{Red, Disk[r[0.175], .075]}];
Show[curve, point]

Any suggestions?

Answer 1

Using FindRoot with started values determined from OP's Show[curve, point]:

r[t_] = {2.9 Cos[3.2 Pi t], Sin[4 Pi t] + 5 t};

sol = FindRoot[r[t2] - r[t1], {{t1, 0.175}, {t2, 0.45}}]
(* {t1 -> 0.173318, t2 -> 0.451682} *)

{r[t1], r[t2]} /. sol
(* {{-0.495174, 1.68785}, {-0.495174, 1.68785}} *)

Answer 2

This question also can be addressed by eliminating t.

g = y /. Simplify[Solve[{x == 29/10 Cos[32/10 Pi t], y == Sin[4 Pi t] + 5 t}, {y, t}], 
    C[1] ∈ Integers] // Expand /. C[1] -> c

(* {-25*ArcCos[10*x/29]/(16*Pi) + 25*C[1]/8 + Sin[(5*(-ArcCos[10*x/29] + 2*Pi*C[1]))/4], 
     25*ArcCos[10*x/29]/(16*Pi) + 25*C[1]/8 + Sin[(5*( ArcCos[10*x/29] + 2*Pi*C[1]))/4]} *)

This expression can be plotted as

f = Reverse@g; f[[2]] = f[[2]] /. c -> c + 1;
Plot[Evaluate[Table[f, {c, 0, 3}]], {x, -29/10, 29/10}]

y is periodic with a period of g[[1]] /. c -> 4 /. ArcCos[(10 x)/29] -> 0, which is 25/2. The three crossing points are given by

With[{d = 0}, {x, f[[1]] /. c -> d} /. FindRoot[Equal @@ f /. c -> d, {x, 0}]]
(* {-0.495174, 1.68785} *)
With[{d = 2}, {x, g[[1]] /. c -> d} /. FindRoot[Equal @@ g /. c -> d, {x, 0}]]
(* {-0.38559, 6.25} *)
With[{d = 3}, {x, f[[1]] /. c -> d} /. FindRoot[Equal @@ f /. c -> d, {x, 0}]]
(* {-0.495174, 10.8122} *)

All other roots can be obtained, of course, by adding integer multiples of 12.5 to y.

Answer 3

Or use NSolve with exact equations

r[t_] = Hold[{2.9 Cos[3.2 Pi t], Sin[4 Pi t] + 5 t}] /. 
    z_?NumberQ :> Rationalize[z] // ReleaseHold;

soln = NSolve[
   {r[t1] == r[t2], 1/10 < t1 < 2/10, 4/10 < t2 < 5/10},
   {t1, t2}][[1]]

(*  {t1 -> 0.173318, t2 -> 0.451682}  *)

Verifying the solution

r[t1] == r[t2] /. soln

(*  True  *)

The intersection point is

pt = r[t1] /. soln

(*  {-0.495174, 1.68785}  *)

curve = ParametricPlot[r[t], {t, 0, 1},
   AxesLabel -> {x, y}];

point = Graphics[{Red, AbsolutePointSize[6],
    Point[pt]}];

Show[curve, point]

Answer 4

NOTE: This is an exaggeration, but incorporates a number of techniques that might be applied to many other problems.

---

Let's take

r[t_] = {2.9 Cos[3.2 Pi t], Sin[4 Pi t] + 5 t};

and the bounds for t

min = 0;
max = 3;

The first step is to extract the intersections from the plot:

curve = ParametricPlot[r[t], {t, min, max}, Axes -> None, 
  PlotRangePadding -> None]

The pixel positions of the intersections can be extracted with

px = PixelValuePositions[#, White] & @
  MorphologicalBranchPoints @ Thinning @ Binarize @ curve

{{74, 410}, {64, 407}, {64, 313}, {74, 311}, {71, 180}, {75, 180}, {74, 50}, {64, 47}}

We need to connect them to the actual coordinates on the plot:

pl = PlotRange@curve

{{-2.9, 2.9}, {0., 15.}}

id = ImageDimensions@curve

{167, 432}

The relation between pl and id is linear, $y=ax+b$ and $y=cx+d$ in the horizontal and vertical directions, respecively:

{a, b} = {a, b} /. 
  First@Solve[{pl[[1, 1]] == b, pl[[1, 2]] == a id[[1]] + b}, {a, b}]
{c, d} = {c, d} /. 
  First@Solve[{pl[[2, 1]] == d, pl[[2, 2]] == c id[[2]] + d}, {c, d}]

{0.0347305, -2.9}

{0.0347222, 0.}

The pixel positions transformed to plot coordinates:

ic = {a #1 + b, c #2 + d} & @@@ px

{{-0.32994, 14.2361}, {-0.677245, 14.1319}, {-0.677245, 10.8681}, {-0.32994, 10.7986}, {-0.434132, 6.25}, {-0.29521, 6.25}, {-0.32994, 1.73611}, {-0.677245, 1.63194}}

look like this:

Not exactly at the intersections, but this is good enough. We can get rid of the ambiguity with clustering:

clu = ClusterClassify@ic

Method: DBSCAN

Number of classes: 4

g = GatherBy[ic, clu]

{{{-0.32994, 14.2361}, {-0.677245, 14.1319}}, {{-0.677245, 10.8681}, {-0.32994, 10.7986}}, {{-0.434132, 6.25}, {-0.29521, 6.25}}, {{-0.32994, 1.73611}, {-0.677245, 1.63194}}}

icmean = Reverse[Mean /@ g]

{{-0.503593, 1.68403}, {-0.364671, 6.25}, {-0.503593, 10.8333}, {-0.503593, 14.184}}

which works very well:

Show[ParametricPlot[r[t], {t, min, max}, Axes -> None, 
  PlotRangePadding -> None], 
 Graphics[{PointSize[Large], Point[#]}] &@icmean]

The above works perfectly, and I believe it answers a number of other questions here: (41496), (78616), (99529), (126847).

Now, to find t for which the intersection occur, we need to do some careful solving:

ff1 = Flatten@
  Table[Select[min < # < max &][
    t /. Quiet@NSolve[r[t][[1]] == icmean[[i, 1]], t]], {i, 1, 
    Length@icmean}]
ff2 = Table[
  t /. NSolve[r[t][[2]] == icmean[[i, 2]], t, Reals], {i, 1, 
   Length@icmean}]

{0.173612, 0.168792, 0.173612, 0.173612}

{{0.140671, 0.174995, 0.451432}, {1.08048, 1.25, 1.41952}, {2.04971, 2.31875, 2.36513}, {2.64067, 2.675, 2.95143}}

and create the set of starting points:

fr = Table[{ff2[[i, 1]], ff2[[i, -1]]}, {i, 1, Length@ff2}]

{{0.140671, 0.451432}, {1.08048, 1.41952}, {2.04971, 2.36513}, {2.64067, 2.95143}}

and now use Xavier's idea

final = {t1, t2} /. 
  Table[FindRoot[
    r[t2] - r[t1], {{t1, fr[[i, 1]]}, {t2, fr[[i, 2]]}}], {i, 1, 
    Length@fr}]

{{0.173318, 0.451682}, {1.08048, 1.41952}, {2.04832, 2.32668}, {2.67332, 2.95168}}

Each pair {t1, t2} should correspond to one intersection:

points = Table[
   Graphics[{Red, Disk[r[Flatten[final][[i]]], .1]}], {i, 1, 
    Length@Flatten[final]}];

All solutions have been found in an automated manner.