9
$\begingroup$

Recently I am replaying with this (I made it in the past):

hyperboloid with holes

the theory is Texture in Mathematica (map the vertex(x,y) to curve(u,v), and draw polygons). So I decided to make it with Mathematica.

ParametricPlot3D[{Sqrt[u^2 - 1] Cos[v], 
  Sqrt[u^2 - 1] Sin[v], -u}, {u, -8, 8}, {v, 0, 2 π}, 
 PlotStyle -> {Texture[
    MengerMesh[4] // Rasterize[#, RasterSize -> 600] & // 
     ImageTrim[#, {{0, 0} + 13, {600, 600} - 13}] &]}, 
 Boxed -> False, Axes -> False, Mesh -> None]

Now I want to hollow out this surface. How to do it?

my attempt

$\endgroup$

4 Answers 4

7
$\begingroup$

Using ColorReplace[] to inject transparency into a texture is very useful for this sort of thing:

sierp = ColorReplace[Rasterize[Show[MengerMesh[4, MeshCellStyle -> {{1, All} -> Gray,
                                                                    {2, All} -> Gray}],
                                    ImagePadding -> None, PlotRangePadding -> None],
                               RasterSize -> 600], White];

ParametricPlot3D[{Sqrt[u^2 - 1] Cos[v], Sqrt[u^2 - 1] Sin[v], -u},
                 {u, -8, 8}, {v, 0, 2 π}, Axes -> False, Boxed -> False,
                 PlotStyle -> {Texture[sierp]}, Mesh -> None]

hyperboloid with Sierpinski holes

$\endgroup$
5
$\begingroup$

Expanding cvgmt's answer, there is a perfect result within 10 seconds in my macbook.

Let's unwrap uv to plane,[Here is done by Sow/Reap u,v] and then choose polygons in Region.

reg=TransformedRegion[MengerMesh[4],{Rescale[Indexed[#,1],{0,1},{0,2Pi}],Rescale[Indexed[#,2],{0,1},{0,\[Pi]}]}&]
AbsoluteTiming[c=0;r=Reap[surf=ParametricPlot3D[{Cos[u]Sin[v],Cos[u]Cos[v],Sin[u]}(*{Sqrt[u^2-1] Cos[v],Sqrt[u^2-1] Sin[v],-u}*),{u,0,2\[Pi]},{v,0,\[Pi]},RegionFunction->Function[{x,y,z,u,v},Sow[{{x,y,z},{u,v}}];True],PlotPoints->100,MaxRecursion->2,Boxed->False,Axes->False,Mesh->False,ColorFunction->(ColorData["Rainbow"][#2]&)]];]
pts=Flatten[r[[2,1]][[All,1]],0];
pts//Length
uv=r[[2,1]][[All,2]];
uv//Length
AbsoluteTiming[tfList=RegionMember[reg,uv];]
tfList//Counts
pts2Plot=Pick[pts,tfList];
mesh=DiscretizeGraphics@r[[1]];
polygons=MeshPrimitives[mesh,2];
polygons//Length
meshPoint=DiscretizeGraphics@Graphics3D[Point/@pts2Plot];
AbsoluteTiming[polygons2Use=Select[polygons[[1;;-1]],Or@@RegionMember[meshPoint,#[[1]]]&];]
Graphics3D[{EdgeForm[],polygons2Use,Red,meshPoint}]

enter image description here enter image description here


Update

The above method is limited, since the sampling problem of ParametricPlot3D enter image description here

So we can plot it with Graphics3D

enter image description here

reg=MengerMesh[4,DataRange->{{-8,8},{0,2\[Pi]}}];
polygons=MeshCells[reg,2];
coo=MeshCoordinates[reg];
pts2Use=Table[{u,v}=p;{Sqrt[u^2-1] Cos[v],Sqrt[u^2-1] Sin[v],-u},{p,coo}];
pts2UseReal=If[AnyTrue[Head/@#,#===Complex&],{0,0,0},#]&/@pts2Use;
gc=GraphicsComplex[pts2UseReal,polygons];
Graphics3D@gc
$\endgroup$
4
$\begingroup$

You can simply add the option Background -> None in Rasterize:

mm = Rasterize[MengerMesh[4, MeshCellStyle -> {{1, All} -> Gray, {2, All} -> Gray}, 
     ImagePadding -> None, PlotRangePadding -> None], 
   RasterSize -> 900, Background -> None];

ParametricPlot3D[{Sqrt[u^2 - 1] Cos[v], Sqrt[u^2 - 1] Sin[v], -u}, 
 {u, -8, 8}, {v, 0, 2 π}, 
 Axes -> False, Boxed -> False, PlotStyle -> Texture[mm], Mesh -> None]

enter image description here

Use Texture[ImageMultiply[mm, RGBColor[0, 0, 1, .5]]] to get

enter image description here

$\endgroup$
4
$\begingroup$

Updated

Simply use {u, v} ∈ reg in the parametric domain is faster enough!

reg = MengerMesh[5, DataRange -> {{-8, 8}, {0, 2 π}}];
surf = ParametricPlot3D[{Sqrt[u^2 - 1] Cos[v], 
   Sqrt[u^2 - 1] Sin[v], -u}, {u, v} ∈ reg, PlotPoints -> 80,
   MaxRecursion -> 2, Boxed -> False, Axes -> False, Mesh -> False, 
  ColorFunction -> (ColorData["Rainbow"][#2] &)]
dissurf = surf // DiscretizeGraphics

enter image description here

Original

Not so faster,but it can be DiscretizeGraphics or export to stl format with holes.

reg = TransformedRegion[
   MengerMesh[
    4], {Rescale[Indexed[#, 1], {0, 1}, {-8, 8}], 
     Rescale[Indexed[#, 2], {0, 1}, {0, 2 π}]} &];
(* Show[reg,Graphics[{EdgeForm[Red],FaceForm[],Rectangle[{-8,0},{8,2\
π}]}]] *)
surf = 
 ParametricPlot3D[{Sqrt[u^2 - 1] Cos[v], 
   Sqrt[u^2 - 1] Sin[v], -u}, {u, -8, 8}, {v, 0, 2 π}, 
  RegionFunction -> 
   Function[{x, y, z, u, v}, RegionMember[reg, {u, v}]], 
  PlotPoints -> 80, MaxRecursion -> 2, Boxed -> False, Axes -> False, 
  Mesh -> False, ColorFunction -> (ColorData["Rainbow"][#2] &)]
dissurf = surf // DiscretizeGraphics
$\endgroup$

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.