Triakis Tetrahedron Stellations

Author

Eric W. Weisstein
November 13, 2024

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

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

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

Diagram

Construction

pname="TriakisTetrahedron";

PolyhedronData[pname,"Orientations"]

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

faces=Take[#,3]&/@PolyhedronData[pname,"Polygons"][[All,1]];

Graphics3D[{{Red,PolyhedronData[pname,"Polyhedron"]},Opacity[.4],DiscretizeRegion[BooleanRegion[And,{Ball[{0,0,0},9],Fold[RegionUnion,EmptyRegion[3],InfinitePlane/@faces]}],MeshCellStyle->1->None]},Boxed->False]

Length[lines3D=
DeleteCases[
With[{planeindx=1},
RegionIntersection[InfinitePlane[faces[[planeindx]]],InfinitePlane[#]]&/@Drop[faces,{planeindx}]],
_EmptyRegion
]//RootReduce//FullSimplify]//Timing

Graphics3D[{Red,#},PlotRange->15]&/@lines3D

Show[%]

Binomial[Length@lines3D,2]

indx=Subsets[Range@Length@lines3D,{2}];
Length[intersections3D=Cases[{#,FullSimplify@RootReduce[RegionIntersection@@lines3D[[#]]]}&/@indx,{i_,Point[p_]}:>{i,p}]]//Timing

Length[pts3D=intersections3D[[All,2]]//Union]

radius=Max[Norm[Most[#]]&/@pts3D]//FullSimplify//Quiet

N[%]

Equal@@(#[[-1]]&/@pts3D)

indexedintersections=intersections3D/.Thread[pts3D->Range[Length[pts3D]]]

clines=Table[Union@Select[indexedintersections,MemberQ[#[[1]],i]&][[All,-1]],{i,Length[lines3D]}]

longestlines=OrderedPointsOnLineSegment[pts3D,#]&/@clines

Graphics3D[{
Thickness[.005],lines3D,
{Darker@Green,MapIndexed[Text[#2[[1]],Mean[pts3D[[#[[{1,-1}]]]]],Background->White]&,longestlines]},
{Red,Sphere[pts3D,.3]}
},
PlotRange->7,ImageSize->Medium,ViewPoint->{0,0,2}
]

norm=(Sqrt[11])Normalize[Cross[pts3D[[1]]-pts3D[[2]],pts3D[[3]]-pts3D[[2]]]]

v3D=RotationMatrix[{norm,{0,0,1}}].#&/@pts3D//FullSimplify

Equal@@v3D[[All,-1]]

v0=Most/@v3D

ArcTan@@v0[[15]]//FullSimplify

v=RotationMatrix[Pi/2+ArcCot[(Sqrt[11])]].#&/@v0//FullSimplify

Max[Norm/@v]//FullSimplify//Quiet

N[%]

Figure

PolyhedronData["TriakisTetrahedron","Orientations"]

PolyhedronData[{"TriakisTetrahedron",#}]&/@PolyhedronData["TriakisTetrahedron","Orientations"]

Labels

Clear[text]

text[text_,indx_,style___]:=Module[{p=Mean[v[[indx]]]},
Style[If[p=={0.,0.},Text[text,p],Table[Text[text,RotationMatrix[2Pi i/4].p],{i,0,3}]],Directive[style]]]

Graphics[
{
Line[v[[#]]]&/@longestlines[[All,{-1,1}]],
{Darker@Green,MapIndexed[Text[#2[[1]],Mean[v[[#]]],Background->White]&,longestlines]},
{Red,PointSize[.015],Point[v]},
Blue,MapIndexed[Text[#2[[1]],#,{0,-1.3},Background->White]&,v]
},BaseStyle->Directive[FontFamily->"Times",16,Bold]]

Graphics[
{
Line[v[[#]]]&/@longestlines[[All,{-1,1}]],
{Red,PointSize[.015],Point[v]}
},
BaseStyle->Directive[FontFamily->"Times",16,Bold]]