I am trying to "smoothen" meshes. For example, if starting from a cuboid, I would like something similar to a rounded cuboid. There are many ways to smoothen a surface, but I am not going to give a precise definition because I'll be happy with most things that could be qualitatively described as smoothened. It is not a problem if the mesh size changes during the procedure.
How can I smoothen a surface mesh?
So what have I done so far and what's wrong with it?
I tried taking every vertex of the mesh and replacing its coordinates with the average of its neighbours. You'll find an implementation below (iter
). The problem with this approach is that it makes some shapes more jagged instead of smoother.
E.g. if I discretize a sphere with Mathematica, then smoothen it, then a clearly icosahedral structure emerges. I need the sphere to remain a sphere, or at least not to expose any recognizable regular geometry.
mesh = DiscretizeRegion[RegionBoundary@Ball[]];
smoothenedMesh = Nest[iter, mesh, 150];
{mesh, smoothenedMesh}
The icosahedral structure is not that obvious on a static screenshot, but it becomes very clear once you start rotating it interactively. This is not acceptable because my goal is precisely to try to destroy geometric regularities that can be perceived visually.
meshQ[_?MeshRegionQ] := True
meshQ[_?BoundaryMeshRegionQ] := True
meshQ[_] := False
MeshToGraph[mesh_?meshQ] :=
Graph[Developer`ToPackedArray@MeshCells[mesh, 0][[All, 1]],
Developer`ToPackedArray@MeshCells[mesh, 1][[All, 1]],
EdgeWeight -> PropertyValue[{mesh, 1}, MeshCellMeasure],
VertexCoordinates -> MeshCoordinates[mesh]
]
iter[mesh_] := Module[{g, coord, newcoord},
g = MeshToGraph[mesh];
coord = MeshCoordinates[mesh];
newcoord = Mean[coord[[AdjacencyList[g, #]]]] & /@ VertexList[g];
MeshRegion[newcoord, MeshCells[mesh, 2]]
]
Here are some test surfaces which may expose other flaws in a smoothening approach.
Graphics3D[
balls = Table[Ball[RandomReal[1, 3], RandomReal[{0.2, 0.5}]], {20}]
]
mesh1 = DiscretizeRegion[
RegionBoundary[RegionUnion @@ balls],
MaxCellMeasure -> {2 -> 0.005}
]
mesh2 = DiscretizeRegion[
DiscretizeRegion[RegionBoundary@Cuboid[],
MaxCellMeasure -> Infinity], MaxCellMeasure -> {2 -> 0.01},
PlotTheme -> "Default"];
mesh3 = DiscretizeRegion@RegionBoundary@RegionUnion[Cuboid[], Cone[]]
mesh1
should produce an amoeba-like shapeless thing when smoothened. It should not have any sharp or pointy parts.
mesh2
exposes another flaw in my approach: take a look at the corners after smoothening. This however looks more fixable by incremental improvements to the method than the problem I described in the main part of the question.
mesh3
is just another test surface.