Rounding an Irregular Polygon
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.
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}]
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}
]
]
]