# How to hollow out this surface?

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

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?

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}],
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]


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}]


Update

The above method is limited, since the sampling problem of ParametricPlot3D

So we can plot it with Graphics3D

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}];
gc=GraphicsComplex[pts2UseReal,polygons];
Graphics3D@gc


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

mm = Rasterize[MengerMesh[4, MeshCellStyle -> {{1, All} -> Gray, {2, All} -> Gray},
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]


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

# 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


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