Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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.

share|improve this question
3  
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
1  
I guessed who the asker was after reading the first two sentences ;-) –  Szabolcs May 22 '12 at 16:49
1  
@ruebenko Does GraphicsComplex improve rendering performance? –  Szabolcs May 22 '12 at 16:50
1  
@Szabolcs: was it the writing style, or the unabashed nostalgia? –  J. M. 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
add comment

1 Answer

up vote 18 down vote accepted

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]];
   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___] :>
   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"]]

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}] :=
  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];
   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___] :>
   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] &)]

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

share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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