4
$\begingroup$

I want to make a high-resolution 3d model of the Reuleaux tetrahedron by using Mathematica

The Reuleaux tetrahedron is the intersection of four balls of radius s centered at the vertices of a regular tetrahedron with side length s.

p = {{0, 0, -(Sqrt[(3/2)]/2)}, {1/Sqrt[3], 0, 1/(2 Sqrt[6])},
    {-(1/(2 Sqrt[3])), 1/2, 1/(2 Sqrt[6])}, {-(1/(2 Sqrt[3])), -(1/2), 1/(2 Sqrt[6])}};

Graphics3D[{Red, Opacity[.4], Ball /@ p}, Boxed -> False]

enter image description here

reg = RegionIntersection @@ (Ball /@ p);
DiscretizeRegion[reg]

enter image description here

$\endgroup$
11
$\begingroup$

Use the OpenCascadeLink for this:

Needs["OpenCascadeLink`"]
s = OpenCascadeShape /@ (Ball /@ p);
shape = OpenCascadeShapeIntersection[s];
bmesh = OpenCascadeShapeSurfaceMeshToBoundaryMesh[shape];

Or, even simpler:

shape = OpenCascadeShape[ RegionIntersection @@ (Ball /@ p)];
bmesh = OpenCascadeShapeSurfaceMeshToBoundaryMesh[shape];

Or:

Needs["NDSolve`FEM`"]
bmesh = ToBoundaryMesh[RegionIntersection @@ (Ball /@ p), 
  "BoundaryMeshGenerator" -> {"OpenCascade"}]

You can then visualize with, for example:

groups = bmesh["BoundaryElementMarkerUnion"];
temp = Most[Range[0, 1, 1/(Length[groups])]];
colors = ColorData["BrightBands"][#] & /@ temp;
bmesh["Wireframe"["MeshElementStyle" -> FaceForm /@ colors]]

enter image description here

$\endgroup$
9
$\begingroup$

DiscretizeRegion before RegionIntersection.

p = {{0, 0, -(Sqrt[(3/2)]/2)}, {1/Sqrt[3], 0, 
    1/(2 Sqrt[6])}, {-(1/(2 Sqrt[3])), 1/2, 
    1/(2 Sqrt[6])}, {-(1/(2 Sqrt[3])), -(1/2), 1/(2 Sqrt[6])}};
reg = DiscretizeRegion /@ Ball /@ p
RegionIntersection[reg, ViewPoint -> {-1.14137, 0.973908, 0.865322}, 
 ViewProjection -> "Orthographic"]

enter image description here

$\endgroup$
3
  • 1
    $\begingroup$ MaxCellMeasure -> 0.01,AccuracyGoal -> 3 Maybe useful. $\endgroup$
    – cvgmt
    Dec 12 '20 at 11:14
  • 1
    $\begingroup$ +1 You can add the options ViewPoint->{-1.14137, 0.973908, 0.865322}, ViewProjection->"Orthographic" to the RegionIntersection and skip the RegionPlot3D $\endgroup$
    – Bob Hanlon
    Dec 12 '20 at 16:29
  • $\begingroup$ @BobHanlon Thank you! Just what I looking for! $\endgroup$
    – cvgmt
    Dec 12 '20 at 16:32
1
$\begingroup$
With[{p = {{0, 0, -(Sqrt[(3/2)]/2)}, {1/Sqrt[3], 0, 
                    1/(2 Sqrt[6])}, {-(1/(2 Sqrt[3])), 1/2, 
                    1/(2 Sqrt[6])}, {-(1/(2 Sqrt[3])), -(1/2), 1/(2 Sqrt[6])}}},
    RegionIntersection @@ (Ball /@ p) // 
        RegionPlot3D[#, PlotPoints -> 80] &
    ]

enter image description here

$\endgroup$

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.