Find smallest distance from a point to a Bézier curve

Question

I wish to find the smallest distance from a point to a curved defined via a Bézier function. I want to do this automatically. For particular cases it is not to difficult. Here is a minimum working example. What point on the curve is closest to the red point?

pts = {{-3, 0}, {-1, 3}, {1, -3}, {0, 1}, {0, 2}, {2, 2}, {-2, -2}};
pt = {-0.07194, 0.6342};
Graphics[{BezierCurve[pts], Point[pts], Red, Point[pt]}, 
 Frame -> True]

My first attempt was RegionDistance[] but this does not have BezierCurve as an input. Looking about I found BezierFunction which enables me to make a function that gets the distance to the curve as a parameter of distance along the curve. Thus

ClearAll[f, f1];
f = BezierFunction[pts];
f1[t_?NumberQ] := EuclideanDistance[ f[t], pt]
Plot[f1[t], {t, 0, 1}]

I was now able to look for the minimum using FindMinimum. This produced an error without a starting point. However, the point I got was not the minimum.

{min, pos} = FindMinimum[f1[t], {t, 0.5}];
minpt = f1[t /. pos];
Plot[f1[t], {t, 0, 1}, 
 Epilog -> {Orange, PointSize[0.03], Point[{minpt, f1[minpt]}]}]

I am aware that finding global minima is not easy so before I try and resolve that issue I wish to return to the original problem and see if anyone can come up with a good method. Thanks

***** Edit*****

Thanks to all who answered. You have taught me much about splines. Clearly BezierFunction is not as good as BSplineFunction. So I perhaps should use BSplineCurve rather than BezierCurve. Are there discussions on which is most suitable when? @flinty has made some very good points in his reply.

Due to the difficulty of local minima it seems that using FindMinimum is not a suitable approach. The best approaches seems to be that of kglr and Chip Hurst. I have opted for the solution of kglr for now (mainly because I started working on that one first). Here is the module I put together to find the point.

nearestPointOnCurve[pts_List, None, sfy_] := {};
nearestPointOnCurve[pts_List, pt_List, sfy_] := 
 Module[{distFun, g, lines, points, p1, p2},
  distFun[{x1_, y1_}, {x2_, y2_}] := 
   Sqrt[((x2 - x1))^2 + (sfy (y2 - y1))^2];
  g = Graphics[{BezierCurve[pts]}, PlotRange -> All, AspectRatio -> 1];
  lines = MeshPrimitives[DiscretizeGraphics[g], 1];
  points = Flatten[Cases[lines, Line[a_] :>  a, \[Infinity]], 1];
  p1 = First@Nearest[points, pt, DistanceFunction -> distFun];
  p1]

