Cubic equation and tangent circle
First define a parametric curve and regions above and below the curve:
ClearAll[curve, disk, region1, region2, radius]
curve[x_] := {x, (x + 1) (x - 1) (x - 2)}
region1 = ImplicitRegion[(x + 1) (x - 1) (x - 2) >= y, {{x, -20, 30}, {y, -80, 80}}];
region2 = ImplicitRegion[(x + 1) (x - 1) (x - 2) <= y, {{x, -20, 30}, {y, -80, 80}}];
and a disk with radius r
tangent to the curve at curve[t]
:
disk[dir_ : -1][t_, r_] := Module[{rr = Rationalize[r, 0],tt = Rationalize[t, 0]},
Disk[curve[tt] + dir rr Cross@Normalize[curve'[tt]], rr]]
For given input region reg
and parameter value t
find the maximal radius r
such that the disk with radius r
tangent to the curve at curve[t]
stays within reg
:
radius[reg_, dir_ : -1][t_?NumericQ] :=
NMaxValue[{r, RegionWithin[reg, disk[dir][t, r]]}, r]
Examples:
radius[region1][-1]
0.992403
radius[region1][3/2]
2.29173
radius[region2, 1][1]
0.555255
pp = ParametricPlot[curve[x], {x, -2, 3}, ImageSize -> Medium,
PlotRange -> {{-5, 5}, {-6, 5}}];
frames = Table[Show[pp,
Graphics @ {PointSize[Large], Red, Point[curve[t]], FaceForm[],
EdgeForm[Red], disk[][t, radius[region1][t]]}],
{t, -3/2, 3/2, 1/100}];
Export["diskoncurve.gif", frames]
ParametricPlot[curve[x], {x, -2, 3}, AspectRatio -> Automatic,
Epilog -> {FaceForm[],
EdgeForm[Red], disk[][1 + 5/10, radius[region1][1 + 5/10]],
EdgeForm[Green], disk[][1, radius[region1][1]],
EdgeForm[Orange], disk[][1/5, radius[region1][1/5]],
EdgeForm[{Dashed, Red}], disk[1][1 + 5/10, radius[region2, 1][1 + 5/10]],
EdgeForm[{Dashed, Green}], disk[1][1, radius[region2, 1][1]],
EdgeForm[{Dashed, Orange}], disk[1][1/5, radius[region2, 1][1/5]]}]
Edit
f[x_] = (x + 1) (x - 1) (x - 2);
r[x_] = {x, f[x]};
eq1 = r[x1] + t1*Cross@Normalize[r'[x1]];
eq2 = r[x2] + t2*Cross@Normalize[r'[x2]];
plot = ParametricPlot[r[x], {x, -2, 3}, PlotStyle -> Blue];
xmin = x /. Solve[f'[x] == 0, x] // Last;
ymin = f[xmin];
xmax = x /. Solve[f'[x] == 0, x] // First;
ymax = f[xmax];
circles1 =
Graphics[Table[{Orange, Circle[eq1, Abs@t1]} /.
NMinimize[{0, t1^2 == t2^2, -2 < x1 < xmin < x2 < 3, eq1 == eq2,
eq1[[2]] == eq2[[2]] == d}, {x1, x2, t1, t2}][[2]], {d,
ymin + 1.5, ymin + 5, .2}]];
circles2 =
Graphics[Table[{Green, Circle[eq1, Abs@t1]} /.
NMinimize[{0, t1^2 == t2^2, -2 < x1 < xmax < x2 < 3, eq1 == eq2,
eq1[[2]] == eq2[[2]] == d}, {x1, x2, t1, t2}][[2]], {d,
ymax - 1, ymax - 5, -.2}]];
Show[plot, circles1, circles2, AspectRatio -> Automatic]
Original
Using the method from Find the equidistance curve between two curves
f[x_] = (x + 1) (x - 1) (x - 2);
r[x_] = {x, f[x]};
eq1 = r[x1] + t1*Cross@Normalize[r'[x1]];
eq2 = r[x2] + t2*Cross@Normalize[r'[x2]];
plot = ParametricPlot[r[x], {x, -2, 3}];
Manipulate[
sol = NMinimize[{0, eq1 == eq2, t1^2 == t2^2, x2 - x1 == c}, {x1, x2,
t1, t2}, Method -> Automatic];
disk = Graphics[{Cyan, Opacity[0.2], EdgeForm[Red],
Disk[eq1, Abs@t1] /. Last[sol]}];
Show[plot, disk, AspectRatio -> Automatic], {c, -2.5, 2.5, .01},
ControlPlacement -> Bottom]