Reuleaux Tetrahedron

Author

Eric W. Weisstein
October 16, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/SolidGeometry/ReuleauxTetrahedron.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/ReuleauxTetrahedron.html.

©2023 Wolfram Research, Inc. except for portions noted otherwise

Construction

Vertices of a cube of edge length (Sqrt[2])

v=Join[{{0,0,0}},Permutations[{0,1,1}]]

EuclideanDistance@@@Subsets[v,{2}]

ineq=And@@(SquaredEuclideanDistance[{x,y,z},#]<2&/@v)/.Abs->Identity

With[{r=2},
RegionPlot3D[And@@ineq,{x,-r,r},{y,-r,r},{z,-r,r},Boxed->False,Axes->False,PlotPoints->100,Method->{"ShrinkWrap"->True}]
]

Centroid at (0, 0, 0)

v={{0,0,-Sqrt[6]/4},{Sqrt[3]/3,0,Sqrt[6]/12},{-Sqrt[3]/6,1/2,Sqrt[6]/12},{-Sqrt[3]/6,-1/2,Sqrt[6]/12}}

ineq2=Function[v,v.v][{x,y,z}-#]<1&/@v

Graphics3D[{Opacity[.5],Sphere/@v},Boxed->False]

With[{r=1},
RegionPlot3D[And@@ineq2,{x,-r,r},{y,-r,r},{z,-r,r},Boxed->False,Axes->False,PlotPoints->100,Method->{"ShrinkWrap"->True}]
]

Show[Graphics3D[{Opacity[.6],{Black,Sphere[v,.03]},ConvexHullRegion[v]},AspectRatio->Automatic],PlotRange->All,Ticks->None]

Solid

Centroid at (0, 0, 0)

Cube Vertices

Region

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[{Opacity[.5],Ball/@p},Boxed->False,Method->{"ShrinkWrap"->True},ImageSize->Small]

reg=RegionIntersection@@(Ball/@{{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])))}})

Block[{a=1},DiscretizeRegion[reg]]

