Skip to main content

graphics - On drilling holes with minimal redundancy (and with colors!)


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.



Answer



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




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


Comments

Post a Comment

Popular posts from this blog

plotting - Filling between two spheres in SphericalPlot3D

Manipulate[ SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, Mesh -> None, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], {n, 0, 1}] I cant' seem to be able to make a filling between two spheres. I've already tried the obvious Filling -> {1 -> {2}} but Mathematica doesn't seem to like that option. Is there any easy way around this or ... Answer There is no built-in filling in SphericalPlot3D . One option is to use ParametricPlot3D to draw the surfaces between the two shells: Manipulate[ Show[SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], ParametricPlot3D[{ r {Sin[t] Cos[1.5 Pi], Sin[t] Sin[1.5 Pi], Cos[t]}, r {Sin[t] Cos[0 Pi], Sin[t] Sin[0 Pi], Cos[t]}}, {r, 1, 2 - n}, {t, 0, Pi}, PlotStyle -> Yellow, Mesh -> {2, 15}]], {n, 0, 1}]
Post a Comment
Read more

plotting - Plot 4D data with color as 4th dimension

I have a list of 4D data (x position, y position, amplitude, wavelength). I want to plot x, y, and amplitude on a 3D plot and have the color of the points correspond to the wavelength. I have seen many examples using functions to define color but my wavelength cannot be expressed by an analytic function. Is there a simple way to do this? Answer Here a another possible way to visualize 4D data: data = Flatten[Table[{x, y, x^2 + y^2, Sin[x - y]}, {x, -Pi, Pi,Pi/10}, {y,-Pi,Pi, Pi/10}], 1]; You can use the function Point along with VertexColors . Now the points are places using the first three elements and the color is determined by the fourth. In this case I used Hue, but you can use whatever you prefer. Graphics3D[ Point[data[[All, 1 ;; 3]], VertexColors -> Hue /@ data[[All, 4]]], Axes -> True, BoxRatios -> {1, 1, 1/GoldenRatio}]
Post a Comment
Read more

plotting - Adding a thick curve to a regionplot

Suppose we have the following simple RegionPlot: f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}] Now I'm trying to change the curve defined by $y=g[x]$ into a thick black curve, while leaving all other boundaries in the plot unchanged. I've tried adding the region $y=g[x]$ and playing with the plotstyle, which didn't work, and I've tried BoundaryStyle, which changed all the boundaries in the plot. Now I'm kinda out of ideas... Any help would be appreciated! Answer With f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 You can use Epilog to add the thick line: RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}, PlotPoints -> 50, Epilog -> (Plot[g[x], {x, 0, 2}, PlotStyle -> {Black, Thick}][[1]]), PlotStyle -> {Directive[Yellow, Opacity[0.4]], Directive[Pink, Opacity[0.4]],
Post a Comment
Read more