Tetrahedron 5-Compound

Author

Eric W. Weisstein
September 29, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Polyhedra/Tetrahedron5-Compound.nb.

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

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

Stellation variants

variants={"TetrahedronFiveCompound",{"IcosahedronStellation",36}};

PolyhedronData/@variants

PolyhedronData[#,"FaceCount"]&/@variants

Length[PolyhedronData[#,"Polyhedra"]]&/@variants

Variants

<<MathWorld`Polyhedra`

variants=PolyhedronData["TetrahedronFiveCompound*"]

PolyhedronData[#,"FaceCount"]&/@variants

Length[PolyhedronData[#,"Polyhedra"]]&/@variants

Polyhedra

GraphicsGrid[Transpose[{
Graphics3D[{PolyhedronData[#,"Polyhedron"]},Boxed->False],
With[{poly=PolyhedronData[#,"Polyhedra"]},Graphics3D[Table[{Hue[(i/(Length[poly]))],poly[[i]]},{i,Length[poly]}],Boxed->False]]
}&/@variants],Dividers->All,ImageSize->500]

Solids and duals

GraphicsGrid[
Table[
With[
{
s={Yellow,PolyhedronData[pname,"Midsphere"]},
dname=PolyhedronData[pname,"Dual","Name"],
style=Directive[Black,Italic,FontFamily->"Times",14]
},
{
Graphics3D[{s,Green,Opacity[.5],PolyhedronData[pname,"Polyhedron"]},Boxed->False,PlotLabel->TextCell[Style[PolyhedronData[pname,"Name"],style],PageWidth->200,TextAlignment->Center]],

Graphics3D[{s,Red,Opacity[.5],PolyhedronData[pname,"Dual","Polyhedron"]},Boxed->False,PlotLabel->Style[PolyhedronData[dname,"Name"],style]],

Graphics3D[{
{Green,Opacity[.5],PolyhedronData[pname,"Polyhedron"]},
{Red,Opacity[.5],PolyhedronData[pname,"Dual","Polyhedron"]},
s
},Boxed->False,PlotLabel->Style["compound with midsphere",style]],

Graphics3D[{
PolyhedronData[pname,"Polyhedron"],
PolyhedronData[pname,"Dual","Polyhedron"]
},Boxed->False,PlotLabel->Style["compound",style]]
}],
{pname,variants}
],
Dividers->All,ImageSize->800,Alignment->Top
]

Interior and convex hull

GraphicsGrid[
With[{style=Directive[Black,Italic,FontFamily->"Times",16]},
Table[{
Graphics3D[PolyhedronData[pname,"Polyhedron"],PlotLabel->TextCell[Style[PolyhedronData[pname,"Name"],style],PageWidth->200,TextAlignment->Center],Boxed->False],
Graphics3D[{AbsoluteThickness[.5],PolyhedronData[pname,"Lines"],Opacity[.8],PolyhedronData[pname,"CompoundInterior","Polyhedron"]},PlotLabel->Style["interior",style],Boxed->False],
Graphics3D[{
{EdgeForm[None],PolyhedronData[pname,"Polyhedron"]},
{Opacity[.7],EdgeForm[Thickness[.005]],PolyhedronData[pname,"ConvexHull","Polyhedron"]}},PlotLabel->Style["convex hull",style],Boxed->False]
},
{pname,variants}]
],
Dividers->All,ImageSize->700]

TextGrid[
Prepend[
Table[{
pname,
RecognizeGraph@PolyhedronGraph@PolyhedronData[pname,"CompoundInterior","Polyhedron"],
RecognizeGraph@PolyhedronGraph@PolyhedronData[pname,"ConvexHull","Polyhedron"]
},
{pname,variants}],
Thread[Style[{"compound","interior","convex hull"},Bold]]],
Dividers->All]

Polyhedron: {"TetrahedronFiveCompound", 1}

Orientations

PolyhedronData["TetrahedronFiveCompound","Orientations"]

PolyhedronData["TetrahedronFiveCompound"]

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

Mirror image compound

Show[PolyhedronData[{"TetrahedronFiveCompound",#}],Boxed->False]&/@{"Dextro","Laevo"}

Show[%]

Polyhedron

Graphics3D[{Opacity[.3],PolyhedronData["TetrahedronFiveCompound","Polyhedron"]}]

Face orientation

Graphics3D[{FaceForm[Green,Red],PolyhedronData["TetrahedronFiveCompound","Polyhedron"]}]

Region

PolyhedronData["TetrahedronFiveCompound","Region"]

Solid and dual

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

Graphics3D[{Opacity[.6],
Red,PolyhedronData["TetrahedronFiveCompound","Polyhedron"],
Green,PolyhedronData["TetrahedronFiveCompound","Dual","Polyhedron"],
Yellow,PolyhedronData["TetrahedronFiveCompound","Midsphere"]},Boxed->False]

Dextro

PolyhedronData[{"TetrahedronFiveCompound","Dextro"},#]&/@{"Graphics3D","Dual","DualCompound"}

Show[Most@%]

Laevo

PolyhedronData[{"TetrahedronFiveCompound","Laevo"},#]&/@{"Graphics3D","Dual","DualCompound"}

Show[Most@%]

Properties: {"TetrahedronFiveCompound", 1}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"TetrahedronFiveCompound",1},"Polyhedron"]

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

Beveled

Wireframe (V2 poster)

From Scott Kim for V2 poster:

Off[General::spell1];
Needs["Graphics`Polyhedra`"]
vertices = Vertices[Dodecahedron];
Triangles[{f1_,f2_,f3_,f4_}] := 
   {{f1, f2, f3},
	{f1, f3, f4},
	{f1, f4, f2},
	{f4, f3, f2}}
tetrapoints = {{1, 9, 12, 20}, {2, 10, 13, 16},
         {3, 6, 14, 17}, {4, 7, 15, 18}, {5, 8, 11, 19}};
poly = 
 (vertices[[#]]&) /@ Flatten[ Triangles /@ tetrapoints, 1];
linearcombination[r_, a_, b_] := (1-r)*a + (r)*b
HollowTriangle[t_] :=
	Block[{a=t[[1]], b=t[[2]], c=t[[3]], aa, bb, cc},
		aa = linearcombination[1/8, a, (b+c)/2];
		bb = linearcombination[1/8, b, (c+a)/2];
		cc = linearcombination[1/8, c, (a+b)/2];
		{{a,b,bb,aa}, {b,c,cc,bb}, {c,a,aa,cc}} ]
On[General::spell1]
tetrapict =
 Show[Graphics3D[ Polygon /@ 
              Flatten[ HollowTriangle /@ poly , 1]], 
              ViewVertical -> {.52, .38, .85}, Boxed -> False]

Cylinders

Graphics3D[{Thickness[.02],PolyhedronData["TetrahedronFiveCompound","Lines"]/.Line[x_]:>Cylinder[x,.02]},Boxed->False]

Beveled

Graphics3D[Bevel[PolyhedronData["TetrahedronFiveCompound","Polygons"],.05],Boxed->False]

Graphics3D[Bevel[PolyhedronData["CubeFiveCompound","Polygons"]//N,.05],Boxed->False]

Centroid

PolyhedronData[pname,"Centroid"]

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

sphere=Circumsphere[p]

(sphere=MyCircumsphere[p])//Timing

Graphics3D[{{Opacity[.2],Yellow,sphere},p},Boxed->False]

Classes

PolyhedronData[pname,"Classes"]

Compound

PolyhedronData[pname,"Compound"]

CompoundInterior

intname=PolyhedronData[pname,"CompoundInterior","Name"]

PolyhedronData[pname,"CompoundInterior","Scale"]

PolyhedronData[pname,"CompoundInterior","RotationMatrix"]

PolyhedronData[pname,"CompoundInterior"]

Graphics3D[{
AbsoluteThickness[1],PolyhedronData[pname,"Lines"],
Opacity[.8],interior=PolyhedronData[pname,"CompoundInterior","Polyhedron"]},Boxed->False]

Graphics3D[{{Opacity[.2],p},Red,interior},Boxed->False]

MyCircumsphere[interior]//Quiet

Insphere[interior]//Quiet

Midsphere[interior]

Construction

int=RegionIntersection[Sequence@@PolyhedronData[pname,"Polyhedra"],PerformanceGoal->"Quality"]

Graphics3D[int]

Graphics3D[{{Opacity[.2],p},Red,int},Boxed->False]

Union[Chop@int[[1]]]//Length

Exactify

vexact=DeleteDuplicates[RootApproximant[Chop[int[[1]]]]]

Length[vexact]

inthull=ConvexHullRegion[Union@vexact]

v=inthull[[1]]//ToRadicals

faces=inthull[[2]]

gname=RecognizeGraph@PolyhedronGraph[inthull]

GraphData[gname,"PolyhedralEmbeddings"]

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[inthull]]//Counts//Quiet

Find rotation matrix

intname

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[intname,"Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,basev=basesolid[[1]]]}]

s=(1/2) (Sqrt[7-3 (Sqrt[5])]);

Graphics3D[{{{Opacity[.2],LabelPolyhedron[p,Background->LightGreen]}},
Red,LabelPolyhedron@Polyhedron[s basesolid[[1]],basesolid[[2]]]},Boxed->False]

rot=RotationMatrix[Pi/5,{0,0,1}]

Graphics3D[{{Opacity[.2],LabelPolyhedron[p,Background->LightGreen]},
Red,LabelPolyhedron@Polyhedron[newv2=s rot.#&/@basesolid[[1]],basesolid[[2]]]},Boxed->False]

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]//Timing

ConvexHull

convexhullname=PolyhedronData[pname,"ConvexHull","Name"]

PolyhedronData[pname,"ConvexHull","Scale"]

PolyhedronData[pname,"ConvexHull","RotationMatrix"]

Graphics3D[convexhull=PolyhedronData[pname,"ConvexHull","Polyhedron"]]

{
Graphics3D[{Red,Opacity[.5],p}],
Graphics3D[{Blue,Opacity[.5],convexhull}]
}

Show[%]

Construct using ConvexHullRegion

Graphics3D[convexhullreg=ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]

v=PolyhedronCoordinates[convexhullreg]

Sort[(convexhullreg[[2]]/.i_Integer:>v[[i]])/.Thread[PolyhedronData[pname,"Vertices"]->Range[PolyhedronData[pname,"V"]]]]

Find scale

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhullreg]]//Tally//FullSimplify

((Max[Norm/@p[[1]]])/(Max[Norm/@PolyhedronData[convexhullname,"Polyhedron"][[1]]]))//FullSimplify//Quiet

FullSimplify[(1/(Sqrt[3+(Sqrt[5])]))-((Sqrt[3-(Sqrt[5])])/2)]

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[convexhullname,"Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,basev=basesolid[[1]]]}]

rot=RotationMatrix[{Mean[basev[[{11,12}]]],{0,0,1}}]//FullSimplify

{Graphics3D[{Polyhedron[newv=rot.#&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ArcTan@@(Most@Mean[newv[[{7,29}]]])//FullSimplify

rot2=RotationMatrix[Pi/2+2Pi/5,{0,0,1}].rot//FullSimplify

{Graphics3D[{Polyhedron[(rot2.#)&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ConvexHullOf

hullof=DeleteCases[Select[PolyhedronData[All],PolyhedronData[#,"ConvexHullName"]===pname&],pname]

DehnInvariant

PolyhedronData[pname,"DehnInvariant"]

(dehn=DehnInvariant[p,Debug->True]//FullSimplify)//Timing

ToConwayBasis[dehn]

Complement[Select[PolyhedronData[All],PolyhedronData[#,"DehnInvariant"]==dehn&&PolyhedronData[#,"Volume"]==vol&],{pname}]

DihedralAngles

(dih1=PolyhedronData[pname,"DihedralAngles"])//Tally

(dih2=SimplifyNumericallyDistinct[DihedralAngles[p]])//Tally

dih1===dih2

Dual

pname

dname=PolyhedronData[pname,"Dual","Name"]

PolyhedronData[pname,"Dual","Scale"]

midrs={PolyhedronData[pname,"Midradius"],PolyhedronData[dname,"Midradius"]}

Divide@@midrs//FullSimplify

GraphicsRow[With[{
s={Yellow,PolyhedronData[pname,"Midsphere"]},
style=Directive[Black,Italic,FontFamily->"Times",14]
},
{
Graphics3D[{s,Green,Opacity[.5],PolyhedronData[pname,"Polyhedron"]},Boxed->False,PlotLabel->TextCell[Style[PolyhedronData[pname,"Name"],style],PageWidth->200,TextAlignment->Center]],
Graphics3D[{s,Red,Opacity[.5],PolyhedronData[pname,"Dual","Polyhedron"]},Boxed->False,PlotLabel->Style[PolyhedronData[dname,"Name"],style]],
Graphics3D[{
{Green,Opacity[.5],PolyhedronData[pname,"Polyhedron"]},
{Red,Opacity[.5],PolyhedronData[pname,"Dual","Polyhedron"]},
s
},Boxed->False,PlotLabel->Style["compound with midsphere",style]],
Graphics3D[{
PolyhedronData[pname,"Polyhedron"],
PolyhedronData[pname,"Dual","Polyhedron"]
},Boxed->False,PlotLabel->Style["compound",style]]
}],Alignment->Top,ImageSize->800]

EdgeCount

PolyhedronData[pname,"EdgeCount"]

EdgeLengths

Tally[lens=SimplifyNumericallyDistinct[PolyhedronEdgeLengths[p],"Simplification"->RootReduce]//FullSimplify]//Timing

PolyhedronData[pname,"EdgeLengths"]

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

(distinctlens=Mean/@Split[Sort[lens],Abs[#1-#2]<1.*^-10&])//N//Quiet

v=p[[1]];

colors=With[{n=Length[distinctlens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[distinctlens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[p],Boxed->False]//Quiet

FaceCount

PolyhedronData[pname,"FaceCount"]

GeneralizedDiameter

PolyhedronData[pname,"GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify//Quiet

Hull

hullname=PolyhedronData[pname,"Hull","Name"]

PolyhedronData[pname,"Hull","Scale"]

((Max[Norm/@p[[1]]])/(Max[Norm/@PolyhedronData[hullname,"Polyhedron"][[1]]]))//FullSimplify//Quiet

PolyhedronData[pname,"Hull"]

Max[Norm/@PolyhedronData[pname,"Hull","Polyhedron"][[1]]]

Max[Norm/@p[[1]]]

{Graphics3D[{Opacity[.5],Red,p}],Graphics3D[{Opacity[.5],Blue,PolyhedronData[pname,"Hull"][[1]]}]}

Show[%]

HullOf

Select[PolyhedronData[All],PolyhedronData[#,"HullName"]===pname&]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

Graphics3D[{{Opacity[.5],p},{Red,sphere}},Boxed->False]

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

Midsphere[p//N]

(sphere=Midsphere[p])//Timing

(sphere=Midsphere[p,Method->"PointLineDistance"])//Timing

Graphics3D[{{Opacity[.5],Yellow,p},{Red,sphere}},Boxed->False]

Net

PolyhedronData[pname,"Net"]

NotationRules

PolyhedronData[pname,"NotationRules"]

Orientations

PolyhedronData[pname,"Orientations"]

PolyhedronData[pname,"DefaultOrientation"]

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

Polygons

PolyhedronData[pname,"FaceCount"]

PolyhedronFaceTally[p]

Graphics3D/@PolyhedronData[pname,"Polygons"]

Show[%]

Polyhedra

PolyhedronData[pname,"Polyhedra"]

Graphics3D[%]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]

Skeleton

PolyhedronData[pname,"Skeleton"]

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

GraphData[gn]

emb=GraphData[gn,"PolyhedralEmbeddings"]

pname

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

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

Total[Area/@PolyhedronData[pname,"Polygons"]]//ToAlgebraicRoot

SurfaceArea[PolyhedronData[pname,"Region"]]

Uniform

PolyhedronData[pname,"Uniform"]

VertexCount

PolyhedronData[pname,"VertexCount"]

VertexSubsetHulls

subsethulls=PolyhedronData[pname,"VertexSubsetHulls"]

v=PolyhedronData[pname,"Vertices"];

Rule[#,Length[#2]]&@@@subsethulls

Rule[#,Graphics3D[Function[f,ConvexHullRegion[v[[f]]]]/@#2]]&@@@subsethulls

subsethulls2=Flatten[Function[{pn,l},Rule[pn,#]&/@l]@@@subsethulls]

Rule[#,Graphics3D[{{Opacity[.3],{Green,p}},Blue,ConvexHullRegion[v[[#2]]]}]]&@@@subsethulls2

Convex hull

Graphics3D[convexhullreg=ConvexHullRegion[v=PolyhedronData[pname,"Vertices"]]]

v=PolyhedronCoordinates[convexhullreg]

Flatten[(convexhullreg[[2]]/.i_Integer:>v[[i]])/.Thread[PolyhedronData[pname,"Vertices"]->Range[PolyhedronData[pname,"V"]]]]//Union

%===Range@Length@v

PolyhedronData[pname,"ConvexHull","Name"]

Platonic

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

Volume

PolyhedronData[pname,"Volume"]

Volume[p]//FullSimplify

PolyhedronVolume[p]//FullSimplify

Volume[PolyhedronData[pname,"Region"]]//FullSimplify

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

WythoffSymbol

PolyhedronData[pname,"WythoffSymbol"]

Properties: {"TetrahedronFiveCompound", 2}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"TetrahedronFiveCompound",2},"Polyhedron"]

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

Centroid

PolyhedronData[pname,"Centroid"]

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

sphere=Circumsphere[p]

(sphere=MyCircumsphere[p])//Timing

Graphics3D[{{Opacity[.2],Yellow,sphere},p},Boxed->False]

Classes

PolyhedronData[pname,"Classes"]

Compound

PolyhedronData[pname,"Compound"]

CompoundInterior

intname=PolyhedronData[pname,"CompoundInterior","Name"]

PolyhedronData[pname,"CompoundInterior","Scale"]

PolyhedronData[pname,"CompoundInterior","RotationMatrix"]

PolyhedronData[pname,"CompoundInterior"]

Graphics3D[{
AbsoluteThickness[1],PolyhedronData[pname,"Lines"],
Opacity[.8],interior=PolyhedronData[pname,"CompoundInterior","Polyhedron"]},Boxed->False]

MyCircumsphere[interior]//Quiet

Insphere[interior]//Quiet

Midsphere[interior]

Construction

int=RegionIntersection[Sequence@@PolyhedronData[pname,"Polyhedra"],PerformanceGoal->"Quality"]

Graphics3D[int]

Graphics3D[{{Opacity[.2],p},Red,int},Boxed->False]

Union[Chop@int[[1]]]//Length

Exactify

vexact=DeleteDuplicates[RootApproximant[Chop[int[[1]]]]]

Length[vexact]

inthull=ConvexHullRegion[Union@vexact]

v=inthull[[1]]//ToRadicals

faces=inthull[[2]]

gname=RecognizeGraph@PolyhedronGraph[inthull]

GraphData[gname,"PolyhedralEmbeddings"]

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[inthull]]//Counts//Quiet

Numerically group

Union[Chop@int[[1]]]//Length

Length[grouped=SplitBy[SortBy[{#,Round[1*^12#]}&/@Chop[int[[1]]],Last],Last][[All,All,1]]]

Max[EuclideanDistance@@@Flatten[Subsets[#,{2}]&/@grouped,1]]

grouped//Column

rules=Flatten[Function[l,Rule[#,Mean[l]]&/@l]/@grouped,1];

newi=ConvexHullRegion[DeleteDuplicates[Chop[int[[1]]]/.rules]]

Graphics3D[LabelPolyhedron@newi]

Midsphere[newi]

RecognizeGraph@PolyhedronGraph@newi

lengths=PolyhedronEdgeLengths[newi]

Divide@@MinMax[%lengths]

Round[10^12lengths]/10^12.//Counts

PolyhedronData["PentakisDodecahedron","EdgeLengths"]

Divide@@%//N

RootReduce[PolyhedronEdgeLengths[PolyhedronData["PentakisDodecahedron","Polyhedron"]]]//Counts

newi[[1]]

newi[[2]]

RootApproximant[((newi[[1]])/(Max[PolyhedronEdgeLengths[newi]])),4]

Graphics3D[{
AbsoluteThickness[1],PolyhedronData[pname,"Lines"],
Opacity[.8],newi},Boxed->False]

Find scale

intname=XXX;

PolyhedronData/@{pname,intname}

xyratio=((Max[Norm/@vexact[[All,;;2]]])/(Max[Norm/@PolyhedronData[intname,"VertexCoordinates"][[All,;;2]]]))//RootReduce//FullSimplify//Quiet

zratio=((Max[vexact[[All,3]]])/(Max[PolyhedronData[intname,"VertexCoordinates"][[All,3]]]))//RootReduce//FullSimplify

{xyratio,xyratio,zratio}

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]//Timing

ConvexHull

convexhullname=PolyhedronData[pname,"ConvexHull","Name"]

PolyhedronData[pname,"ConvexHull","Scale"]

PolyhedronData[pname,"ConvexHull","RotationMatrix"]

Graphics3D[convexhull=PolyhedronData[pname,"ConvexHull","Polyhedron"]]

{
Graphics3D[{Red,Opacity[.5],p}],
Graphics3D[{Blue,Opacity[.5],convexhull}]
}

Show[%]

Construct using ConvexHullRegion

Graphics3D[convexhullreg=ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]

v=PolyhedronCoordinates[convexhullreg]

Sort[(convexhullreg[[2]]/.i_Integer:>v[[i]])/.Thread[PolyhedronData[pname,"Vertices"]->Range[PolyhedronData[pname,"V"]]]]

Find scale

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhullreg]]//Tally//FullSimplify

((Max[Norm/@p[[1]]])/(Max[Norm/@PolyhedronData[convexhullname,"Polyhedron"][[1]]]))//FullSimplify//Quiet

FullSimplify[(1/(Sqrt[3+(Sqrt[5])]))-((Sqrt[3-(Sqrt[5])])/2)]

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[convexhullname,"Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,basev=basesolid[[1]]]}]

rot=RotationMatrix[{Mean[basev[[{11,12}]]],{0,0,1}}]//FullSimplify

{Graphics3D[{Polyhedron[newv=rot.#&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ArcTan@@(Most@Mean[newv[[{7,29}]]])//FullSimplify

rot2=RotationMatrix[Pi/2+2Pi/5,{0,0,1}].rot//FullSimplify

{Graphics3D[{Polyhedron[(rot2.#)&/@basesolid[[1]],basesolid[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,basesolid[[1]]]}],
Graphics3D[ConvexHullRegion[PolyhedronData[pname,"Vertices"]]]}

ConvexHullOf

hullof=DeleteCases[Select[PolyhedronData[All],PolyhedronData[#,"ConvexHullName"]===pname&],pname]

DehnInvariant

PolyhedronData[pname,"DehnInvariant"]

(dehn=DehnInvariant[p,Debug->True]//FullSimplify)//Timing

ToConwayBasis[dehn]

Complement[Select[PolyhedronData[All],PolyhedronData[#,"DehnInvariant"]==dehn&&PolyhedronData[#,"Volume"]==vol&],{pname}]

DihedralAngles

(dih1=PolyhedronData[pname,"DihedralAngles"])//Tally

(dih2=SimplifyNumericallyDistinct[DihedralAngles[p]])//Tally

dih1===dih2

Dual

pname

dname=PolyhedronData[pname,"Dual","Name"]

PolyhedronData[pname,"Dual","Scale"]

midrs={PolyhedronData[pname,"Midradius"],PolyhedronData[dname,"Midradius"]}

Divide@@midrs//FullSimplify

GraphicsRow[With[{
s={Yellow,PolyhedronData[pname,"Midsphere"]},
style=Directive[Black,Italic,FontFamily->"Times",14]
},
{
Graphics3D[{s,Green,Opacity[.5],PolyhedronData[pname,"Polyhedron"]},Boxed->False,PlotLabel->TextCell[Style[PolyhedronData[pname,"Name"],style],PageWidth->200,TextAlignment->Center]],
Graphics3D[{s,Red,Opacity[.5],PolyhedronData[pname,"Dual","Polyhedron"]},Boxed->False,PlotLabel->Style[PolyhedronData[dname,"Name"],style]],
Graphics3D[{
{Green,Opacity[.5],PolyhedronData[pname,"Polyhedron"]},
{Red,Opacity[.5],PolyhedronData[pname,"Dual","Polyhedron"]},
s
},Boxed->False,PlotLabel->Style["compound with midsphere",style]],
Graphics3D[{
PolyhedronData[pname,"Polyhedron"],
PolyhedronData[pname,"Dual","Polyhedron"]
},Boxed->False,PlotLabel->Style["compound",style]]
}],Alignment->Top,ImageSize->800]

EdgeCount

PolyhedronData[pname,"EdgeCount"]

EdgeLengths

Tally[lens=SimplifyNumericallyDistinct[PolyhedronEdgeLengths[p],"Simplification"->RootReduce]//FullSimplify]//Timing

PolyhedronData[pname,"EdgeLengths"]

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

(distinctlens=Mean/@Split[Sort[lens],Abs[#1-#2]<1.*^-10&])//N//Quiet

v=p[[1]];

colors=With[{n=Length[distinctlens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[distinctlens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[p],Boxed->False]//Quiet

FaceCount

PolyhedronData[pname,"FaceCount"]

GeneralizedDiameter

PolyhedronData[pname,"GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify//Quiet

Hull

hullname=PolyhedronData[pname,"Hull","Name"]

PolyhedronData[pname,"Hull","Scale"]

((Max[Norm/@p[[1]]])/(Max[Norm/@PolyhedronData[hullname,"Polyhedron"][[1]]]))//FullSimplify//Quiet

PolyhedronData[pname,"Hull"]

Max[Norm/@PolyhedronData[pname,"Hull","Polyhedron"][[1]]]

Max[Norm/@p[[1]]]

{Graphics3D[{Opacity[.5],Red,p}],Graphics3D[{Opacity[.5],Blue,PolyhedronData[pname,"Hull"][[1]]}]}

Show[%]

HullOf

Select[PolyhedronData[All],PolyhedronData[#,"HullName"]===pname&]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

Graphics3D[{{Opacity[.5],p},{Red,sphere}},Boxed->False]

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

Midsphere[p//N]

(sphere=Midsphere[p])//Timing

(sphere=Midsphere[p,Method->"PointLineDistance"])//Timing

Graphics3D[{{Opacity[.5],Yellow,p},{Red,sphere}},Boxed->False]

Net

PolyhedronData[pname,"Net"]

NotationRules

PolyhedronData[pname,"NotationRules"]

Orientations

PolyhedronData[pname,"Orientations"]

PolyhedronData[pname,"DefaultOrientation"]

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

Polygons

PolyhedronData[pname,"FaceCount"]

PolyhedronFaceTally[p]

Graphics3D/@PolyhedronData[pname,"Polygons"]

Show[%]

Polyhedra

PolyhedronData[pname,"Polyhedra"]

Graphics3D[%]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]

Skeleton

PolyhedronData[pname,"Skeleton"]

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

GraphData[gn]

emb=GraphData[gn,"PolyhedralEmbeddings"]

pname

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

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

Total[Area/@PolyhedronData[pname,"Polygons"]]//ToAlgebraicRoot

SurfaceArea[PolyhedronData[pname,"Region"]]

Uniform

PolyhedronData[pname,"Uniform"]

VertexCount

PolyhedronData[pname,"VertexCount"]

VertexSubsetHulls

subsethulls=PolyhedronData[pname,"VertexSubsetHulls"]

v=PolyhedronData[pname,"Vertices"];

Rule[#,Length[#2]]&@@@subsethulls

Rule[#,Graphics3D[Function[f,ConvexHullRegion[v[[f]]]]/@#2]]&@@@subsethulls

subsethulls2=Flatten[Function[{pn,l},Rule[pn,#]&/@l]@@@subsethulls]

Rule[#,Graphics3D[{{Opacity[.3],{Green,p}},Blue,ConvexHullRegion[v[[#2]]]}]]&@@@subsethulls2

Convex hull

Graphics3D[convexhullreg=ConvexHullRegion[v=PolyhedronData[pname,"Vertices"]]]

v=PolyhedronCoordinates[convexhullreg]

Flatten[(convexhullreg[[2]]/.i_Integer:>v[[i]])/.Thread[PolyhedronData[pname,"Vertices"]->Range[PolyhedronData[pname,"V"]]]]//Union

%===Range@Length@v

PolyhedronData[pname,"ConvexHull","Name"]

Platonic

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

Volume

PolyhedronData[pname,"Volume"]

Volume[p]//FullSimplify

PolyhedronVolume[p]//FullSimplify

Volume[PolyhedronData[pname,"Region"]]//FullSimplify

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

WythoffSymbol

PolyhedronData[pname,"WythoffSymbol"]

Interior

ineqs=((ExpandAll[N[(Flatten[List@@(PolyhedronInequalities[#,{x,y,z}]&/@Tetrahedron5CompoundR)]),20]]//Chop)/.x_?NumericQ:>ToExactN[x])

ineqs={-1-((Sqrt[5])/2)-(Sqrt[(1/5) (5+2 (Sqrt[5]))]) x+(-2-(Sqrt[5])) y-(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) z<0&&1+((Sqrt[5])/2)+(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) x+(-(3/2)-((Sqrt[5])/2)) y+(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) z<0&&-1-((Sqrt[5])/2)-(Sqrt[(5/2)+(11/(2 (Sqrt[5])))]) x+(1/2) (1+(Sqrt[5])) y+(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) z<0&&1+((Sqrt[5])/2)-(Sqrt[(2/5) (25+11 (Sqrt[5]))]) x-(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) z<0,1+((Sqrt[5])/2)-(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) x+(-(3/2)-((Sqrt[5])/2)) y-(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) z<0&&-1-((Sqrt[5])/2)+(Sqrt[(1/5) (5+2 (Sqrt[5]))]) x+(-2-(Sqrt[5])) y+(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) z<0&&1+((Sqrt[5])/2)-(Sqrt[(5/2)+(11/(2 (Sqrt[5])))]) x+(-(1/2)-((Sqrt[5])/2)) y+(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) z<0&&-1-((Sqrt[5])/2)-(Sqrt[(2/5) (25+11 (Sqrt[5]))]) x-(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) z<0,1+((Sqrt[5])/2)+(Sqrt[(1/5) (5+2 (Sqrt[5]))]) x+(-2-(Sqrt[5])) y+(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) z<0&&-1-((Sqrt[5])/2)+(Sqrt[(5/2)+(11/(2 (Sqrt[5])))]) x+(-(1/2)-((Sqrt[5])/2)) y-(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) z<0&&1+((Sqrt[5])/2)+(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) x+(1/2) (3+(Sqrt[5])) y-(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) z<0&&-1-((Sqrt[5])/2)+2 (Sqrt[(1/5) (5+2 (Sqrt[5]))]) x+(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) z<0,1+((Sqrt[5])/2)-(Sqrt[(1/5) (5+2 (Sqrt[5]))]) x+(-2-(Sqrt[5])) y-(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) z<0&&-1-((Sqrt[5])/2)-(Sqrt[(5/2)+(11/(2 (Sqrt[5])))]) x+(-(1/2)-((Sqrt[5])/2)) y+(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) z<0&&1+((Sqrt[5])/2)-(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) x+(1/2) (3+(Sqrt[5])) y+(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) z<0&&-1-((Sqrt[5])/2)-2 (Sqrt[(1/5) (5+2 (Sqrt[5]))]) x-(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) z<0,1+((Sqrt[5])/2)+(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) x+(1/2) (3+(Sqrt[5])) y+(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) z<0&&-1-((Sqrt[5])/2)+(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) x+(-(3/2)-((Sqrt[5])/2)) y+(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) z<0&&1+((Sqrt[5])/2)+(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) x+(-(3/2)-((Sqrt[5])/2)) y-(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) z<0&&-1-((Sqrt[5])/2)+(Sqrt[(13/2)+(29/(2 (Sqrt[5])))]) x+(1/2) (3+(Sqrt[5])) y-(Sqrt[(1/2)+(1/(2 (Sqrt[5])))]) z<0}

Runs out of memory

Timing[interior=PolyhedronFromInequalities[List@@ineqs[[1]],{x,y,z}]]

Construction

{"TetrahedronFiveCompound", 1} (actually 2 of them) from VertexSubsetCompound["Dodecahedron","Tetrahedron"]

Graphics3D[VertexSubsetCompound["Dodecahedron","Tetrahedron"]]

{"TetrahedronFiveCompound", 1} from dodecahedron

<<DiscreteMath`Combinatorica`

v=PolyhedronVertices[Dodecahedron];

Show[Graphics3D[{
Polyhedron[Dodecahedron],
PointSize[.05],Point/@v[[{2,9}]]
}],Boxed->False]

l=RootReduce[Sqrt[#.#]&[Subtract@@v[[{2,9}]]]]

l2=FullSimplify[l^2]

Tet[l_]:=#.#&[(#.#-l2)&/@Subtract@@@KSubsets[v[[l]],2]]

Binomial[20,4]

Timing[tets=Select[KSubsets[Range[20],4],Abs[Tet[#]]<10^-8&]]

tets={{1,11,17,20},{1,12,18,19},{2,9,14,15},{2,10,13,16},{3,7,9,20},{3,8,10,19},{4,5,11,14},{4,6,12,13},{5,7,16,18},{6,8,15,17}};

{tet5R,tet5L}=Select[KSubsets[tets,5],Sort[Flatten[#]]==Union[Flatten[#]]&]

Show[Graphics3D[Polygon/@KSubsets[#,3]&/@(v[[#]]&/@tets)],
Boxed->False]

Show[GraphicsArray[Function[f,Graphics3D[Polygon[v[[#]]]&/@KSubsets[#,3]&/@f,Boxed->False]]/@{tet5R,tet5L}],
GraphicsSpacing->-.2]

Tetrahedra

<<DiscreteMath`Combinatorica`

PolyhedronFaces[Tetrahedron5Compound]

tets=Select[KSubsets[PolyhedronFaces[Tetrahedron5Compound],4],Length[Union[Flatten[#]]]==4&]

tets/.Thread[PolyhedronFaces[Tetrahedron5Compound]->Range[20]]

PolyhedronPolyhedron[Tetrahedron5Compound]:={{1,2,3,4},{5,6,7,8},{9,10,11,12},{13,14,15,16},{17,18,19,20}}

Split Version through Stellation

FaceIntersections[poly_]:=Module[{pairs=KSubsets[Take[#,3]&/@First/@poly,2]},
DeleteCases[Intersection3D@@@Map[Plane,pairs,{2}],{}]
]

poly=Tetrahedron5Compound;
Timing[lines=FaceIntersections[Polyhedron[poly]];]

Timing[newlines=Map[ToExact,lines,{4}];]

Length/@{lines,newlines}

Timing[Length[points=Intersection3D@@@KSubsets[newlines,2]]]

Length[points2=Union[DeleteCases[points,{}],SameTest->(Abs[N[#1[[1]]-#2[[1]],200]]=={0,0,0}&)]]//Timing

Timing[points3=Map[ToExact,points2,{4}];]

Show[Graphics3D[{Polyhedron[poly],{Red,newlines},{PointSize[.02],points3}}]]

points4=Select[points3,#[[1]].#[[1]]<2&];

Show[Graphics3D[{Polyhedron[poly],{PointSize[.02],
points4},
MapIndexed[Text[#2[[1]],#1[[1]]+{0,0,.1},Background->White]&,points4]}],Boxed->False]

Show[Graphics3D[{Polyhedron[poly],{PointSize[.03],
points4[[{31,175,191,9,139}]]}}],Boxed->False]

FullSimplify[Sqrt[(#[[2]]-#[[1]]).(#[[2]]-#[[1]])]&/@Partition[First/@points4[[{31,175,191,9,139}]],2,1,1]]

poly2=Polygon2D[First/@points4[[{31,175,191,9,139}]]];

Show[Graphics[poly2],AspectRatio->Automatic]

poly3=FullSimplify[Map[ToExact,poly2,{2}]][[1]]

FullSimplify[Function[f,Sqrt[f.f]][Subtract@@#]&/@Partition[poly3,2,1,1]]

{#,N[#]}&@Sort[{(Sqrt[3-(Sqrt[5])]),(Sqrt[7-3 (Sqrt[5])]),(1/2) (3-(Sqrt[5])),(1/2) (3-(Sqrt[5])),(Sqrt[3-(Sqrt[5])])},Less]

Show[Graphics[{ClosedLine[poly3],
MapIndexed[Text[#2[[1]],#1,Background->White]&,poly3]
}],AspectRatio->Automatic]

poly3={{0,0},{((-1+(Sqrt[5]))/(2 (Sqrt[2]))),(Sqrt[(9/4)-((3 (Sqrt[5]))/4)])},{((Sqrt[3+(Sqrt[5])])/4),(1/4) (Sqrt[21-9 (Sqrt[5])])},{((3+(Sqrt[5]))/(4 (Sqrt[2]))),(1/4) (Sqrt[9-3 (Sqrt[5])])},{(Sqrt[3-(Sqrt[5])]),0}};

Show[Graphics[net=ClosedLine/@Table[{{Cos[#],Sin[#]},{-Sin[#],Cos[#]}}&[-n Pi/3].#&/@poly3,{n,0,2}],AspectRatio->Automatic]
]

<<Simplify`

net2=Map[ToExact,Flatten[net],{3}]

v=Union[Flatten[First/@net2,1]];

Drop[First[#],-1]&/@net2/.Thread[v->Range[Length[v]]]

v//InputForm

Show[Graphics[Net[Tetrahedron5Compound,1]],AspectRatio->Automatic]

Convex Hull of split version

<<ConvexHull`

Show[Graphics3D[ConvexHull3D[First/@points3]]]

{"TetrahedronFiveCompound", 1}

{"TetrahedronFiveCompound", 2}

Graphics3D[compound=VertexSubsetCompound[{"TetrahedronFourCompound",3},"Tetrahedron"]]

PolyhedronData

PolyhedronDataString

file=OpenWrite["~/compound.m"]

WriteString[file,With[
{
base="Tetrahedron",
n=5,
facecnt=PolyhedronFaceCount[compound],
ind=2
},
PolyhedronDataString[compound,
"StandardName"->{base<>StringJoin@@(Capitalize/@StringSplit[IntegerName[n],"\[Hyphen]"])<>"Compound",ind},
"AlternateStandardNames"->{},
"Name"->IntegerName[ind,"Ordinal"]<>" "<>ToLowerCase[base]<>" "<>ToString[n]<>"\[Hyphen]compound",
"Information"->base<>ToString[n]<>"-Compound",
"PolyhedronIndices"->"Partition[Range["<>ToString[facecnt]<>"], "<>ToString[facecnt/n]<>"]",
"Classes"->{"Compound"}
]]]

Close[file]