About

decimateMesh[mr, n] will simplify the mesh by decimating n vertices of the mesh while moving other vertices to maintain the overall shape.
decimateMesh[mr, Scaled[x]] will decimate x% of the vertices.
Implements Surface Simplification Using Quadric Error Metrics.
Requires V12.2 or higher.
TODO
• handle topological boundaries differently
• always preserve topology
• add an optional bias to simplify planar regions less

Code

Compiled helpers

SetAttributes[fastCompile, HoldAllComplete];​​fastCompile[args__] := ​​ Compile[​​ args,​​ CompilationTarget  "C",​​ Parallelization  True,​​ RuntimeOptions  "Speed",​​ CompilationOptions  {"InlineCompiledFunctions"  True, "InlineExternalDefinitions"  True}​​ ]
In[]:=
fundamentalErrorQuadrics[mr_] := feqC[faceNormals[mr], MeshPrimitives[mr, 2, "Multicells"  True]〚1, 1, All, 1〛]
In[]:=
faceNormals[mr_] :=​​ With[{n = Region`Mesh`MeshCellNormals[mr, 2]},​​ n /; ArrayQ[n]​​ ]
In[]:=
faceNormals[mr_] := Join @@ facenormalsC /@ MeshPrimitives[mr, 2, "Multicells" -> True][[1]]
In[]:=
If[Head[facenormalsC] =!= CompiledFunction,​​ facenormalsC = fastCompile[{{faces, _Real, 2}},​​ Module[{cross, norm},​​ cross = Cross[faces[[2]]-faces[[1]],faces[[3]]-faces[[1]]];​​ norm = Total[cross^2];​​ If[norm > 0, Divide[cross, Sqrt[norm]], cross]​​ ],​​ RuntimeAttributes->{Listable},​​ Parallelization->False​​ ];​​];
In[]:=
feqC = fastCompile[{{normals, _Real, 2}, {fp, _Real, 2}},​​ Module[{tr},​​ ​​ tr = Transpose[normals];​​ AppendTo[tr, Minus[Total[tr Transpose[fp]]]];​​ ​​ Transpose[Outer[Times, tr, tr, 1], {3, 2, 1}]​​ ]​​][[-1]];
In[]:=
cTotal = fastCompile[{{p, _Integer, 1}, {M, _Real, 3}},​​ Total[M〚p〛],​​ RuntimeAttributes  {Listable}​​];
In[]:=
faceNormal = fastCompile[{{coords, _Real, 2}, {inds, _Integer, 1}},​​ Module[{cross, norm},​​ cross = Cross[​​ Subtract[Compile`GetElement[coords, Compile`GetElement[inds, 2]], Compile`GetElement[coords, Compile`GetElement[inds, 1]]], ​​ Subtract[Compile`GetElement[coords, Compile`GetElement[inds, 3]], Compile`GetElement[coords, Compile`GetElement[inds, 1]]]​​ ];​​ norm = cross.cross;​​ Power[norm + Subtract[1.0, Unitize[norm]], -0.5]*cross​​ ],​​ RuntimeAttributes  {Listable},​​ Parallelization  False​​];
In[]:=
replaceValue = fastCompile[{{i, _Integer}, {s, _Integer}, {f, _Integer}},​​ If[i  s, f, i],​​ RuntimeAttributes  {Listable},​​ Parallelization  False​​];
In[]:=
getTerms[expr_Plus, c_] := Total[Pick[List @@ expr, List @@ expr /. _Compile`GetElement  1, c] /. -1  1]
In[]:=
Clear[inverseMask, inverseMaskP];​​Quiet @ With[​​ ​​ code1 = Map[getTerms[#, 1]&, Det[Array[m, {4, 4}]] * Inverse[Array[m, {4, 4}]]〚1;;3, -1〛 /. {m[4, 4]  1, m[4, _]  0} /. {m[a__]  Compile`GetElement[m, a]}],​​ code2 = Map[getTerms[#, -1]&, Det[Array[m, {4, 4}]] * Inverse[Array[m, {4, 4}]]〚1;;3, -1〛 /. {m[4, 4]  1, m[4, _]  0} /. {m[a__]  Compile`GetElement[m, a]}],​​ det1 = getTerms[Det[Array[m, {4, 4}]] /. {m[4, 4]  1, m[4, _]  0} /. {m[a__]  Compile`GetElement[m, a]}, 1],​​ det2 = getTerms[Det[Array[m, {4, 4}]] /. {m[4, 4]  1, m[4, _]  0} /. {m[a__]  Compile`GetElement[m, a]}, -1]​​ ,​​ MapThread[​​ #1 = fastCompile[{{coords, _Real, 2}, {i, _Integer, 1}, {m, _Real, 2}},​​ Module[{d = Subtract[det1, det2]},​​ If[Abs[d] > 10^-12.,​​ Power[d, -1.0] Subtract[code1, code2],​​ Mean[coords[[i]]]​​ ]],​​ RuntimeAttributes  {Listable},​​ Parallelization  #2​​ ]&,​​ {{inverseMask, inverseMaskP}, {False, True}}​​ ]​​];
In[]:=
Clear[dCost, dCostP];​​MapThread[​​ #1 = fastCompile[{{v, _Real, 1}, {m, _Real, 2}},​​ Append[v, 1].m.Append[v, 1],​​ RuntimeAttributes  {Listable},​​ Parallelization  #2​​ ]&,​​ {{dCost, dCostP}, {False, True}}​​];
In[]:=
ClearAll[Profile];​​SetAttributes[Profile, HoldFirst];
In[]:=
Profile[code_, tag_] := Sow[First[AbsoluteTiming[code]], tag];
In[]:=
Profile[code_, tag_] := code

Utilities

Main

Main