# On drilling holes with minimal redundancy (and with colors!)

The old Mathematica package GraphicsShapes featured the function PerforatePolygons[], which drilled a hole in any Polygon[] primitive present in a Graphics3D[] object. One would usually use it on the output of ParametricPlot3D[] or Polyhedron[] from the GraphicsPolyhedra package, like so: Here is a slightly simplified implementation of PerforatePolygons[] which I used in generating the pictures above:

perforateaux[points_, ratio_] := Block[{test = TrueQ[First[points] == Last[points]],
center, q},
center = Mean[If[test, Most, Identity][points]]; q = 1 - 2 Boole[test];
Partition[#, 2, 1, {1, q}] & /@ {points, (center + ratio (# - center)) & /@ points}]]

PerforatePolygons[shape_, ratio_: 0.5] :=
shape /. Polygon[p_] :> perforateaux[p, ratio]


(I elected to remove the additional EdgeForm[] directive in the original implementation so that the images clearly show what is going on with each polygon. A proper implementation would have it, of course.)

Nowadays, both PolyhedronData[] and ParametricPlot3D[] return GraphicsComplex[] objects within Graphics3D[]. The big benefit of this new representation, among other things, is that it minimizes redundant storage; instead of having a point being stored on three or four Polygon[] primitives, all the points in the object are stored in the first component of GraphicsComplex[], and the Polygon[] objects only need to store the index corresponding to the point they need. For instance, compare the output of PolyhedronData["Tetrahedron", "Faces"] and Normal[PolyhedronData["Tetrahedron", "Faces"]].

The problem with this efficient representation is that it no longer works nicely with polygon replacement rules like the one used by PerforatePolygons[]. Of course, there is the obvious solution of applying Normal[] to any GraphicsComplex[] object generated before applying PerforatePolygons[], but you lose out on the storage efficiency afforded by GraphicsComplex[].

Here now is my question:

Is it possible to improve PerforatePolygons[] so that it works onGraphicsComplex[] objects, with the output still retaining the GraphicsComplex[] characteristic of storage with minimum redundancy?

If the question above is not sufficiently challenging for you, consider the following wrinkle.

Polygon[] objects in Mathematica are currently able to take a VertexColors option that sets how the things are colored, with proper color interpolation within the polygon.

Is it possible to implement a version of PerforatePolygons[] that does its best to have the new polygons inherit the coloring used by the old polygons?

As an example of what is expected: The improved PerforatePolygons[] should be able to produce an image like the one on the right from the one on the left. For triangular polygons, simple bilinear interpolation works nicely, but how about more complicated polygon objects? Again, it is important that a GraphicsComplex[] object still be one after the perforation.

• as a small side note: GraphicsComplex is good because it avoids equality tests on coordinates. The incidents in the polygons just refer to one and the same coordinate. The storage issue is a secondary benefit. – user21 May 22 '12 at 10:19
• I guessed who the asker was after reading the first two sentences ;-) – Szabolcs May 22 '12 at 16:49
• @ruebenko Does GraphicsComplex improve rendering performance? – Szabolcs May 22 '12 at 16:50
• @Szabolcs: was it the writing style, or the unabashed nostalgia? – J. M.'s torpor May 22 '12 at 17:12
• @Szabolcs, it did when I last checked but that's a while back, – user21 May 22 '12 at 20:27

Here's a start:

perforateaux[pts_, ratio_, indices : {__Integer}] :=
Module[
{vertices, center, newPts, ind},
vertices = Replace[indices, {{p_, b___, p_} :> {p, b}}];
center = Mean[pts[[vertices]]];
newPts = ratio (# - center) + center & /@ pts[[ vertices]];
{Partition[vertices, 2, 1, {1, 1}],
Partition[Range[Length[newPts]] + Length[pts], 2, 1, {1, 1}]}];
{Join[pts, newPts], ind}];

perforateaux[pts_, ratio_, indices : {{__Integer} ..}] :=
{#[], Flatten[#[[2, 1]], 1]} &@
Reap[Fold[(Sow[#2]; #1) &@@ perforateaux[#, ratio, #2] &, pts, indices]]

PerforatePolygons[graphics3D_, ratio_: 0.5] :=
graphics3D /. GraphicsComplex[pts_, shape_, opt___] :>
Module[{newshapes},
newshapes = Flatten[Cases[{shape}, Polygon[a_, b___] :>
(If[Depth[a] == 2, {a}, a]), Infinity], 1];
GraphicsComplex[#1, Polygon[#2]] & @@ perforateaux[pts, ratio, newshapes, opt]]


Example

PerforatePolygons[PolyhedronData["Dodecahedron"]] Here's a way to preserve the colouring in a plot. This assumes that the plot is of the form Graphics3D[...GraphicsComplex[pts, {shapes}, ... , VertexColors -> colours, ...], ... ]. I should note that it's not very fast, so I think there is still room for optimisation of the code.

newCols[pts_, collst_, ratio_] := Module[{normal, center, colc},
center = Mean[pts];
colc = Blend[collst, Norm[# - center] & /@ pts];
Blend[{colc, #}, ratio] & /@ collst]

perforateauxCol[pts_, collst_, ratio_, indices : {__Integer}] :=
Module[
{vertices, center, newPts, ind, newcol},
vertices = Replace[indices, {{p_, b___, p_} :> {p, b}}];
center = Mean[pts[[vertices]]];
newPts = ratio (# - center) + center & /@ pts[[ vertices]];
newcol = newCols[pts[[vertices]], collst[[vertices]], ratio];
{Partition[vertices, 2, 1, {1, 1}],
Reverse /@
Partition[Range[Length[newPts]] + Length[pts], 2,
1, {1, 1}]}];
{Join[pts, newPts], Join[collst, newcol], ind}];

perforateauxCol[pts_, collst_, ratio_,
indices : {{__Integer} ..}] :=
{#[[1, 1]], #[[1, 2]],
Flatten[#[[2, 1]], 1]} &@
Reap[Fold[(Sow[#[]]; #[[{1,
2}]]) &@(perforateauxCol[#[], #[],
ratio, #2]) &, {pts, collst}, indices]]

PerforatePolygonsCol[graphics3D_, ratio_: 0.5] := graphics3D /.
GraphicsComplex[pts_, shape_, opt1___, VertexColors -> collst_,
opt2___] :>
Module[{newshapes},
newshapes = Flatten[Cases[{shape}, Polygon[a_, b___] :>
(If[Depth[a] == 2, {a}, a]), Infinity], 1];
GraphicsComplex[#1, Polygon[#3], opt1, VertexColors -> #2,
opt2] & @@
perforateauxCol[N[pts],
If[Head[collst] === List, N[RGBColor @@@ collst], N[collst]],
ratio, newshapes]]


Example

pl = Plot3D[Sin[x^2 - 4 Pi y (1 - y)], {x, 0, Pi}, {y, 0, 1},
PlotPoints -> 20, MaxRecursion -> 1, Mesh -> All,
ColorFunction -> (ColorData["GrayYellowTones"][#3] &)] With holes

pl1 = PerforatePolygonsCol[pl] To remove the edges you can do something like

Show[pl1 /. a_Polygon :> {EdgeForm[], a}] 