The old Mathematica package Graphics`Shapes` 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 Graphics`Polyhedra` package, like so:

objects with holes

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];
    MapThread[Polygon[Join[#1, Reverse[#2]]] &, 
     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:

colored polygon, with and without hole

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.

  • 5
    $\begingroup$ 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. $\endgroup$
    – user21
    May 22, 2012 at 10:19
  • 1
    $\begingroup$ I guessed who the asker was after reading the first two sentences ;-) $\endgroup$
    – Szabolcs
    May 22, 2012 at 16:49
  • 1
    $\begingroup$ @ruebenko Does GraphicsComplex improve rendering performance? $\endgroup$
    – Szabolcs
    May 22, 2012 at 16:50
  • 1
    $\begingroup$ @Szabolcs: was it the writing style, or the unabashed nostalgia? $\endgroup$ May 22, 2012 at 17:12
  • $\begingroup$ @Szabolcs, it did when I last checked but that's a while back, $\endgroup$
    – user21
    May 22, 2012 at 20:27

1 Answer 1


Here's a start:

perforateaux[pts_, ratio_, indices : {__Integer}] :=
   {vertices, center, newPts, ind},
   vertices = Replace[indices, {{p_, b___, p_} :> {p, b}}];
   center = Mean[pts[[vertices]]];
   newPts = ratio (# - center) + center & /@ pts[[ vertices]];
   ind = MapThread[Flatten[{#1, Reverse[#2]}] &,
     {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} ..}] :=
 {#[[1]], Flatten[#[[2, 1]], 1]} &@
  Reap[Fold[(Sow[#2]; #1) &@@ perforateaux[#, ratio, #2] &, pts, indices]]

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



Mathematica graphics

Edit: Adding colours

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}] :=
   {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];
   ind = MapThread[Flatten[{##}] &,
     {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[#[[3]]]; #[[{1, 
           2}]]) &@(perforateauxCol[#[[1]], #[[2]], 
        ratio, #2]) &, {pts, collst}, indices]]

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


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] &)]

Mathematica graphics

With holes

pl1 = PerforatePolygonsCol[pl]

Mathematica graphics

To remove the edges you can do something like

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

Mathematica graphics


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.