Rounding an Irregular Polygon

Question

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.

Now, I believe there are two ways to go about this:

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"}]]

Answer 1

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}]

Answer 2

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.

Answer 3

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]),
    PlotRangePadding -> 0.2],
   {{frac, 1}, .5, 1.1}
   ]
  ]
 ]