You can see I have put in a distance function because sometimes you need the location of the point nearest the cursor rather than the nearest Cartesian point. Here is an example that illustrates this point and is something to play with.

 pts = {{0, 0.5178`4.}, {0.0007762`4., 0.4642`4.}, {0.0001964`4., 
    2.535`4.}, {0.000477`4., 2.268`4.}, {0.0007575`4., 
    2.`4.}, {0.0009247`4., 3.202`4.}, {0.001171`4., 
    2.834`4.}, {0.001418`4., 2.466`4.}, {0.001614`4., 
    1.833`4.}, {0.001908`4., 2.586`4.}, {0.002202`4., 
    3.338`4.}, {0.002247`4., 1.774`4.}, {0.002647`4., 
    1.87`4.}, {0.003048`4., 1.966`4.}, {0.002157`4., 
    0.2631`4.}, {0.003`4., -0.1185`4.}};

{x1, x2} = MinMax[pts[[All, 1]]];
{y1, y2} = MinMax[pts[[All, 2]]];
ar = 1/4;
{sfx, sfy} = {1/(x2 - x1), ar/(y2 - y1)};

DynamicModule[{},
 Dynamic[Graphics[{BezierCurve[pts], PointSize[0.01], 
    Point[MousePosition["Graphics"]],
    Red, Point[
     nearestPointOnCurve[pts, MousePosition["Graphics"], sfy/sfx]],
    Orange, 
    Point[nearestPointOnCurve[pts, MousePosition["Graphics"], 1]]
    }, Frame -> True, PlotRange -> All, AspectRatio -> ar, 
   ImageSize -> 12 72]
  ]
 ]

The black point is the cursor, the orange point is the nearest in Cartesian distance and the red point is the nearest in the screen coordinates.

Thanks for all your help.

Answer 1

g0 = Graphics[{BezierCurve[pts], Point[pts], Red, Point[pt]}, Frame -> True];
lines = MeshPrimitives[DiscretizeGraphics[g0], 1];

npt = RegionNearest[RegionUnion @@ lines][pt]

 {0.0805512, 0.671604}

Graphics[{Blue,lines, Red, Point[pt], Black, Point@pts, 
  Green, PointSize[Large], Point@npt}, Frame -> True]

Answer 2

Simply using BezierFunction is not enough. The BezierFunction will not match the BezierCurve because that curve is actually a composite of multiple splines - see here: BezierCurve is different from BezierFunction.

This below is adapted from the above and @J. M.'s technical difficulties solution:

You need to first chop your spline into its components and minimize over both, then find which closest point on each sub-spline is closer to your point. See here on how to produce the parts: How to construct BezierFunction for BezierCurve with npts>4 and SplineDegree -> 3?

pt = {-0.07194, 0.6342};
pts = {{-3, 0}, {-1, 3}, {1, -3}, {0, 1}, {0, 2}, {2, 2}, {-2, -2}};
bzsplinefns = BezierFunction /@ Partition[pts, 4, 3];
distance[p1_, p2_] := SquaredEuclideanDistance[p1, p2]
splineDistance[spline_, point_, t_?NumericQ] := 
 distance[spline[t], point]
closest[spline_, point_] := 
 NArgMin[{splineDistance[spline, point, t], 0 < t < 1}, t]
tvals = closest[#, pt] & /@ bzsplinefns;
finalNearestPoint = 
 MinimalBy[MapThread[#1[#2] &, {bzsplinefns, tvals}], 
   distance[#, pt] &][[1]]
Graphics[{Point[pt], Thick, Gray, BezierCurve[pts], Thin,
  {RandomColor[], Line[Table[#[t], {t, 0, 1, 0.01}]]} & /@ 
   bzsplinefns, PointSize[Large], Point[finalNearestPoint]}]

If you choose BSplineCurve instead, you don't need to worry about breaking it into multiple BSplineFunctions - you can just minimize a single BSplineFunction that accounts for the whole curve.

pt = {-0.07194, 0.6342};
pts = {{-3, 0}, {-1, 3}, {1, -3}, {0, 1}, {0, 2}, {2, 2}, {-2, -2}};
distance[p1_, p2_] := SquaredEuclideanDistance[p1, p2]
splineDistance[spline_, point_, t_?NumericQ] := 
 distance[spline[t], point]
closest[spline_, point_] := 
 NArgMin[{splineDistance[spline, point, t], 0 < t < 1}, t]
bsp = BSplineFunction[pts];
result = bsp[closest[bsp, pt]]
Graphics[{BSplineCurve[pts], Point[pt], PointSize[Large], 
  Point[result]}]

Answer 3

Another way is to express the curve as a union of ParametricRegions and then use RegionNearest.

p1 = (List @@ Expand[(x + y)^3] /. {x -> 1 - t, y -> t}).pts[[1 ;; 4]];

p2 = (List @@ Expand[(x + y)^3] /. {x -> 1 - t, y -> t}).pts[[4 ;; 7]];

breg = RegionUnion[
  ParametricRegion[p1, {{t, 0, 1}}], 
  ParametricRegion[p2, {{t, 0, 1}}]
];

Region[Style[breg, Thick]]

RegionNearest[breg, pt]

{0.0808892, 0.67102}

Answer 4

This works for me

{min, pos} = FindMinimum[f1[t], {t, 0.99}, Method -> "Newton"]
minpt = {t, f1[t]} /. pos
Plot[f1[t], {t, 0, 1}, 
 Epilog -> {Orange, PointSize[0.03], Point[minpt]}]