3
$\begingroup$

This is probably a silly question but...

Context

I have gathered from this site Functions to draw sets of concentric 3D rings

as follows:

annulus3D[c_?VectorQ, {r1_, r2_}, h_?Positive] /; 0 < r1 < r2 := 
 BSplineSurface[
  Map[TranslationTransform[c], 
   Map[Function[pt, 
       Append[#1 pt, #2]], {{1, 0}, {1, 1}, {-1, 1}, {-1, 
        0}, {-1, -1}, {1, -1}, {1, 0}}] & @@@ {{r2, h}, {r1, h}, {r1, 
      0}, {r2, 0}}, {2}], SplineClosed -> True, 
  SplineDegree -> {1, 2}, 
  SplineKnots -> {{0, 0, 1/4, 1/2, 3/4, 1, 1}, {0, 0, 0, 1/4, 1/2, 
     1/2, 3/4, 1, 1, 1}}, 
  SplineWeights -> 
   Outer[Times, ConstantArray[1, 4], {1, 1/2, 1/2, 1, 1/2, 1/2, 1}]]
ring3D[orientation_?VectorQ, radius_?NumberQ, width_?NumberQ, 
  height_?NumberQ] := 
 GeometricTransformation[
  annulus3D[{0, 0, 0}, {radius, radius + width}, height], 
  RotationMatrix[Pi/4, orientation]]

so that

ring3D[{0, 0, 1/2}, 3, 3, 0.1]

produces

enter image description here

But as soon as I wrap it with a Graphics3D, it displays a mesh and is very slow

Graphics3D[ring3D[{0, 0, 1/2}, 3, 3, 0.1]]

enter image description here

Question

How can I simply recover the rotated object so that I can superimpose them and still have smoth surfaces and fast rendering? (No mesh)

E.g. Not this:

Graphics3D[{ring3D[{0, 0, 1/2}, 3, 3, 0.1], 
            ring3D[{0, 1/2, 1/2}, 3, 3, 0.1]}]

enter image description here

It might be that the solution involves something else than GeometricTransformation ?

I use Mathematica 12.3 on MacOS.

Note that on Wolfram Cloud the code fails differently: only the first annulus is shown when aiming to display two; so something is wrong with the 3D bounding box.

Improve this question
$\endgroup$
7
  • 1
    $\begingroup$ No mesh problem on iOS Wolfram Cloud (kernel 12.3.0 Linux). Lighting looks a little odd to me, like the surface normals are botched. Not sure about the speed due to internet layer between the app and kernel, but re-renders after rotating quickly. Have you tried EdgeForm[] — looks like after the conversion region -> graphics, the edges of the polygons are being drawn. It might be a bug (probably is, imo, at this point). $\endgroup$
    – Michael E2
    Aug 4, 2021 at 15:15
  • $\begingroup$ @MichaelE2 If I use J.M.'s code annulus3D2[c_?VectorQ, {r1_, r2_}, h_?Positive] /; 0 < r1 < r2 := RegionProduct[BoundaryDiscretizeRegion[Annulus[c, {r1, r2}]], MeshRegion[{{0}, {h}}, Line[{1, 2}]]] I get much improved performance but still a mesh $\endgroup$
    – chris
    Aug 4, 2021 at 15:22
  • $\begingroup$ No problem on my laptop ("12.3.1 for Mac OS X x86 (64-bit) (June 19, 2021)") except when rotating the graphics in the Front End, the shading gets darker toward the center. What version are you using? $\endgroup$
    – Michael E2
    Aug 4, 2021 at 16:18
  • 1
    $\begingroup$ No problem with Mathematica 12.3.1 on Windows 10 x64, except that the second code displays only one ring. $\endgroup$
    – Alexey Popkov
    Aug 5, 2021 at 4:09
  • 1
    $\begingroup$ @chris Probably not, because your specific problem isn't reproduced. Other buggy behavior is found, but not what you describe in the question. I suggest reporting to the support. $\endgroup$
    – Alexey Popkov
    Aug 6, 2021 at 3:56

1 Answer 1

Reset to default
4
$\begingroup$

I found a workaround for my specific problem, but I am still interested in other answers which may address the original problem (Most of the credit goes to J.M. of course).

The idea is to extract the MeshCoordinates and MeshCells by hand.

annulus3D[c_?VectorQ, {r1_, r2_}, h_?Positive] /; 0 < r1 < r2 := 
 Module[{tt, pts, polys}, 
  tt = RegionProduct[BoundaryDiscretizeRegion[Annulus[c, {r1, r2}]], 
    MeshRegion[{{0}, {h}}, Line[{1, 2}]]];
  {pts, polys} = {MeshCoordinates[tt], MeshCells[tt, 2]};
  {EdgeForm[None], GraphicsComplex[pts, polys]}
  ]
ring3D[orientation_?VectorQ, radius_?NumberQ, width_?NumberQ, 
  height_?NumberQ] := 
 GeometricTransformation[
  annulus3D[{0, 0}, {radius, radius + width}, height], 
  RotationMatrix[Pi/4, orientation]]

which allows me to produce

Graphics3D@ring3D[{0, 0, 1}, 3, 3, 1/2]

enter image description here

And eventually

enter image description here

Improve this answer
$\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.