Deltoidal Icositetrahedron

Author

Eric W. Weisstein
January 5, 2024

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Polyhedra/DeltoidalIcositetrahedron.nb.

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

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

Figure

With[{pname="DeltoidalIcositetrahedron"},
GraphicsRow[{
Graphics3D[{Opacity[.8],PolyhedronData[pname,"Polyhedron"]},Boxed->False],
Graphics3D[{PolyhedronData[pname,"Lines"]},Boxed->False],
PolyhedronData[pname,"Net"]
},ImageSize->700]]

Solid

PolyhedronData["DeltoidalIcositetrahedron","Orientations"]

Show[PolyhedronData[{"DeltoidalIcositetrahedron",#}],Boxed->True]&/@PolyhedronData["DeltoidalIcositetrahedron","Orientations"]

Solid and Dual

GraphicsRow[PolyhedronData["DeltoidalIcositetrahedron",#]&/@{"Graphics3D","Dual","DualCompound"}]

Net

PolyhedronData["DeltoidalIcositetrahedron","Net"]

PolyhedronData["DeltoidalIcositetrahedron","Net","Colored"]

NetPrintout[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],"TriakisTetrahedron.pdf"]

Properties

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname="DeltoidalIcositetrahedron","Polyhedron"]

vol=PolyhedronData[pname,"Volume"]

Centroid

PolyhedronData[pname,"Centroid"]

RegionCentroid[p]//FullSimplify

PolyhedronCentroid[p]

Circumsphere

PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

MyCircumsphere[p]

DihedralAngles

PolyhedronData[pname,"DihedralAngles"]//Tally

DihedralAngles[p]//FullSimplify//Tally

N[%[[All,1]]]

Show[Graphics3D[{poly,
MapIndexed[Text[#2[[1]],#1]&,Centroid/@poly//N]
}],Boxed->False]

{4, 4, {3}} in space

Show[Graphics3D[p=poly[[{10,22}]]],Boxed->False]

FullSimplify[π-DihedralAngle@@p]

InputForm[%]

N[%]180/Pi

{4, 4, {4}} in space

Show[Graphics3D[p=poly[[{10,12}]]],Boxed->False]

FullSimplify[π-DihedralAngle@@p]

InputForm[%]

N[%]180/Pi

EdgeLengths

PolyhedronData[pname,"EdgeLengths"]

PolyhedronData[pname,"Lines"]/.Line[l_]:>EuclideanDistance@@l//FullSimplify//Union

Faces

Show[GraphicsArray[partition[PolyhedronFaces[poly],5]]]

Graphics3D@PolyhedronData["DeltoidalIcositetrahedron","Faces","Polygon"][[1]]

EuclideanDistance@@@Partition[PolyhedronData["DeltoidalIcositetrahedron","Faces","Polygon"][[1,1]],2,1,1]//FullSimplify

PolygonAngle[PolyhedronData["DeltoidalIcositetrahedron","Faces","Polygon"][[1]]]//RootReduce//FullSimplify

N[%]

s=2-1/Sqrt[2];
θ=ArcCos[(1/8) (-2-(Sqrt[2]))];
ϕ=ArcCos[(1/4) (2-(Sqrt[2]))];
y=Cos[(1/2)θ]//FullSimplify

x=Sin[(1/2)θ]//FullSimplify

h=s Cos[(1/2)ϕ]//FullSimplify

Graphics[poly=Polygon[{{0,0},{x,-y},{0,-y-h},{-x,-y}}],AspectRatio->Automatic]

PolygonAngle[poly]//FullSimplify

Inequalities

And@@FullSimplify[PolyhedronInequalities[Polyhedron[poly],{#1,#2,#3}]]

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]//RootReduce//FullSimplify//Timing

MyInsphere[p]//FullSimplify//Timing

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

((MomentOfInertia[p])/(Volume[p]))//RootReduce//Timing

PolyhedronInertiaTensor[p]//Timing

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

((NIntegrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p])/vol)

ClosestMeanCylindricalRadius[%]

Integrate over polyhedron

(rxy=((Integrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p])/vol)//FullSimplify)

N[rxy]

Divergence theorem [unevaluated integral]

(rxy=MeanCylindricalRadius[p,"Simplification"->FullSimplify,Debug->True])//Timing

N[rxy]

LogSimplify[rxy]//FullSimplify

CAD

cad=CylindricalDecomposition[PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z},"Function"]

((NIntegrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

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

CAD over  1/16

reg=FullSimplify[PolyhedronData[pname,"RegionFunction"][x,y,z]&&0<y<Tan[Pi/4]x&&z>0]

Show[Graphics3D[{Opacity[.2],p}],RegionPlot3D[ImplicitRegion[reg,{x,y,z}],PlotPoints->50]]

((Volume[ImplicitRegion[reg,{x,y,z}]])/vol)//FullSimplify

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

16((NIntegrate[(Sqrt[(x^2)+(y^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

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

ByteCount[rxy]

N[rxy,10^4]//N

ByteCount[rxylog=LogSimplify[rxy,"ZeroTestNumericalPrecision"->10000,WorkingPrecision->10000,Debug->True]]//Timing

N[rxylog,10^4]//N

ByteCount[rxycollect=Collect[TrigToExp[rxylog],Log[_]]//RootReduce]//Timing

N[rxycollect,20]

rxycollect

FullSimplify[rxycollect]//Expand

MeanInteriorLineSegmentLength

PolyhedronData[pname,"MeanInteriorLineSegmentLength"]

N[%]

GlobalAdaptive numerical integration

ineq=PolyhedronData[pname,"RegionFunction"]

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}=RegionBounds[ImplicitRegion[ineq[x,y,z],{x,y,z}]]

(1/(vol^2)) NIntegrate[Sqrt[(x1-x2)^2+(y1-y2)^2+(z1-z2)^2]Boole[ineq[x1,y1,z1]&&ineq[x2,y2,z2]],
{x1,xmin,xmax},{y1,ymin,ymax},{z1,zmin,zmax},
{x2,xmin,xmax},{y2,ymin,ymax},{z2,zmin,zmax}]

(1/(vol^2)) NIntegrate[Sqrt[(x1-x2)^2+(y1-y2)^2+(z1-z2)^2]Boole[ineq[x1,y1,z1]&&ineq[x2,y2,z2]],
{x1,xmin,xmax},{y1,ymin,ymax},{z1,zmin,zmax},
{x2,xmin,xmax},{y2,ymin,ymax},{z2,zmin,zmax},
Method->{"GlobalAdaptive","MaxErrorIncreases"->1*^4}]//Timing

Integration

ineq=PolyhedronData[pname,"RegionFunction"]

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}=RegionBounds[ImplicitRegion[ineq[x,y,z],{x,y,z}]]

cad=CylindricalDecomposition[ineq[x1,y1,z1]&&ineq[x2,y2,z2],{x1,y1,z1,x2,y2,z2},"Function"]

(1/(vol^2)) Integrate[Sqrt[(x1-x2)^2+(y1-y2)^2+(z1-z2)^2]Boole[cad],
{x1,xmin,xmax},{y1,ymin,ymax},{z1,zmin,zmax},
{x2,xmin,xmax},{y2,ymin,ymax},{z2,zmin,zmax}]

Monte Carlo

reg=PolyhedronData[pname,"Region"]

Length[lines=Partition[RandomPoint[N@reg,10^7],2]]//Timing

Graphics3D[{{Opacity[.2],EdgeForm[],BoundaryDiscretizeRegion[reg]},Red,Line/@Take[lines,UpTo@1000]},AspectRatio->Automatic]

lengths=Norm/@Subtract@@@lines;//Timing

Histogram[lengths,{.01}]

Mean[lengths]

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)]),{x,y,z}∈p])/vol)

ClosestMeanSphericalRadius[%]

Integrate over polyhedron

(rxyz=((Integrate[(Sqrt[(x^2)+(y^2)+(z^2)]),{x,y,z}∈p])/vol))//Timing

N[rxyz]

Divergence theorem

(rxyz=MeanSphericalRadius[p,"Simplification"->FullSimplify,Debug->True])//Timing

N[rxyz]

LogSimplify[rxyz]//FullSimplify

CAD

cad=CylindricalDecomposition[PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z},"Function"]

((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

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

N[rxyz,20]

rxysimp1=ResourceFunction["LogSimplify"][rxy]//FullSimplify

CAD over  1/XX

reg=FullSimplify[PolyhedronData[pname,"RegionFunction"][x,y,z]&&0<y<Tan[Pi/5]x]

((Volume[ImplicitRegion[reg,{x,y,z}]])/vol)//FullSimplify

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

XX((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)])Boole[cad],{x,y,z}∈FullRegion[3]])/vol)

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

ByteCount[rxyzlog=LogSimplify[rxyz,"ZeroTestNumericalPrecision"->10000,WorkingPrecision->10000,Debug->True]]//Timing

ByteCount[rxyzcollect=Collect[TrigToExp[rxyzlog],Log[_]]//RootReduce]//Timing

Boole Integrate doing z integral first

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}=CoordinateBounds[p]

ineq=PolyhedronData[pname,"RegionFunction"][x,y,z]

(i1=Integrate[Boole[ineq](Sqrt[(x^2)+(y^2)+(z^2)]),{z,zmin,zmax}])//Timing

NIntegrate[(i1/vol),{x,xmin,xmax},{y,ymin,ymax}]

(i2=Integrate[(i1/vol),{x,xmin,xmax},{y,ymin,ymax}])//Timing

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

N[%]

((NIntegrate[(x^2)+(y^2),{x,y,z}∈p])/vol)

Integrate over Polyhedron

(rxy2=((Integrate[(x^2)+(y^2),{x,y,z}∈p])/vol)//FullSimplify)

N[rxy2]

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

((NIntegrate[(x^2)+(y^2)+(z^2),{x,y,z}∈p])/vol)

Integrate over polyhedron

(rxy2=((Integrate[(x^2)+(y^2)+(z^2),{x,y,z}∈p])/vol)//FullSimplify)

N[rxy2]

Midsphere

PolyhedronData[pname,"Midsphere"]

Midsphere[p]//FullSimplify//Timing

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

{RegionPlot3D[ImplicitRegion[PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z}],PlotPoints->60],
Graphics3D[p]}

Collect[#,{x,y,z},RootReduce]&/@PolyhedronInequalities[p,{x,y,z}]

ineq=FullSimplify[%]

ineq/.{x->#,y->#2,z->#3}

{Region@ImplicitRegion[ineq,{x,y,z}],Graphics3D[p]}

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

gn=PolyhedronData[pname,"Skeleton","Name"]

emb=GraphData[gn,"PolyhedralEmbeddings"]

GraphData[gn,"Graph",{"3D","All"}]

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

RootReduce[%]

SurfaceArea[p]//RootReduce//Timing

Total[Area/@PolyhedronData[pname,"Polygons"]]//RootReduce//Timing

VertexSubsetHulls

Platonic

(h=VertexSubsetHulls[p,"Platonic","Skip"->{}])//Timing

g=Function[poly,Graphics3D[{
{Gray,Opacity[.2],EdgeForm[Thick],PolyhedronData[p,"Faces"]},ConvexHull3D[N[PolyhedronData[p,"VertexCoordinates"]][[#]]]&/@poly},Boxed->False]]/@h[[All,2]]

g2=Graphics3D[{
{Gray,Opacity[.2],PolyhedronData[p,"Faces"]},
h2=ConvexHull3D[v[[#]]]&/@i2
},Boxed->False]

Graphics3D[ConvexHull3D[v[[#]]]&/@hull2,Boxed->False,ImageSize->250,Method->{"ShrinkWrap"->True}]

Graphics3D[Dual[ConvexHull3D[v[[#]]]]&/@hull2,Boxed->False,ImageSize->250,Method->{"ShrinkWrap"->True}]

Graphics3D[ConvexHull3D[v[[#]]]&/@Join[i1,i2,i3],Boxed->False]

Volume

PolyhedronData[pname,"Volume"]

Volume[p]//FullSimplify

PolyhedronVolume[p,Method->"GaussLaw"]//FullSimplify

Volume[ImplicitRegion[PolyhedronData[pname,"RegionFunction"][x,y,z],{x,y,z}]]//FullSimplify//Timing

Perspective projections

Manipulate[PolyhedronProjectionGraph[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],{a,b,c}],{a,-1,1},{b,-1,1},{c,-1,1}]

{1,(1/17) (6+(Sqrt[2])),1,-ArcTan[(Sqrt[(5/82)+(3/(82 (Sqrt[2])))])]}

g=PolyhedronProjectionGraph[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],{1,(1/17) (6+(Sqrt[2])),1,-ArcTan[(Sqrt[(5/82)+(3/(82 (Sqrt[2])))])]},VertexLabels->"Name"]

v=GraphEmbedding[g];

ArcTan@@(v[[3]]-v[[14]])//FullSimplify

g=PolyhedronProjectionGraph[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],{1,z,1},VertexLabels->"Name"]

v=GraphEmbedding[g];

FullSimplify[v[[2]]-v[[19]],z>0]

Solve[Thread[%==0],z]//FullSimplify

{1,1+(Sqrt[2]),0}

g=PolyhedronProjectionGraph[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],{1,1+(Sqrt[2]),0},VertexLabels->"Name"]

g=PolyhedronProjectionGraph[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],{1,z,0},VertexLabels->"Name"]

v=GraphEmbedding[g];

FullSimplify[v[[1]]-v[[12]],z>0]

Solve[Thread[%==0],z]//FullSimplify

{1,2,1,-ArcTan[(Sqrt[(2/3)])]}

g=PolyhedronProjectionGraph[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],{1,2,1,-ArcTan[(Sqrt[(2/3)])]},VertexLabels->"Name"]

v=GraphEmbedding[g];

ArcTan@@(v[[1]]-v[[5]])//FullSimplify

g=PolyhedronProjectionGraph[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],{1,z,1},VertexLabels->"Name"]

v=GraphEmbedding[g];

FullSimplify[v[[1]]-v[[10]],z>0]

Solve[Thread[%==0],z]//FullSimplify

{1,2(Sqrt[2]),1,-ArcTan[(2/(Sqrt[5]))]}

{-.105,.305,-.105}/.105

g=PolyhedronProjectionGraph[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],{1,2(Sqrt[2]),1,-ArcTan[(2/(Sqrt[5]))]},VertexLabels->"Name"]

v=GraphEmbedding[g];

ArcTan@@(v[[1]]-v[[5]])//FullSimplify

g=PolyhedronProjectionGraph[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],{1,z,1},VertexLabels->"Name"]

v=GraphEmbedding[g];

eqn=FullSimplify[v[[11]]-v[[19]],z>0]

Solve[Thread[eqn==0],z]//FullSimplify

{0,1,0}

PolyhedronProjectionGraph[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],{0,1,0}]

{1,1,1}

PolyhedronProjectionGraph[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],{1,1,1}]

{1,1,0}

PolyhedronProjectionGraph[PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],{1,1,0}]

Construction

DeltoidalIcositetrahedronExact:=OrientCentered[Dual[Polyhedron[SmallRhombicuboctahedron],Method->Semiregular]]

Net construction

{a,b}=PolyhedronData["DeltoidalIcositetrahedron","EdgeLengths"]

N[%]

v=PolyhedronData["DeltoidalIcositetrahedron","VertexCoordinates"];

Graphics3D[{PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]

PolygonAngle[Polygon[v[[{15,8,6,21}]]]]//RootReduce//FullSimplify//Quiet

θ=ArcCos[(1/8) (-2-(Sqrt[2]))];
ϕ=ArcCos[(1/4) (2-(Sqrt[2]))];

{θ,ϕ}//N

poly=With[{x=((Sqrt[10+(Sqrt[2])])/4),y=((Sqrt[6-(Sqrt[2])])/4),h=(1/4) (Sqrt[62-33 (Sqrt[2])])},{{0,0},{x,-y},{0,-y-h},{-x,-y}}]

Graphics[{FaceForm[LightYellow],EdgeForm[Black],Polygon[poly]}]

v={{0,0},{0,-b}};
v=Join[v,{RotationMatrix[-ϕ].v[[2]],v[[2]]+RotationMatrix[ϕ].(v[[1]]-v[[2]])/b}];
v=Join[v,{v[[4]]+RotationMatrix[θ].(v[[3]]-v[[4]]),v[[3]]+RotationMatrix[-ϕ].(v[[4]]-v[[3]])b}];
v=Join[v,Table[v[[6]]+RotationMatrix[-i ϕ].(v[[3]]-v[[6]]),{i,2,4}],Table[v[[6]]+RotationMatrix[-i ϕ].(v[[4]]-v[[6]]),{i,3}]];
v=Join[v,{v[[4]]+RotationMatrix[θ].(v[[5]]-v[[4]]),v[[5]]+RotationMatrix[-ϕ].(v[[4]]-v[[5]])b}];
v=Join[v,{v[[10]]+RotationMatrix[-θ].(v[[5]]-v[[10]])}];
v=Join[v,{v[[15]]+RotationMatrix[-ϕ].(v[[10]]-v[[15]])b}];
v=Join[v,{v[[10]]+RotationMatrix[θ].(v[[7]]-v[[10]]),v[[7]]+RotationMatrix[-ϕ].(v[[10]]-v[[7]])b}];
v=Join[v,{v[[7]]+RotationMatrix[ϕ].(v[[11]]-v[[7]])b,v[[11]]+RotationMatrix[-θ].(v[[7]]-v[[11]])}];
v=Join[v,{v[[11]]+RotationMatrix[θ].(v[[8]]-v[[11]]),v[[8]]+RotationMatrix[-ϕ].(v[[11]]-v[[8]])b}];
v=Join[v,{v[[8]]+RotationMatrix[ϕ].(v[[12]]-v[[8]])b,v[[12]]+RotationMatrix[-θ].(v[[8]]-v[[12]])}];
v=Join[v,{v[[12]]+RotationMatrix[θ].(v[[9]]-v[[12]]),v[[9]]+RotationMatrix[-ϕ].(v[[12]]-v[[9]])b}];
v=Join[v,{-#,#2}&@@@Drop[v,2]];
faces={{1,3,4,2},{3,6,5,4},{6,9,12,8},{6,8,11,7},{6,7,10,5},{4,5,14,13},{5,10,15,16},{7,18,17,10},{11,20,19,7},{8,22,21,11},{24,23,8,12},{26,25,12,9}};
faces=Join[faces,{{27,1,2,28}},Reverse/@Rest[faces]+24];
Graphics[{FaceForm[LightYellow],EdgeForm[Black],poly=Polygon[v,faces],MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]

<<MathWorld`Graphs`

<<MathWorld`Polyhedra`

Total[Area[Polygon[v,#]]&/@faces]//ToAlgebraicRoot//FullSimplify

PolyhedronData["DeltoidalIcositetrahedron","SurfaceArea"]

faces=Sort[faces]

v1=FullSimplify@Map[ToAlgebraicRoot,v,{2}]

Total[Area[Polygon[v1,#]]&/@faces]//ToAlgebraicRoot//FullSimplify

net=GraphicsComplex[v1,Polygon[faces]];

SimplifyNumericallyDistinct[NetEdgeLengths[net]//Quiet,"Simplification"->FullSimplify]//Union