Finding the largest disk within a convex region using Region primitives
poly = Polygon @ {{0, 1}, {0, 6}, {4, 10}, {8, 10}, {11, 7}, {11, 4},
{7, 0}, {1, 0}, {0, 1}};
dsk = Disk[{x, y}, r];
We can use RegionWithin[poly, dsk]
as the constraint in ArgMax
:
sol = Quiet @ ArgMax[{r, RegionWithin[poly, dsk]}, {x, y, r}]
{43/8, 39/8, 13/(2 Sqrt[2])}
Graphics[{EdgeForm[Black], FaceForm[Yellow], poly,
Red, Circle[Most @ sol, Last @sol], PointSize[Large], Point[Most @ sol]}]
As an area maximization problem:
reg = Polygon[{{0, 1}, {0, 6}, {4, 10}, {8, 10}, {11, 7}, {11, 4}, {7, 0}, {1, 0}, {0, 1}}];
rnf = RegionNearest[RegionBoundary[reg]];
gendisk[{x_, y_}] := Disk[{x, y}, EuclideanDistance[{x, y}, rnf[{x, y}]]]
cost[{x_?NumericQ, y_?NumericQ}] := Area[gendisk[{x, y}]]
{err, sol} = NMaximize[cost[{x, y}], {x, y} \[Element] reg,
Method -> "RandomSearch"];
Graphics[{FaceForm[None], EdgeForm[Black], reg, Yellow,
FaceForm[Yellow], gendisk[Values@sol], Red, Point[Values[sol]]}]
There's a ridge at the centre of the distance transform, so I don't think there is a unique solution but a family of disks with maximal area.
ImageAdjust@DistanceTransform@ColorNegate@Graphics[reg]
Conjecture
We believe that the center of the max circle should be lie in the line segment.
pts = {{0, 1}, {0, 6}, {4, 10}, {8, 10}, {11, 7}, {11, 4}, {7, 0}, {1,
0}};
poly = Polygon[pts];
fig1 = Graphics[{{LightGreen, poly}, {Red, Point[pts]}, Blue,
Text[#, RegionCentroid[RegionDifference[Disk[#, 1.3], poly]]] & /@
pts}];
p1 = {x, y} /. (Reduce[
RegionDistance[InfiniteLine[{{0, 6}, {4, 10}}], {x, y}] ==
RegionDistance[InfiniteLine[{{7, 0}, {11, 4}}], {x, y}] ==
RegionDistance[InfiniteLine[{{1, 0}, {7, 0}}], {x, y}] && {x,
y} ∈ poly, Reals] // ToRules) // Simplify;
p2 = {x, y} /. (Reduce[
RegionDistance[InfiniteLine[{{0, 6}, {4, 10}}], {x, y}] ==
RegionDistance[InfiniteLine[{{7, 0}, {11, 4}}], {x, y}] ==
RegionDistance[
InfiniteLine[{{4, 10}, {8, 10}}], {x, y}] && {x,
y} ∈ poly, Reals] // ToRules) // Simplify;
Show[fig1,
Graphics[{Text[p1, p1, {1, 1}],
Text[p2, p2, {-1, -1}], {Red, Point[{p1, p2}], Line[{p1, p2}]}}]]
pts = {{0, 1}, {0, 6}, {4, 10}, {8, 10}, {11, 7}, {11, 4}, {7, 0}, {1,
0}};
poly = Polygon[pts];
bds = InfiniteLine /@ Partition[pts, 2, 1, 1];
Maximize[{Min[RegionDistance[#, {x, y}] & /@ bds], {x, y} ∈
poly}, {x, y}] // Simplify;
ContourPlot[
Min[RegionDistance[#, {x, y}] & /@ bds], {x, y} ∈ poly,
Contours -> {1, 1.5, 2.5, 3.5, 4, 4.5}, ContourShading -> Automatic,
PlotPoints -> 50, MaxRecursion -> 2]
Edit II
pts = {{0, 1}, {0, 6}, {4, 10}, {8, 10}, {11, 7}, {11, 4}, {7, 0}, {1,
0}};
poly = Polygon[pts];
bds = InfiniteLine /@ Partition[pts, 2, 1, 1];
Maximize[{Min[RegionDistance[#, {x, y}] & /@ bds], {x, y} ∈
poly}, {x, y}] // Simplify
$$\left\{\frac{13}{2 \sqrt{2}},\left\{x\to \frac{1}{4} \left(42-13 \sqrt{2}\right),y\to 10-\frac{13}{2 \sqrt{2}}\right\}\right\}$$
pts = {{0, 1}, {0, 6}, {4, 10}, {8, 10}, {11, 7}, {11, 4}, {7, 0}, {1,
0}};
poly = Polygon[pts];
bds = InfiniteLine /@ Partition[pts, 2, 1, 1];
sol = Maximize[{r,
Sequence @@
Table[EuclideanDistance[RegionNearest[bd, {x, y}], {x, y}] >=
r, {bd, bds}], {x, y} ∈ poly}, {r, x, y}] // Simplify
Graphics[{{Opacity[0.1], poly}, Point[{x, y}], Circle[{x, y}, r]} /.
Last[sol]] // Timing
$$\left\{\frac{13}{2 \sqrt{2}},\left\{r\to \frac{13}{2 \sqrt{2}},x\to \frac{11}{2},y\to 5\right\}\right\}$$
Edit I
pts = {{0, 1}, {0, 6}, {4, 10}, {8, 10}, {11, 7}, {11, 4}, {7, 0}, {1,
0}};
poly = Polygon[pts];
bds = InfiniteLine /@ Partition[pts, 2, 1, 1];
sol = Maximize[{r,
Table[RegionDistance[bd, {x, y}] >= r, {bd, bds}], {x,
y} ∈ poly}, {r, x, y}] // Simplify
Graphics[{{Opacity[0.2], poly}, Point[{x, y}], Circle[{x, y}, r]} /.
Last[sol]]
$$\left\{\frac{13}{2 \sqrt{2}},\left\{r\to \frac{13}{2 \sqrt{2}},x\to \frac{43}{8},y\to \frac{39}{8}\right\}\right\}$$
If we add condition to y
such as y>=5
,the result is
$$\left\{\frac{13}{2 \sqrt{2}},\left\{r\to \frac{13}{2 \sqrt{2}},x\to \frac{355}{64},y\to \frac{323}{64}\right\}\right\}$$
So It must be exist a line attain the maximum.