6
$\begingroup$

enter image description here

This should work? But it is giving me the wrong t values

$\endgroup$
7
$\begingroup$
r[t_] := {6 Cos[ 2.9 Pi t], Cos[3.5 Pi t] + 5 t};

pp = ParametricPlot[r[t], {t, 0, 1} ];
pt = First @ Graphics`Mesh`FindIntersections[pp];

Show[pp, Graphics @ {Red, PointSize[Large], Point @ pt}, 
 PlotLabel -> Style[Row[{"intersection = ", pt}], 16]]

enter image description here

To get the same result using FindRoot, we can use the approach from this answer to (1) add the constraints t2 > t1 and (2) randomly change the starting values until no error message is issued by FindRoot :

constraints = 0 < t1 < 1 && t2 > t1;
startingvals = {RandomReal[], RandomReal[]};
While[err == Quiet@Check[
 sol = FindRoot[1 - Boole[constraints] + Boole[constraints] (r[t2] - r[t1]), 
       Transpose[{{t1, t2}, startingvals}]], err], 
  startingvals = {RandomReal[], RandomReal[]};];
r[t1] /. sol

{-0.320402, 3.3467}

To get multiple intersections remove First in definition of pt above:

pp = ParametricPlot[r[t], {t, 0, 10}];
pt = Graphics`Mesh`FindIntersections[pp];
Labeled[Show[pp, Graphics@{Red, PointSize[Large], Point@pt}, AspectRatio -> 1], 
 Style[Column[{"intersections", MatrixForm@pt}], 16], Left]

enter image description here

$\endgroup$
3
$\begingroup$
r[t_] := {6 Cos[29 Pi t/10], Cos[7 Pi t/2] + 5 t};

ParametricPlot[r[t], {t, 0, 1}, 
 ColorFunction -> Function[{x, y, t}, ColorData["Rainbow"][t]], 
 PlotLegends -> BarLegend["Rainbow"]]

enter image description here

Using the colors to determine the initial estimates,

sol = FindRoot[{(r[t0][[1]]) == (r[t1][[1]]), (r[t0][[2]]) == (r[
       t1][[2]])}, {{t0, 1/2}, {t1, 9/10}}, WorkingPrecision -> 15]

(* {t0 -> 0.511377264145361, t1 -> 0.867933080682225} *)

Verifying,

r[t0] == r[t1] /. sol

(* True *)
$\endgroup$
2
$\begingroup$

If you didn't have a vast knowledge of all the internal functions provided by Mathematica then you might try a more brute force approach.

Trying a variety of starting values for t1 and t2 seems to usually come up with the same value for t1 and t2. Thus it looks like FindRoot might not have sufficiently good starting values to be able to find different t1 and t2 that give you your intersection. But from your graph you have a pretty good estimate of r[t] so lets look for points near that intersection and which have a substantially different values for t.

rt[t_] := {6 Cos[2.9 Pi t], Cos[3.5 Pi t] + 5 t, t};
Select[Table[rt[t], {t, 0, 1, .001}], 3.2<#[[2]]<3.4 && -1<#[[1]]<0 &]

which gives us

{...
 {-0.067857, 3.39995, 0.516},
 {-0.0508932, 3.31707, 0.863},
 ...
}

which hints that t1 ~= .516 and t2 ~= .863 so we try

r[t_] := {6 Cos[2.9 Pi t], Cos[3.5 Pi t] + 5 t};
sol = FindRoot[r[t1] - r[t2], {{t1, .516}, {t2, .863}}]

and that correctly finds two distinct t1 and t2 for your problem.

$\endgroup$
2
$\begingroup$

NSolve can do the job, if you use rationalized parameters. Even Solve can do it, gives Root expression.

r[t_] = {6 Cos[29/10 Pi t], Cos[35/10 Pi t] + 5 t};

eq1 = And @@ Thread[r[t1] == r[t2]] && 0 < t1 < t2 < 1

eq2 = eq1 // TrigToExp // Simplify

(*   E^(-(29/10) I \[Pi] t2) + E^((29 I \[Pi] t2)/10) == 
     E^(-(29/10) I \[Pi] t1) + E^((29 I \[Pi] t1)/10) && 
     E^(-(7/2) I \[Pi] t2) + E^((7 I \[Pi] t2)/2) + 10 t2 == 
     E^(-(7/2) I \[Pi] t1) + E^((7 I \[Pi] t1)/2) + 10 t1 && 
   0 < t1 < t2 < 1      *)

nsol = NSolve[eq2, {t1, t2}, WorkingPrecision -> 30] // Chop // 
    Simplify[#, t1 \[Element] Reals && t2 \[Element] Reals] &

(*   {{t1 -> 0.511377264145361554521949670476, 
       t2 -> 0.867933080682224652374602053662}}   *)

sol = Solve[eq2, {t1, t2}] // Chop // 
       Simplify[#, t1 \[Element] Reals && t2 \[Element] Reals] &

(*   {{t1 -> Root[{-29 (-1 + (-1)^(1/29)) (1 + (-1)^(1/29)) (1 + (-1)^(
      2/29)) (1 - (-1)^(1/29) + (-1)^(2/29)) (1 + (-1)^(
      1/29) + (-1)^(2/29)) (1 + (-1)^(4/29)) (1 - (-1)^(
      2/29) + (-1)^(4/29)) (1 - (-1)^(4/29) + (-1)^(8/29)) - 
   400 E^((7 I \[Pi] #1)/2) + 29 E^(7 I \[Pi] #1) - 
   29 E^(7/29 I \[Pi] (-20 + 29 #1)) + 
   580 E^((7 I \[Pi] #1)/2) #1 &, 
 0.511377264145361554521949670476156189687360774384 + 
  0.*10^-49 I}], 
t2 -> 40/29 - 
  Root[{-29 (-1 + (-1)^(1/29)) (1 + (-1)^(1/29)) (1 + (-1)^(
       2/29)) (1 - (-1)^(1/29) + (-1)^(2/29)) (1 + (-1)^(
       1/29) + (-1)^(2/29)) (1 + (-1)^(4/29)) (1 - (-1)^(
       2/29) + (-1)^(4/29)) (1 - (-1)^(4/29) + (-1)^(8/29)) - 
    400 E^((7 I \[Pi] #1)/2) + 29 E^(7 I \[Pi] #1) - 
    29 E^(7/29 I \[Pi] (-20 + 29 #1)) + 
    580 E^((7 I \[Pi] #1)/2) #1 &, 
  0.511377264145361554521949670476156189687360774384 + 
   0.*10^-49 I}]}}   *)
$\endgroup$
2
$\begingroup$

Without special knowledge NMinimize solves the problem straight forward:

NMinimize[{1/(t2 - t1)^2 (*force t1!=t2*), r[t1] == r[t2], 0 < t1 < t2 < 1}, {t1, t2}]    
(*{7.86584, {t1 -> 0.511377, t2 -> 0.867933}}*)
$\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.