# Rounding an Irregular Polygon

Consider a random irregular convex polygon, for example, the 6-side polygon

I want to define a function that, given a certain parameter r (roundness), rounds each corner and creates a smooth polygon. Something like

Following this answer and my previous question, using the following code gets me pretty close to my goal

arcgen[{p1_, p2_, p3_}, r_, n_] :=
Module[{dc = Normalize[p1 - p2] + Normalize[p3 - p2], cc, th},
cc = p2 + r dc/EuclideanDistance[dc, Projection[dc, p1 - p2]];
th = Sign[
Det[PadRight[{p1, p2, p3}, {3, 3}, 1]]] (\[Pi] -
VectorAngle[p3 - p2, p1 - p2])/(n - 1);
NestList[RotationTransform[th, cc],
p2 + Projection[cc - p2, p1 - p2], n - 1]]
roundedPolygon[Polygon[opts_?MatrixQ], r_?NumericQ,
n : (_Integer?Positive) : 12] :=
With[{pts = Split[opts][[All, 1]]},
Polygon[Flatten[
arcgen[#, r, n] & /@
Partition[
If[TrueQ[First[pts] == Last[pts]], Most, Identity][pts], 3,
1, {2, -2}], 1]]];


This works perfectly for regular polygons. However, when considering random irregular polygons (from a Voronoi mesh, for example), something odd starts to happen

L1 = 3; L2 = 3;
pts = {RandomReal[L1, L1 L2], RandomReal[L2, L1 L2]} // Transpose;
mesh = VoronoiMesh[pts];
pol = RandomChoice[MeshPrimitives[mesh, 2]];
ListAnimate[Table[Graphics[{EdgeForm[Thick], White, roundedPolygon[pol, r]}],
{r, .01, .4, .01}]]


It seems that if two or more vertices are "too close" and for some values of the roundness r, the drawing circles overlap and create this extra structures that I want to avoid. Notice that only happens for specific values of r, which might depend on the random polygon extracted from the Voronoi mesh.

1. Simply removing these external circumference bits is enough for my goal, but how do I do it efficiently? That is, how do I trim such parts (if they occur) and keep the (almost) rounded polygon?

2. Perhaps more challenging, how do I implement this roundness idea to a random irregular convex polygon? I guess mapping the polygon to a circle would be good (could the area be kept constant?), maybe following something like the Schwarz–Christoffel mapping? Alternatively, could I maybe determine an automatic "cutoff" for each vertex and its proximity to other vertex?

1 is my main goal, but I'm open to more elegant solutions. Any ideas?

Just for a bit of context, my background and motivation: I'm modelling an epithelium with a convex mesh, where each polygon is represents a biological cell. My goal is to simply provide a more realistic look to each cell by rounding its vertices. For example, a transformation like

If there is a nicer way of doing this, please let me know. The left mesh is given by the following code

L1 = 4; L2 = 4; ptr = .2;
pts = Table[
Flatten[Table[{3/2 i, Sqrt[3] j + Mod[i, 2] Sqrt[3]/2}, {i,
L2 + 4}, {j, L1 + 4}], 1][[j]] + {RandomReal[{-ptr, ptr}],
RandomReal[{-ptr, ptr}]}, {j, (L1 + 4) (L2 + 4)}] // N;
mesh0 = VoronoiMesh[pts];
mesh1 = MeshRegion[MeshCoordinates[mesh0],
With[{a = PropertyValue[{mesh0, 2}, MeshCellMeasure]},
With[{m = 6}, Pick[MeshCells[mesh0, 2], UnitStep[a - m], 0]]]];
mesh = MeshRegion[MeshCoordinates[mesh1],
MeshCells[mesh1, {2, "Interior"}]]

• What about running the curve shortening flow for some time (the time is the roundedness parameter)? In the end, the flow will collapse to a "round point". It can implemented rather easily. I can show it to you if you are interested. It is basically the 1D version of this. – Henrik Schumacher Mar 4 '20 at 17:46
• How fast is that? It seems interesting. In any case, please see the added section regarding the motivation and my ultimate goal. – sam wolfe Mar 4 '20 at 17:57
• Dunno. A second for the hole mesh depicted. Or do you need it interactively? – Henrik Schumacher Mar 4 '20 at 18:03
• What do you mean by interactively? I don't need to use ListAnimate, just a function that rounds the cells. – sam wolfe Mar 4 '20 at 18:25
• I have to say that this is a beautiful question in all regards. It's clearly written, has a detailed explanation of what the problem is, and it contains why it's important in the real world. Nicely done Sam! – halirutan Mar 5 '20 at 9:20

Not an anwser, yet. This is how the curve shorthening flow would act on the cells:

As you can see, the cells lose contact. So this is probably not what you are looking for, right?

Something similar can be obtained by just subdividing the polygons a little (cutting off the corners) and then using BSplineCurve:

polys = MeshPrimitives[mesh, 2][[All, 1]];
f[p_, λ_, μ_] :=
With[{scales = {(1 - λ) 0 + λ ((1 - μ) 0 + μ \
1/2), 1/2, ((1 - μ) 1 + μ 1/2) λ + (1 - λ) 1}},
Join @@
Transpose[
TensorProduct[p, (1. - scales)] +
TensorProduct[RotateLeft[p], scales], {1, 3, 2}]
]
g = Manipulate[
Graphics[{
Thick,
BSplineCurve[Map[f[#, λ, μ] &, polys[[All]]],
SplineClosed -> True],
Red, Point /@ Map[f[#, λ, μ] &, polys[[All]]]
}],
{{λ, 1/2}, 0, 1}, {{μ, 1/2}, 0, 1}]


• Just one small thing: it seems that when λ = 0 we still get a bit of curvature around a vertex (more evident in a random Voronoi mesh). Would it be possible to avoid this so that λ = 0 corresponds exactly to the original mesh? I guess not entirely since this is now a Graphics object, but just wondering. – sam wolfe Mar 10 '20 at 11:50

A quick hack, essentially interpolating a point travelling at constant speed on polygon edge and averaging the position over a time interval:

With[{coords = Append[#, #[[1]]] &@RandomPolygon[{"Convex", 8}][[1]]},
With[{ip =
Interpolation[
Transpose@{Rescale@Accumulate@
Prepend[EuclideanDistance @@@ Partition[coords, 2, 1], 0],
coords}, InterpolationOrder -> 1]},
Graphics[
{FaceForm@None, EdgeForm@Black, Polygon@coords,
FaceForm@Pink, EdgeForm@None,
Polygon@Table[
Mean@Table[ip[Mod[t + t0, 1]], {t0, 0, .1, .001}], {t, 0, 1, .005}]}]]]


The problem with this is that too short sides lose touch with the smoothed one. A variation where every side is traversed in same amount of time can fix this, causing every side to have one point where the rounded polygon touches the unrounded one:

With[{coords = Append[#, #[[1]]] &@RandomPolygon[{"Convex", 10}][[1]]},
With[{ip =
Interpolation[
Transpose@{Rescale[Range@Length@coords - 1], coords},
InterpolationOrder -> 1]},
Graphics[
{FaceForm@None, EdgeForm@Black, Polygon@coords,
FaceForm@Pink, EdgeForm@None,
Polygon@Table[
Mean@Table[
ip[Mod[t + t0, 1]], {t0, 0, 1/(Length@coords - 1), .01}],
{t, 0, 1, .005}]}]]]


The problem with this variant is that it can have quite uneven curvature.

Here is an approach that is very similar to Henrik's second one. The idea is to use bezier curves, which have (as you might know from Illustrator or Inkscape) fixed points and "handles" that adjust the direction and curvature. We use the midpoints between two vertices of a cell as the fixed point and the handles point in the direction of vertices. When you adjust the length of the handles, then the curve gets smoother or sharper.

The good thing is that the cells will always be glued together at the midpoints which is probably a thing you care about. The only parameter this method has is a factor that scales the handles and you'll get the following result for 0.8

## Code

The only important thing is that BezierCurve takes a list of the form {point, handle, handle, point, handle, handle, ...} which requires some attention when massaging the input points.

createCell[pts_ /; Length[pts] >= 3, f_] := Module[{
ext = Join[pts, pts[[;; 3]]],
result
},
result = Function[{p1, p2, p3},
With[{m1 = Mean[{p1, p2}], m2 = Mean[{p2, p3}]},
{m1, m1 + f*(p2 - m1), m2 + f*(p2 - m2)}
]] @@@ Partition[ext, 3, 1];
BezierCurve[Flatten[result, 1][[;; -3]]]
]

polys = MeshPrimitives[mesh, 2][[All, 1]];
Graphics[{FaceForm[None], EdgeForm[Darker[Blue]], Polygon[polys],
Thickness[0.01], createCell[#, .8] & /@ polys}]



And for the dynamic people among us, here is the thing that created the animation at the top:

drawArrows[pts_] := With[{parts = Partition[pts, 4, 3]},
{Arrow[{#1, #2}], Arrow[{#4, #3}]} & @@@ parts
]

With[
{p = polys[[7]]},
With[
{cell = createCell[p, frac]},
Manipulate[
Graphics[{FaceForm[None], EdgeForm[Darker[Blue]], Polygon[polys],
Thickness[0.015], cell, Thickness[0.005],
Darker[Blue], PointSize[0.03],
, Point[p], Orange, drawArrows @@ cell},
PlotRange -> (MinMax /@ Transpose[p]),