8

I have a collection of sets of points, each set defining the segment of a (nice) curve on the unit sphere $S^2 \subset \mathbb{R}^3$. The points are computed numerically. I now want to compute the intersection of the curve segments and I would like to get all solutions if two curve segments intersect more than once. The following Mathematica script works but only gives me one solution:

f1 = BSplineFunction[points[[1]]];
f2 = BSplineFunction[points[[2]]];
g[u_, v_] := Norm[f1[u] - f2[v]]
NMinimize[{g[x, y], 0 <= x <= 1, 0 <= y <= 1}, {x, y}]

Using

NSolve[g[x, y] == 0, {x, y}]

simply yields the function call as an output, and

FindRoot[g[x, y] == 0, {{x, 0.5, 0, 1}, {y, 0.5, 0, 1}}]

complains that the number of variables does not match the number of equations. Any suggestions on how to solve this?

Edit2: This is a sample of the data I am using that I would like to yield two points of intersection

points =
{{{ 0.0563319, -0.0207277,  -0.998197}, { 0.0468164,  -0.020208,  -0.998699}, 
  { 0.0361213, -0.0187319,  -0.999172}, { 0.0269836,  -0.0165999, -0.999498}, 
  { 0.0191223, -0.0140227,  -0.999719}, { 0.0122367,  -0.0111131, -0.999863}, 
  { 0.00603102,-0.00789628, -0.999951}, { 0.000232715,-0.00432551,-0.999991}, 
  {-0.00539442,-0.000299408,-0.999985}, {-0.0110431,   0.00431947,-0.99993}, 
  {-0.0168598,  0.00968684, -0.999811}, {-0.0229461,   0.0159607, -0.999609}, 
  {-0.0293624,  0.0232877,  -0.999298}, {-0.036133,    0.031792,  -0.998841}, 
  {-0.0432526,  0.0415674,  -0.998199}, {-0.0506922,   0.0526714, -0.997324}}, 
 {{-0.0563319,  0.0207277,  -0.998197}, {-0.0468164,   0.020208,  -0.998699}, 
  {-0.0361213,  0.0187319,  -0.999172}, {-0.0269836,   0.0165999, -0.999498}, 
  {-0.0191223,  0.0140227,  -0.999719}, {-0.0122367,   0.0111131, -0.999863}, 
  {-0.00603102, 0.00789628, -0.999951}, {-0.000232715, 0.00432551,-0.999991}, 
  { 0.00539442, 0.000299408,-0.999985}, { 0.0110431,  -0.00431947,-0.99993},
  { 0.0168598, -0.00968684, -0.999811}, { 0.0229461,  -0.0159607, -0.999609}, 
  { 0.0293624, -0.0232877,  -0.999298}, { 0.036133,   -0.031792,  -0.998841}, 
  { 0.0432526, -0.0415674,  -0.998199}, { 0.0506922,  -0.0526714, -0.997324}}};
user10303
  • 81
  • 4

2 Answers2

6

This isn't perfect by any means, but can be of some use:

f1 = BSplineFunction[Table[{x, Sin@x, 0}, {x, 0, 6 Pi, .1}]];
f2 = BSplineFunction[Table[{x, Cos@x, 0}, {x, 0, 6 Pi, .1}]];
g[u_, v_] := Norm[f1[u] - f2[v]]
i = ColorNegate@Binarize@ContourPlot[g[u,v], {u, 0, 1}, {v, 0, 1}, PlotRange->{0, .5}, Frame-> None];
mc = MorphologicalComponents@i;
areas = (Range@Max@mc /. ComponentMeasurements[i, "BoundingBox"])/ First@ImageDimensions@i;
cond = Transpose /@  areas /. {{t1min_, t1max_}, {t2min_, t2max_}} -> 
                                                      (t1min < t1 < t1max && t2min < t2 < t2max);
mins = {t1, t2} /. (Quiet@NMinimize[{g[t1, t2], #}, {t1, t2}] & /@ cond)[[All,  2]];
Show[ParametricPlot3D[f1[t], {t, 0, 1}], 
     ParametricPlot3D[f2[t], {t, 0, 1}], 
     Graphics3D[{Red, PointSize[Large], Point[f1 /@ mins[[All, 1]]]}]]

Mathematica graphics

Dr. belisarius
  • 115,881
  • 13
  • 203
  • 453
4

Another quite inefficient (and unreliable), but straightforward way to search for intersections by moving the search interval for x:

mins = Table[
   NMinimize[{g[x, y], xlim <= x <= 1, 0 <= y <= 1}, {x, y}], {xlim, 
    0, 1, 0.1}];

intersects = 
 DeleteDuplicates[{x, y} /. Select[mins, #[[1]] < 10^-5 &][[All, 2]], 
  Norm[#1 - #2] < 10^-3 &]

(* {{0.204834, 0.754727}, {0.754727, 0.204834}}*)

Show[{ParametricPlot3D[f1[t], {t, 0, 1}], 
  ParametricPlot3D[f2[t], {t, 0, 1}], 
  Graphics3D[{PointSize[Large], Red, 
    Point[f1 /@ intersects[[All, 1]]]}]}]

Mathematica graphics

Yves Klett
  • 15,383
  • 5
  • 57
  • 124
  • I think I can modify this enough to solve my problem efficiently using some symmetry observations. Thanks! – user10303 Nov 03 '13 at 23:52