1
$\begingroup$

Using some code from http://www.bugman123.com/Hyperbolic/index.html

n = 7; m = 3; dt = 2 Pi/n; dtm = 2 Pi/m; r = 
 1.0/(1 - Sin[dt/2]/Cos[dtm/2]); R = r Cos[(dt + dtm)/2]/Cos[dtm/2];
ToMatrix[z_, 
   r_] := (I/r) {{z, r^2 - z Conjugate[z]}, {1, -Conjugate[z]}};
alist = Table[
  ToMatrix[r Exp[I t], r - 1], {t, dt/2, 2 Pi, dt}]; Tlist = 
 Join[{IdentityMatrix[2]}, alist];
homography[{{a_, b_}, {c_, d_}}, z_] := (a z + b)/(c z + d);
FindT[T0_, Tlist_] := 
  MemberQ[Tlist, 
   T_ /; Abs[homography[T, 0] - homography[T0, 0]] < 1.0*^-3];
i2 = 1; Do[i1 = i2 + 1; i2 = Length[Tlist]; 
 Do[Scan[(T = Tlist[[i]].#; 
     If[! FindT[T, Tlist], Tlist = Append[Tlist, T]]) &, alist], {i, 
   i1, i2}], {2}];
plot = Show[
  Graphics[Map[
    Line[Table[
       z = homography[#, R Exp[I t]]; {Re[z], Im[z]}, {t, 0, 2 Pi, 
        dt}]] &, Tlist], AspectRatio -> Automatic]]

plotFilled = Show[Graphics[
 Map[{RGBColor[RandomReal[], RandomReal[], RandomReal[]], 
  Polygon[Table[
    z = homography[#, R Exp[I t]]; {Re[z], Im[z]}, {t, 0, 2 Pi, 
     dt}]]} &, Tlist], AspectRatio -> Automatic]]

to make Poincaré hyperbolic tilings

Poincaré hyperbolic tiling Poincaré hyperbolic tiling

and some code I grab from here

Options[Extrude] = 
  Join[Options[Graphics3D], {Closed -> True, Capped -> True}];
Extrude[curve_, {zmin_, zmax_}, opts : OptionsPattern[]] := 
  Module[{info, points, color, tube, caps}, info = Flatten[{curve}]; 
   points = Select[info, Head[#1] === Line &][[1, 1]]; 
   If[OptionValue[Closed], points = Join[points, {points[[1]]}]]; 
   color = Select[info, Head[#1] === Directive &]; 
   If[Length[color] == 0, color = Orange, 
    color = First[Select[color[[1]], ColorQ]]]; 
   tube = Polygon[
     Partition[
      Flatten[Transpose[(points /. {x_, y_} -> {x, y, #1} &) /@ {zmin,
           zmax}], 1], 3, 1]]; 
   If[OptionValue[Closed] && OptionValue[Capped], 
    caps = (Polygon[points /. {x_, y_} -> {x, y, #1}] &) /@ {zmin, 
       zmax}; tube = Flatten[{tube, caps}], tube = {tube}]; 
   Graphics3D[(Flatten[{color, #1}] &) /@ tube, 
    FilterRules[{opts}, Options[Graphics3D]]]];

I wanted to make some pretty 3D printed drink coasters:

plotSheet = 
 Show[Extrude[#, {-0.01, 0.01}, Capped -> True, Boxed -> False] & /@ 
   plot[[1]]]
plotTube = 
 Graphics3D[{JoinForm["Miter"], 
   plot[[1, 2 ;; -1]] /. 
    Line[pts_, rest___] :> Tube[Append[#, 0] & /@ pts, 0.05, rest]}, 
  Axes -> True]
plotFilledSheet = Show[plotSheet, plotTube, PlotRange -> All]

Fancy drink coaster

However, when I try to discretize this to make it a filled region, I get

DiscretizeGraphics[plotFilledSheet]

Bad discretization

I have also tried simply exporting as an STL but then the tubes around the outer heptagons in the STL are not connected. CAD software then treats it as an open region (surface) and trying to close it lead to awful results.

Saving as an OBJ gave results just like DiscretizeGraphics.

Does anyone have thoughts on how I can get this and the bowl I want to make printed?

Bowl

$\endgroup$
1
$\begingroup$

Sigh. Indeed, that is really frustrating. Tubes are always a pain to work with and junctions are particularly hard to get pretty.

The following is a brute-force method that represents the final BoundaryMeshRegions as sublevel sets of (i) the distance function to edges of the heptagons and (ii) the surface to of the heptagons. In the end, I "join" the BoundaryMeshRegions with Show and by exporting to STL. It seems to work but I cannot check if your external program excepts the resulting STL file as input. I also tried RegionUnion on S1 and S2, but that took forever...

data = Map[ Table[z = homography[#, R Exp[I t]]; {Re[z], Im[z], 0.}, {t, 0, 2 Pi, dt}] &, Tlist];
L = MeshRegion[
   Join @@ Most /@ data,
   Line[Join @@ (Partition[#, 2, 1, 1] & /@Partition[Range[7 Length[data]], 7])]];
P = MeshRegion[
   Join @@ Most /@ data,
   Polygon[Partition[Range[7 Length[data]], 7]]
   ];
f = RegionDistance[L];
g = RegionDistance[P];
θ1 = 0.05;
θ2 = 0.01;
z =.

R1 = ImplicitRegion[f[{x, y, z}] <= θ1, {{x, -4, 4}, {y, -4,4}, {z, -θ1 1.1, θ1 1.1}}];
R2 = ImplicitRegion[g[{x, y, z}] <= θ2, {{x, -4, 4}, {y, -4, 4}, {z, -θ1 1.1, θ1 1.1}}];

S1 = BoundaryDiscretizeRegion[R1, MaxCellMeasure -> 0.001]; // 
  AbsoluteTiming // First
S2 = BoundaryDiscretizeRegion[R2, MaxCellMeasure -> 0.001]; // 
  AbsoluteTiming // First

Export["a.stl", Show[S1, S2]]; // AbsoluteTiming // First

24.8892

6.34708

79.5849

You may control the resolution of the generated BoundaryMeshRegions by setting the option MaxCellMeasure as desired.

$\endgroup$
  • $\begingroup$ That works wonderfully... thank you! Now I just gotta get my 3D printer fixed. $\endgroup$ – EricMock Feb 3 at 21:25
  • $\begingroup$ I am glad to hear that (that it worked, not that your printer is broken ;) ). You're welcome! $\endgroup$ – Henrik Schumacher Feb 3 at 21:27
  • $\begingroup$ This might be a topic for a new question but I'll ask here. Is there a way to change/override Norm in the RegionDistance function to something besides Euclidean? Obviously I'm thinking of different cross-sections. $\endgroup$ – EricMock Feb 5 at 1:04
  • $\begingroup$ Hm. None that I know of. I also think that it would be hard to design more interesting cross sections by specifying a distance function. What you have in mind would probably depend on the directions of the edges of the heptatgons. This would be so aniotropic that it probably cannot be represented by a norm... $\endgroup$ – Henrik Schumacher Feb 5 at 1:29
  • $\begingroup$ My original thought was just a square cross-section. But, then I started thinking "crazy". Something like DistanceFunction for Nearest. $\endgroup$ – EricMock Feb 5 at 1:43

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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