RegionMeasure[reg//N]

RegionMeasure[reg]//Timing

Curve

Parametric Equation of Curve

Function[v,v.v][{x,y,z}-#]==1&/@p

Function[v,v.v][{x,y,z}-#]==1&/@p[[{1,3,4}]]

{x,y} /.Solve[%[[{1,2}]],{x,y}]

eqn=Append[FullSimplify[{(1/8) (4 (Sqrt[2]) z+(Sqrt[6]) (Sqrt[5-4 (Sqrt[6]) z-24 (z^2)])),-(1/3) ((Sqrt[(3/2)]) z-2 (Sqrt[6]) z+((3 (Sqrt[5-4 (Sqrt[6]) z-24 (z^2)]))/(4 (Sqrt[2]))))}],z]

{f,g}=Drop[{(1/4) (2 (Sqrt[2]) z+(Sqrt[(15/2)-6 z ((Sqrt[6])+6 z)])),-((-4 (Sqrt[3]) z+(Sqrt[5-4 z ((Sqrt[6])+6 z)]))/(4 (Sqrt[2]))),z},-1]

Simple form due to Mads Sørensen

{(1/2)(Sqrt[2])z+(1/4) (Sqrt[(15/2)-6(Sqrt[6]) z (1+(Sqrt[6]) z)]),((4 (Sqrt[3]) z+(Sqrt[5-4(Sqrt[6]) z (1+(Sqrt[6]) z)]))/(4(Sqrt[2])))}-{(1/2)(Sqrt[2])z+(1/8)(Sqrt[6])(Sqrt[5-4(Sqrt[6])z(1+(Sqrt[6])z)]),(1/2)(Sqrt[6])z+(1/8)(Sqrt[2])(Sqrt[5-4(Sqrt[6])z(1+(Sqrt[6])z)])}//FullSimplify

Find endpoints

Simplify[eqn/.z->Sqrt[6]/12]

Solve[(15/2)-6 z ((Sqrt[6])+6 z)==0,z]

tip=Simplify[eqn/. z->(1/12) (6-(Sqrt[6]))]

vertex=Simplify[eqn/. z->Sqrt[6]/12]

Line element

Sqrt[FullSimplify[D[f,z]^2+D[g,z]^2+1]]

Arc Length

l=FullSimplify[2Integrate[3 (Sqrt[2]) (Sqrt[-(1/(-5+4 z ((Sqrt[6])+6 z)))]),{z,Sqrt[6]/12,(1/12) (6-(Sqrt[6]))}]]

FullSimplify[%]

N[l]

FullSimplify[(y-Sqrt[6]/12)/((1/12) (6-(Sqrt[6]))-Sqrt[6]/12)]

-(1/6) (3+(Sqrt[6])) ((Sqrt[6])-12 #)&/@{Sqrt[6]/12,(1/12) (6-(Sqrt[6]))}

l2=FullSimplify[2Integrate[3 (Sqrt[2]) (Sqrt[-(1/(-5+4 z ((Sqrt[6])+6 z)))]),{z,Sqrt[6]/12,(1/12) (6-(Sqrt[6]))}]]

Simplify[6 (Sqrt[2]) (Sqrt[-(1/(-5+4 z ((Sqrt[6])+6 z)))]) /. z->y Sqrt[6]/12]

6 (Sqrt[2])/(Sqrt[5-2 y-(y^2)])

FullSimplify[(1/12) (6-(Sqrt[6]))/(Sqrt[6]/12)]

Expand[Sqrt[6]/12 6 (Sqrt[2])]

Integrate[(1/(Sqrt[5-2 y-(y^2)])),{y,1,Sqrt[6]-1}]Expand[Sqrt[6]/12 6 (Sqrt[2])]

N[%]

Simplify[((6 (Sqrt[2]))/(Sqrt[5-2 y-(y^2)])) /. y->(z-1)]

Sqrt[6]/12 6Sqrt[2]

FullSimplify[Sqrt[6]/12Integrate[((6Sqrt[2])/(Sqrt[6-(z^2)])),{z,2,Sqrt[6]}]]

N[%]

N[(Sqrt[3]) ArcCot[(Sqrt[2])]]

V7

2Integrate[3 (Sqrt[2]) (Sqrt[-(1/(-5+4 z ((Sqrt[6])+6 z)))]),{z,Sqrt[6]/12,(1/12) (6-(Sqrt[6]))}]

FullSimplify[%]

N[%]

Sqrt[6]/12Integrate[((6Sqrt[2])/(Sqrt[6-(z^2)])),{z,2,Sqrt[6]}]

Spherical triangle check

a=b=c=l;
s=(a+b+c)/2;

l'Huillier's Theorem

delta1=FullSimplify[4ArcTan[Sqrt[Tan[s/2]Tan[(s-a)/2]^3]]]

Law of Cosines for sides

aa=FullSimplify[ArcCos[(Cos[a]-Cos[b]Cos[c])/Sin[b]/Sin[c]]]

delta2=(3aa-Pi)

N[delta1-delta2,1000]

Show[Graphics3D[{
PointSize[.05],Point/@p,Point[{(1/12) (3 (Sqrt[2])-(Sqrt[3])),-(1/4) (1-(Sqrt[6])),(1/12) (6-(Sqrt[6]))}],
t,
ParametricPlot3D[eqn,{z,Sqrt[6]/12,(1/12) (6-(Sqrt[6]))},DisplayFunction->Identity][[1]]
},AspectRatio->Automatic],PlotRange->All,ViewPoint->{0,0,2},Axes->True,Ticks->None]

FullSimplify[ArcCos[tip[[-1]]/Sqrt[tip.tip]]]

FullSimplify[ArcCos[vertex[[-1]]/Sqrt[vertex.vertex]]]

eqn

FullSimplify[{(1/4) (2 (Sqrt[2]) z+(Sqrt[(15/2)-6 z ((Sqrt[6])+6 z)])),-((-4 (Sqrt[3]) z+(Sqrt[5-4 z ((Sqrt[6])+6 z)]))/(4 (Sqrt[2]))),z}]

Find z(θ)

FullSimplify[eqn[[2]]/eqn[[1]]]

t->Tan[θ]

FullSimplify[z/.Solve[t==FullSimplify[eqn[[2]]/eqn[[1]]],z]]

zt=-(((Sqrt[3])+3 t (2+(Sqrt[3]) t)-4 (Sqrt[3+19 (t^2)+12 (t^4)+(Sqrt[3]) t (7+11 (t^2))]))/(2 (Sqrt[2]) (9+2 (Sqrt[3]) t+11 (t^2))))

Check that correct values are returned for endpoints

Simplify@{zt/. θ->0,zt/.θ->Pi/3}

Parametric Equation of Edge

a=Simplify[LineLineIntersection[{{-Sqrt[3]/6,1/2},{Sqrt[3]/3,0}},{{0,0},{Cos[θ],Sin[θ]}}]]

Simplify[{a/.θ->0,a/.θ->Pi/3}]

({-Sqrt[3]/6,1/2}+{Sqrt[3]/3,0})/2

Simplify[z/Sqrt[x^2+y^2+z^2] /. {x->((Cos[θ])/((Sqrt[3]) Cos[θ]+3 Sin[θ])),y->((Sin[θ])/((Sqrt[3]) Cos[θ]+3 Sin[θ])),z->Sqrt[6]/12}]

FullSimplify[ArcCos[(1/((Sqrt[3]) (Sqrt[((10-Cos[2 θ]+(Sqrt[3]) Sin[2 θ])/((((Sqrt[3]) Cos[θ]+3 Sin[θ]))^2))])))]]

FullSimplify[ArcTan[((Sqrt[24])/(((Sqrt[3]) Cos[θ]+3 Sin[θ])))]]

SurfaceArea

www.math.unl.edu/~bharbourne1/ST/sphericaltetrahedron.html

N[8π-18ArcCos[1/3],20]

Volume

Exact

N[s1=(1/12)(3(Sqrt[2])-49π+162ArcTan[(Sqrt[2])]),20]

FullSimplify[s1]

N[s2=1/24 (6 Sqrt[2]+16 Pi+57 ArcCos[17/81]-132 ArcTan[Sqrt[2]]),20]

FullSimplify[s2]

FullSimplify[s1-s2]

TrigToExp[s1-s2]//FullSimplify

FullSimplify[TrigToExp[#]]&/@{s1,s2}

N[s3=8/3π-(27/4)ArcCos[1/3]+(Sqrt[2])/4]

FullSimplify[s1-s3]

Boole [unevaluated pieces]

(x, y, z) [unevaluated integral]

(Vxyz=((Integrate[Boole[ineq],{x,y,z}∈FullRegion[3]])/((Sqrt[2])^3)))//Timing

(Vxyz=((Integrate[Boole[ineq],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞}])/((Sqrt[2])^3)))//Timing

NumericQ[Vxyz]

N[Vxyz,20]

(x, z, y) [unevaluated integral]

(Vxzy=((Integrate[Boole[ineq],{x,z,y}∈FullRegion[3]])/((Sqrt[2])^3)))//Timing

(Vxzy=((Integrate[Boole[ineq],{x,-∞,∞},{z,-∞,∞},{y,-∞,∞}])/((Sqrt[2])^3)))//Timing

N[Vxzy,20]

(Vxzysimp=FullSimplify[Vxzy])//Timing

(y, x, z) [unevaluated integral]

(Vyxz=((Integrate[Boole[ineq],{y,x,z}∈FullRegion[3]])/((Sqrt[2])^3)))//Timing

(Vyxz=((Integrate[Boole[ineq],{y,-∞,∞},{x,-∞,∞},{z,-∞,∞}])/((Sqrt[2])^3)))//Timing

NumericQ[Vyxz]

N[Vyxz,20]

(y, z, x) [unevaluated integral]

(Vyzx=((Integrate[Boole[ineq],{y,z,x}∈FullRegion[3]])/((Sqrt[2])^3)))//Timing

(Vyzx=((Integrate[Boole[ineq],{y,-∞,∞},{z,-∞,∞},{x,-∞,∞}])/((Sqrt[2])^3)))//Timing

N[Vyzx,20]

(z, x, y) [unevaluated integral]

(Vzxy=((Integrate[Boole[ineq],{z,x,y}∈FullRegion[3]])/((Sqrt[2])^3)))//Timing

(Vzxy=((Integrate[Boole[ineq],{z,-∞,∞},{x,-∞,∞},{y,-∞,∞}])/((Sqrt[2])^3)))//Timing

NumericQ[Vzxy]

N[Vzxy,20]

(z, y, x) [unevaluated integral]

(Vzyx=((Integrate[Boole[ineq],{z,y,x}∈FullRegion[3]])/((Sqrt[2])^3)))//Timing

(Vzyx=((Integrate[Boole[ineq],{z,-∞,∞},{y,-∞,∞},{x,-∞,∞}])/((Sqrt[2])^3)))//Timing

NumericQ[Vzyx]

N[Vzyx,20]

CAD [unevaluated pieces]

cad=CylindricalDecomposition[ineq,{x,y,z},"Function"]

(Vxyz=((Integrate[Boole[cad],{x,y,z}∈FullRegion[3]])/((Sqrt[2])^3)))//Timing

NumericQ[Vxyz]

(Vxyz=((Integrate[Boole[cad],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞}])/((Sqrt[2])^3)))//Timing

NumericQ[Vxyz]

Transformation to nicer coordinates

NIntegrate[((8(Sqrt[3]))/(1+3(t^2)))-((16(Sqrt[2])(3t+1)(((4(t^2)+t+1))^(3/2)))/((3(t^2)+1)(((11(t^2)+2t+3))^2)))-(((Sqrt[2])(249(t^2)+54t+65))/(((11(t^2)+2t+3))^2)),{t,0,1}]

Spherical Coordinates from center of the tetrahedron

Find r(ϕ)

#.#&[{r Cos[θ]Sin[ϕ],r Sin[θ]Sin[ϕ],r Cos[ϕ]+Sqrt[6]/4}]

FullSimplify[%]

Simplify[Solve[%==1,r]]

Simplify[%/. ϕ->0]

Find ϕ(θ)

eqn=Append[FullSimplify[{(1/8) (4 (Sqrt[2]) z+(Sqrt[6]) (Sqrt[5-4 (Sqrt[6]) z-24 (z^2)])),-(1/3) ((Sqrt[(3/2)]) z-2 (Sqrt[6]) z+((3 (Sqrt[5-4 (Sqrt[6]) z-24 (z^2)]))/(4 (Sqrt[2]))))}],z]

FullSimplify[z/Sqrt[eqn.eqn]]

t->Tan[θ]

t1=FullSimplify[FullSimplify[z/Sqrt[eqn.eqn]]/.z->zt]

t1=(-(Sqrt[3])-6 t-3 (Sqrt[3]) (t^2)+4 (Sqrt[3+19 (t^2)+12 (t^4)+(Sqrt[3]) t (7+11 (t^2))]))/(√((51+22 (Sqrt[3]) t+73 (t^2)-8 (Sqrt[3]) (Sqrt[3+19 (t^2)+12 (t^4)+(Sqrt[3]) t (7+11 (t^2))]))(9+2 (Sqrt[3]) t+11 (t^2))))

FullSimplify[t1]

line[l_List]:=Line[Append[l,l[[1]]]]

24Integrate[r^2 Sin[ϕ],{r,0,(1/4) (-(Sqrt[6]) Cos[ϕ]+(Sqrt[13+3 Cos[2 ϕ]]))}]

NIntegrate[(1/8) (((-(Sqrt[6]) Cos[ϕ]+(Sqrt[13+3 Cos[2 ϕ]])))^3) Sin[ϕ],{θ,0,Pi/3},{ϕ,0,ArcCos[t1 /.t->Tan[θ]]}]//Timing

24NIntegrate[r^2 Sin[ϕ],{θ,0,Pi/3},{ϕ,0,ArcCos[t1]},{r,0,(1/4) (-(Sqrt[6]) Cos[ϕ]+(Sqrt[13+3 Cos[2 ϕ]]))},AccuracyGoal->16]//Timing

By Hand

$Version

Timing[i=Integrate[((8(Sqrt[3]))/(1+3(t^2)))-((16(Sqrt[2])(3t+1)(((4(t^2)+t+1))^(3/2)))/((3(t^2)+1)(((11(t^2)+2t+3))^2)))-(((Sqrt[2])(249(t^2)+54t+65))/(((11(t^2)+2t+3))^2)),{t,0,1}]]//Timing

N[i,20]

LogSimplify[i]

FullSimplify[i]

it=FullSimplify[Integrate[((8(Sqrt[3]))/(1+3(t^2)))-((16(Sqrt[2])(3t+1)(((4(t^2)+t+1))^(3/2)))/((3(t^2)+1)(((11(t^2)+2t+3))^2)))-(((Sqrt[2])(249(t^2)+54t+65))/(((11(t^2)+2t+3))^2)),t],0<t<1]

FullSimplify[Limit[it,t->1]-Limit[it,t->0]]

Curves

eqs=Function[v,v.v][{x,y,z}-#]==1&/@p

Solve[#,{x,y}]&/@Subsets[eqs,{2}]

p

pp[{f_,g_},{z1_,z2_}]:=ParametricPlot3D[{f,g,z},{z,z1,z2},DisplayFunction->Identity,Ticks->None][[1]]

Solve[5+4*Sqrt[6]*z-24*z^2==0,z]

FullSimplify[%]

WriteLiveForm["reultetw.m",Show[Graphics3D[{
t,
PointSize[.05],
Point/@p,
pp[{1/24*(2*Sqrt[3]-Sqrt[6]*Sqrt[17-4*Sqrt[6]*z-24*z^2]),1/8*(2-Sqrt[2]*Sqrt[17-4*Sqrt[6]*z-24*z^2])},{-(1/(2 (Sqrt[6]))),((Sqrt[(3/2)])/2)}],
pp[{1/24*(2*Sqrt[3]-Sqrt[6]*Sqrt[17-4*Sqrt[6]*z-24*z^2]),1/8*(-2+Sqrt[2]*Sqrt[17-4*Sqrt[6]*z-24*z^2])},{-(1/(2*Sqrt[6])),Sqrt[3/2]/2}],
pp[{(1/12) (-2 (Sqrt[3])+(Sqrt[6]) (Sqrt[17-4 (Sqrt[6]) z-24 (z^2)])),0},{-(1/(2 (Sqrt[6]))),((Sqrt[(3/2)])/2)}],
pp[{(Sqrt[2]) z,((-(Sqrt[5+4 (Sqrt[6]) z-24 (z^2)]))/(2 (Sqrt[2])))},{(1/12) (-6+(Sqrt[6])),-(1/(2 (Sqrt[6])))}],
pp[{(Sqrt[2]) z,((Sqrt[5+4 (Sqrt[6]) z-24 (z^2)])/(2 (Sqrt[2])))},{(1/12) (-6+(Sqrt[6])),-(1/(2 (Sqrt[6])))}],
pp[{(1/8) (-4 (Sqrt[2]) z+(Sqrt[6]) (Sqrt[5+4 (Sqrt[6]) z-24 (z^2)])),(1/3) (-(Sqrt[(3/2)]) z+2 (Sqrt[6]) z+((3 (Sqrt[5+4 (Sqrt[6]) z-24 (z^2)]))/(4 (Sqrt[2]))))},{(1/12) (-6+(Sqrt[6])),-(1/(2 (Sqrt[6])))}],
pp[{(1/8) (-4 (Sqrt[2]) z-(Sqrt[6]) (Sqrt[5+4 (Sqrt[6]) z-24 (z^2)])),(1/3) (-(Sqrt[(3/2)]) z+2 (Sqrt[6]) z-((3 (Sqrt[5+4 (Sqrt[6]) z-24 (z^2)]))/(4 (Sqrt[2]))))},{(1/12) (-6+(Sqrt[6])),-(1/(2 (Sqrt[6])))}],
pp[{(1/8) (-4 (Sqrt[2]) z+(Sqrt[6]) (Sqrt[5+4 (Sqrt[6]) z-24 (z^2)])),(1/3) ((Sqrt[(3/2)]) z-2 (Sqrt[6]) z-((3 (Sqrt[5+4 (Sqrt[6]) z-24 (z^2)]))/(4 (Sqrt[2]))))},{(1/12) (-6+(Sqrt[6])),-(1/(2 (Sqrt[6])))}],
pp[{(1/8) (-4 (Sqrt[2]) z-(Sqrt[6]) (Sqrt[5+4 (Sqrt[6]) z-24 (z^2)])),(1/3) ((Sqrt[(3/2)]) z-2 (Sqrt[6]) z+((3 (Sqrt[5+4 (Sqrt[6]) z-24 (z^2)]))/(4 (Sqrt[2]))))},{(1/12) (-6+(Sqrt[6])),-(1/(2 (Sqrt[6])))}]},
PlotRange->All,Boxed->False],ViewPoint->{0,2,2.5}]]

Properties

GeneralizedDiameter

Entity["Solid","ReuleauxTetrahedron"]["GeneralizedDiameter"]

Solid

Entity["Solid","ReuleauxTetrahedron"]["Region"]

({d,soln}=With[{reg=Entity["Solid","ReuleauxTetrahedron"]["Region"][1]},
NMaximize[
{
SquaredEuclideanDistance[{x1,y1,z1},{x2,y2,z2}],
{x1,y1,z1}∈reg&&{x2,y2,z2}∈reg
},
{x1,y1,z1,x2,y2,z2},PrecisionGoal->20,WorkingPrecision->50]])//Timing

N[(7/2)-(Sqrt[6]),20]

FullSimplify[(Sqrt[(7/2)-(Sqrt[6])])]

RootReduce[%]//FullSimplify

Graphics3D[{{Opacity[.5],SolidData["ReuleauxTetrahedron","Graphics3D"][[1]]},PointSize[Large],Point[{{x1,y1,z1},{x2,y2,z2}}/.soln]}]

With[{reg=Entity["Solid","ReuleauxTetrahedron"]["Region"][1]},
Maximize[
{
SquaredEuclideanDistance[{x1,y1,z1},{x2,y2,z2}],
{x1,y1,z1}∈reg&&{x2,y2,z2}∈reg
},
{x1,y1,z1,x2,y2,z2}]]//Timing

Surface

surf=Entity["Solid","ReuleauxTetrahedron"]["Region"][1]/.Ball->Sphere

reg=Region[surf]

With[{p1=Array[p,3],p2=Array[q,3]},Maximize[
{
SquaredEuclideanDistance[p1,p2],
p1∈reg&&p2∈reg
},
Join[p1,p2]]]//Timing

SurfaceArea

Inequalities

ineq=Entity["Solid","ReuleauxTetrahedron"]["Inequalities"][1][x,y,z]

ineq[[1]]

Area

surf=Entity["Solid","ReuleauxTetrahedron"]["Region"][1]/.Ball->Sphere

Area[surf]//Timing

SurfaceArea

With[{reg=Entity["Solid","ReuleauxTetrahedron"]["Region"][1]},SurfaceArea[reg]]//Timing

Volume

With[{reg=Entity["Solid","ReuleauxTetrahedron"]["Region"][1]},Volume[reg]]//Timing