I'm not at all suggesting that things should be done this way, since it will be decidedly slow, and the undocumented FindIntersections
function is apparently a little unreliable, but I thought the following method was cute, and we will give FindIntersections
every change to succeed. This method also has the distinction of not requiring guesses that can be fed to FindRoot
, and in fact it can be used to generate good guesses for using FindRoot
. In any case, here it is.
Let's take as our function
r[t_] = {3 Cos[33 π t/10], Sin[4 π t] + 4 t};
Step 1: Generate the zero-contours of r[t1] - r[t2]
The two components of r
must simultaneously and independently by equal. In other words, it must be true that
0 == r[t1] - r[t2] // First
and
0 == r[t1] - r[t2] // Last
for t1 != t2
. Individually, we can think of each of these equations as defining the zero-contours of a function f[t1, t2]
. In order to satisfy these equations simultaneously, we will look for the intersections between the contours of the two different component functions. This is the main insight. So, we generate the ContourPlot
s:
pl = Show[
MapThread[
ContourPlot[#1
, {t1, 0, 5}, {t2, 0, 5}
, Contours -> {0}
, RegionFunction -> Function[#1 > #2]
, ContourStyle -> #2
, ContourShading -> False
, PlotPoints -> 20] &
, {r[t1] - r[t2], {Blue, Red}}]
]
resulting in

We have chosen to use RegionFunction -> Function[#1 > #2]
because t1
and t2
are basically dummy variables.
Now, we care about where the blue curves intersect the red curves, because it is at those points that both components of r[t1] - r[t2]
are simultaneously zero. We want to try to cut out any extra intersections, like the ones between the blue curves. For this, we modify the code above to include instead
RegionFunction -> Function[#1 > #2 && Abs[#1 - #2] < 0.6]
We had to come up with the number 0.6
by hand, of course. This method is not without some necessary fiddling. The result is

Step 2: Find the intersections
We use an undocumented function to find those intersections:
Graphics`Mesh`MeshInit[];
intersections = Graphics`Mesh`FindIntersections[pp];
Show[pp, Epilog -> {PointSize[0.017], Point /@ intersections}]
resulting in

Step 3: Feed the results to FindRoot
The answers are already pretty good, but we can polish them by using them as the guesses for FindRoot
:
times = FindRoot[Thread[r[t1] == r[t2]], Transpose[{{t1, t2}, #}]] & /@ intersections
(* {{t1 -> 0.471257, t2 -> 0.134804}, {t1 -> 1.38891, t2 -> 1.03533}
, {t1 -> 1.97158, t2 -> 1.66478}, {t1 -> 2.90891, t2 -> 2.54563}
, {t1 -> 3.45833, t2 -> 3.20833}, {t1 -> 4.42628, t2 -> 4.05857}
, {t1 -> 4.88051, t2 -> 4.81646}} *)
Step 4: Check the results
In order to make sure that each pair {t1, t2}
corresponds to the same intersection, and that we have found them all, and that they are correct, we can plot the points together with the original curve:
Manipulate[
ParametricPlot[r[t]
, {t, 0, 5}
, Epilog -> {PointSize[0.07], Red, Point@r[#] /. times[[kk]]}
] & /@ {t1, t2} // GraphicsRow
, {kk, 1, Length@times, 1}]
resulting in:
