Group Abstract Group Abstract

Message Boards Message Boards

Finding the largest disk which fits inside a nonconvex Polygon

Find the largest disk which fits inside a given rectangle poly

poly = Polygon[{{-1, -1}, {1, -1}, {1, 1}, {-1, 1}}];

AbsoluteTiming @ 
 Maximize[{r, RegionWithin[poly, Disk[{x, y}, r]], r > 0}, {r, x, y}]

{0.0856107, {1, {r -> 1, x -> 0, y -> 0}}}

AbsoluteTiming @ 
 NMaximize[{r, RegionWithin[poly, Disk[{x, y}, r]], r > 0}, {r, x, y}]

{0.0178753, {1., {r -> 1., x -> 0., y -> 0.}}}

The approach which works for the rectangle doesn't in any reasonable time for a nonconvex polygon.

poly = Polygon[{{-1, -1}, {1, -1}, {1, 1}, {0, 1/2}, {-1, 1}}];

TimeConstrained[
 Maximize[{r, RegionWithin[poly, Disk[{x, y}, r]], r > 0}, {r, x, y}], 100]

$Aborted

TimeConstrained[
 NMaximize[{r, RegionWithin[poly, Disk[{x, y}, r]], r > 0}, {r, x, y}], 100]

$Aborted

 Define a function which find the maximum disk radius as a function of the coordinates of the disk center and maximize that.

ar[x_?NumberQ, y_?NumberQ] := 
 FindMaxValue[{r, RegionWithin[poly, Disk[{x, y}, r]], r > 0}, {r}]

AbsoluteTiming[sln = FindMaximum[ar[x, y], {{x, 0.5}, {y, 0}}]]

FindMaximum::lstol: The line search decreased the step size to within the tolerance specified by AccuracyGoal and PrecisionGoal but was unable to find a sufficient increase in the function. You may need more than MachinePrecision digits of working precision to meet these tolerances.

{1.9142, {0.767949, {x -> 0.232051, y -> -0.232051}}}

Show[Graphics @{Opacity[0.3], Green, poly}, 
 Graphics @ {Opacity[0.3], Red, Disk[{x, y} /. sln[[2]], sln[[1]]]}, 
 ImageSize -> Small, Axes -> True]

enter image description here
POSTED BY: Frank Kampas
2 Replies
Sort By:

Interesting. Here's the plot of the result obtained by your methodenter image description here
POSTED BY: Frank Kampas

An approach that uses RegionPlot3D and the internal structure of Graphics3D:

poly = Polygon[{{-1, -1}, {1, -1}, {1, 1}, {0, 1/2}, {-1, 1}}];
regPl = RegionPlot3D[RegionWithin[poly, Disk[{x, y}, r]] && r >= 0,
  {x, -1.5, 1.5}, {y, -1.5, 1.5}, {r, -.1, .8}]
TakeLargestBy[regPl[[1, 1]], Last, 2]
POSTED BY: Gianluca Gorni
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard