Tetrahedron 4-Compound

Author

Eric W. Weisstein
October 5, 2023

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

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

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

Variants

<<MathWorld`Polyhedra`

variants=PolyhedronData["TetrahedronFourCompound*"]

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->700]

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]

GraphData["Fullerene",28]

Polyhedron: {"TetrahedronFourCompound", 1}

Orientations

PolyhedronData[{"TetrahedronFourCompound",1},"Orientations"]

PolyhedronData[{"TetrahedronFourCompound",1},"DefaultOrientation"]

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

Polyhedron

Graphics3D[{Opacity[.8],PolyhedronData[{"TetrahedronFourCompound",1},"Polyhedron"]}]

Face orientation

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

Region

PolyhedronData[{"TetrahedronFourCompound",1},"Region"]

Solid and dual

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

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

Polyhedron: {"TetrahedronFourCompound", 2}

Orientations

PolyhedronData[{"TetrahedronFourCompound",2},"Orientations"]

PolyhedronData[{"TetrahedronFourCompound",2},"DefaultOrientation"]

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

Polyhedron

Graphics3D[{Opacity[.8],PolyhedronData[{"TetrahedronFourCompound",2},"Polyhedron"]}]

Face orientation

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

Region

PolyhedronData[{"TetrahedronFourCompound",2},"Region"]

Solid and dual

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

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

Polyhedron: {"TetrahedronFourCompound", 3}

Orientations

PolyhedronData[{"TetrahedronFourCompound",3},"Orientations"]

PolyhedronData[{"TetrahedronFourCompound",3},"DefaultOrientation"]

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

Polyhedron

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

Face orientation

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

Region

PolyhedronData[{"TetrahedronFourCompound",3},"Region"]

Solid and dual

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

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

Polyhedron: {"TetrahedronFourCompound", 4}

Orientations

PolyhedronData[{"TetrahedronFourCompound",4},"Orientations"]

PolyhedronData[{"TetrahedronFourCompound",4},"DefaultOrientation"]

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

Polyhedron

Graphics3D[{Opacity[.8],PolyhedronData[{"TetrahedronFourCompound",4},"Polyhedron"]}]

Face orientation

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

Region

PolyhedronData[{"TetrahedronFourCompound",4},"Region"]

Solid and dual

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

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

Polyhedron: {"TetrahedronFourCompound", 5}

Orientations

PolyhedronData[{"TetrahedronFourCompound",5},"Orientations"]

PolyhedronData[{"TetrahedronFourCompound",5},"DefaultOrientation"]

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

Polyhedron

Graphics3D[{Opacity[.8],PolyhedronData[{"TetrahedronFourCompound",5},"Polyhedron"]}]

Face orientation

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

Region

PolyhedronData[{"TetrahedronFourCompound",5},"Region"]

Solid and dual

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

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

Polyhedron: {"TetrahedronFourCompound", 6}

Orientations

PolyhedronData[{"TetrahedronFourCompound",6},"Orientations"]

PolyhedronData[{"TetrahedronFourCompound",6},"DefaultOrientation"]

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

Polyhedron

Graphics3D[{Opacity[.8],PolyhedronData[{"TetrahedronFourCompound",6},"Polyhedron"]}]

Face orientation

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

Region

PolyhedronData[{"TetrahedronFourCompound",6},"Region"]

Solid and dual

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

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

Properties: {"TetrahedronFourCompound", 1}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"TetrahedronFourCompound",1},"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]

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

MyCircumsphere[interior]//Quiet

Insphere[interior]/.x_?NumericQ:>ToAlgebraicRoot[x]//Quiet

Midsphere[interior]

Construction

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

Graphics3D[int]

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

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

Exactify: RootApproximant

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

Length[vexact]

Exactify: ToAlgebraicRoot

vexact=DeleteDuplicates[Map[ToAlgebraicRoot[SetPrecision[#,14],"MaxDegree"->8]&,Chop[int[[1]]],{2}]]

Length[vexact]

Plane intersections

polygons=PolyhedronData[pname,"Polygons"]

Length@polygons

Binomial[%,3]

intersections=RegionIntersection@@@Subsets[InfinitePlane@@@polygons,{3}];//Timing

Length[pts=Cases[intersections,Point[x_]:>Flatten[x]]]

pts[[1]]

Graphics3D[{AbsolutePointSize[3],Point[pts],Opacity[.2],p},PlotRange->.8]

Norm/@int[[1]]//Union

Length[pts2=Select[pts,.228<Norm[#]<.229||.269<Norm[#]<.27||.30<Norm[#]<.31&]]

vexact=Map[ToAlgebraicRoot,pts2,{2}]//FullSimplify

N[vexact-pts2,100]//Abs//Max

Graphics3D[{AbsolutePointSize[10],Point[vexact],Opacity[.2],p}]

Exact interior

inthull=ConvexHullRegion[Union@vexact]

v=inthull[[1]]

faces=Sort[inthull[[2]]]

gname=RecognizeGraph@PolyhedronGraph[inthull]

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

lengths=Keys[%]

Graphics3D[{AbsolutePointSize[10],Point[vexact],{Opacity[.2],p},Red,int}]

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

newi[[1]]

Sort[newi[[2]]]

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

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]

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

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]

GraphicsGrid[Partition[Graphics3D[{
{Green,Opacity[.7],PolyhedronData[#,"Polyhedron"]},
{Blue,Opacity[.2],PolyhedronData[#,"ConvexHull","Polyhedron"]}},Boxed->False,PlotLabel->Style[PolyhedronData[#,"Name"],Directive[14,Black,Italic,FontFamily->"Times"]]]&/@hullof,UpTo[3]],Dividers->All,ImageSize->800]

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[%]

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[hullname,"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"]]]}

HullOf

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

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

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[N[p,50]]

%/.x_?InexactNumberQ:>FullSimplify@RootApproximant[x]

sphere=MyInsphere[p]

Graphics3D[{{Opacity[.2],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"]

(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

polyhedra=PolyhedronData[pname,"Polyhedra"]

Length[polyhedra]

Graphics3D[polyhedra]

Graphics3D[Table[{Hue[(i/(Length[polyhedra]))],polyhedra[[i]]},{i,Length[polyhedra]}]]

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"]

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

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

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

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: {"TetrahedronFourCompound", 2}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"TetrahedronFourCompound",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]

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

MyCircumsphere[interior]//Quiet

Insphere[interior]/.x_?NumericQ:>ToAlgebraicRoot[x]//Quiet//Timing

Midsphere[interior]

Construction

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

Graphics3D[int]

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

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

newi[[1]]

Sort[newi[[2]]]

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

Exactify: RootApproximant

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

Length[vexact]

Exactify: ToAlgebraicRoot

vexact=DeleteDuplicates[Map[ToAlgebraicRoot[SetPrecision[#,14],"MaxDegree"->4]&,Chop[int[[1]]],{2}]]

Length[vexact]

Plane intersections

polygons=PolyhedronData[pname,"Polygons"]

Length@polygons

Binomial[%,3]

Length[intersections=RegionIntersection@@@Subsets[InfinitePlane@@@polygons,{3}]]//Timing

Length[pts=Cases[intersections,Point[x_]:>Flatten[x]]]

pts[[1]]

Length[pts2=Select[pts,Min[Abs[Denominator[#]]]>1*^-100&]]//Quiet//Timing

Graphics3D[{AbsolutePointSize[5],Point[N[pts2]],Opacity[.2],p},PlotRange->.7]

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

normineqs[l_,dx_:.01]:=Function[Evaluate[Or@@(Function[f,f-dx<=Norm[#]<=f+dx]/@l)]]

ineq=normineqs[groupednorms,.0001]

Length[pts3=Select[pts2,ineq]]//Quiet//Timing

Graphics3D[{AbsolutePointSize[5],Point[N[pts3]],Opacity[.2],p},PlotRange->.7]

Length[pts4=DeleteDuplicates[Map[ToAlgebraicRoot,pts3,{2}]]]//Timing

Graphics3D[{AbsolutePointSize[5],Point[pts4],{Opacity[0],p},Red,ConvexHullRegion[pts4]},PlotRange->.4]

vexact=pts4

Exact interior

inthull=ConvexHullRegion[Union@vexact]

v=inthull[[1]]

faces=Sort[inthull[[2]]]

gname=RecognizeGraph@PolyhedronGraph[inthull]

GraphData[gname,"PolyhedralEmbeddings"]

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

pname

Concave

PolyhedronData[pname,"Concave"]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]

ConvexHull

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

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

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

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

Graphics3D[LabelPolyhedron@convexhull]

CoplanarPoints[convexhull[[1]][[{2,8,9,4}]]]

MyDihedralAngle[{Polygon[v[[{2,8,9}]]],Polygon[v[[{2,9,4}]]]}]//FullSimplify

Not quite coplanar:

Pi-N[%,10]

{
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

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]

GraphicsGrid[Partition[Graphics3D[{
{Green,Opacity[.7],PolyhedronData[#,"Polyhedron"]},
{Blue,Opacity[.2],PolyhedronData[#,"ConvexHull","Polyhedron"]}},Boxed->False,PlotLabel->Style[PolyhedronData[#,"Name"],Directive[14,Black,Italic,FontFamily->"Times"]]]&/@hullof,UpTo[3]],Dividers->All,ImageSize->800]

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[%]

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[hullname,"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"]]]}

HullOf

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

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

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[N[p,50]]

%/.x_?InexactNumberQ:>FullSimplify@RootApproximant[x]

sphere=MyInsphere[p]

Graphics3D[{{Opacity[.2],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"]

(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

polyhedra=PolyhedronData[pname,"Polyhedra"]

Length[polyhedra]

Graphics3D[polyhedra]

Graphics3D[Table[{Hue[(i/(Length[polyhedra]))],polyhedra[[i]]},{i,Length[polyhedra]}]]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

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

GraphData[gn]

emb=GraphData[gn,"PolyhedralEmbeddings"]

l={{gn,{0,Union[emb,{pname}]}}}

PropertyReplace[l,"PolyhedralEmbeddings","14.0"]

pname

With[{verts=PolyhedronData[pname,"Vertices"],faces=PolyhedronData[pname,"Faces","List"]},
ToCommonEdges[GraphData[gn],Graph[Range[Length[verts]],UndirectedEdge@@@Union[Sort/@Flatten[Partition[#,2,1,1]&/@faces,1]]]]]//Chop[#,1*^-5]&//N

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

So there is a fifth tetrahedron in the vertex set of this 4-tetrahedron compound, but it is not attractive:

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

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

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

Convex hull

pname

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

<<MathWorld`Polyhedra`

(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: {"TetrahedronFourCompound", 3}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"TetrahedronFourCompound",3},"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]

Midsphere[inthull]

Insphere[inthull]

v=inthull[[1]]

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]

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

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]

GraphicsGrid[Partition[Graphics3D[{
{Green,Opacity[.7],PolyhedronData[#,"Polyhedron"]},
{Blue,Opacity[.2],PolyhedronData[#,"ConvexHull","Polyhedron"]}},Boxed->False,PlotLabel->Style[PolyhedronData[#,"Name"],Directive[14,Black,Italic,FontFamily->"Times"]]]&/@hullof,UpTo[3]],Dividers->All,ImageSize->800]

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[%]

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[hullname,"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"]]]}

HullOf

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

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

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[N[p,50]]

%/.x_?InexactNumberQ:>FullSimplify@RootApproximant[x]

sphere=MyInsphere[p]

Graphics3D[{{Opacity[.2],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"]

(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

polyhedra=PolyhedronData[pname,"Polyhedra"]

Length[polyhedra]

Graphics3D[polyhedra]

Graphics3D[Table[{Hue[(i/(Length[polyhedra]))],polyhedra[[i]]},{i,Length[polyhedra]}]]

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"]

l={{gn,{0,Union[emb,{pname}]}}}

PropertyReplace[l,"PolyhedralEmbeddings","14.0"]

pname

With[{verts=PolyhedronData[pname,"Vertices"],faces=PolyhedronData[pname,"Faces","List"]},
ToCommonEdges[GraphData[gn],Graph[Range[Length[verts]],UndirectedEdge@@@Union[Sort/@Flatten[Partition[#,2,1,1]&/@faces,1]]]]]//Chop[#,1*^-5]&//N

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

pname

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

So there is a tetrahedron 5-compound (call it {"TetrahedronFiveCompound", 2} on the vertices of the 4-compound

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: {"TetrahedronFourCompound", 4}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"TetrahedronFourCompound",4},"Polyhedron"]

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

Centroid

PolyhedronData[pname,"Centroid"]

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

sphere=Circumsphere[p]

MyCircumsphere[N[p,50]]

%/.x_?InexactNumberQ:>FullSimplify@RootApproximant[x]

(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]]

faces=inthull[[2]]

gname=RecognizeGraph@PolyhedronGraph[inthull]

GraphData[gname,"PolyhedralEmbeddings"]

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

pname

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]

ConvexHull

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

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

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

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

Counts[SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]]

Keys[%]//N

{
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

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]

GraphicsGrid[Partition[Graphics3D[{
{Green,Opacity[.7],PolyhedronData[#,"Polyhedron"]},
{Blue,Opacity[.2],PolyhedronData[#,"ConvexHull","Polyhedron"]}},Boxed->False,PlotLabel->Style[PolyhedronData[#,"Name"],Directive[14,Black,Italic,FontFamily->"Times"]]]&/@hullof,UpTo[3]],Dividers->All,ImageSize->800]

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[%]

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[hullname,"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"]]]}

HullOf

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

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

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[N[p,50]]

%/.x_?InexactNumberQ:>FullSimplify@RootApproximant[x]

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[N[p,50]]

%/.x_?InexactNumberQ:>FullSimplify@RootApproximant[x]

(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

polyhedra=PolyhedronData[pname,"Polyhedra"]

Length[polyhedra]

Graphics3D[polyhedra]

Graphics3D[Table[{Hue[(i/(Length[polyhedra]))],polyhedra[[i]]},{i,Length[polyhedra]}]]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

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

GraphData[gn]

emb=GraphData[gn,"PolyhedralEmbeddings"]

l={{gn,{0,Union[emb,{pname}]}}}

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

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

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

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: {"TetrahedronFourCompound", 5}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"TetrahedronFourCompound",5},"Polyhedron"]

AdjacentFaceIndices

adj1=PolyhedronData[pname,"AdjacentFaceIndices"]

adj2=AdjacentFaceIndices[p]

adj1===adj2

Centroid

PolyhedronData[pname,"Centroid"]

Circumsphere

sphere=PolyhedronData[pname,"Circumsphere"]

sphere=Circumsphere[p]

MyCircumsphere[N[p,50]]

%/.x_?InexactNumberQ:>FullSimplify@RootApproximant[x]

(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},
Opacity[.8],Red,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]]

faces=inthull[[2]]

gname=RecognizeGraph@PolyhedronGraph[inthull]

GraphData[gname,"PolyhedralEmbeddings"]

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

pname

Find scale

intname={"CanonicalDipyramid",8};

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]

ConvexHull

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

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

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

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

Counts[SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]]

Keys[%]//N

{
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

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]

GraphicsGrid[Partition[Graphics3D[{
{Green,Opacity[.7],PolyhedronData[#,"Polyhedron"]},
{Blue,Opacity[.2],PolyhedronData[#,"ConvexHull","Polyhedron"]}},Boxed->False,PlotLabel->Style[PolyhedronData[#,"Name"],Directive[14,Black,Italic,FontFamily->"Times"]]]&/@hullof,UpTo[3]],Dividers->All,ImageSize->800]

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[%]

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[hullname,"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"]]]}

HullOf

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

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

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[N[p,50]]

%/.x_?InexactNumberQ:>FullSimplify@RootApproximant[x]

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[N[p,50]]

%/.x_?InexactNumberQ:>FullSimplify@RootApproximant[x]

(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

polyhedra=PolyhedronData[pname,"Polyhedra"]

Length[polyhedra]

Graphics3D[polyhedra]

Graphics3D[Table[{Hue[(i/(Length[polyhedra]))],polyhedra[[i]]},{i,Length[polyhedra]}]]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

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

GraphData[gn]

emb=GraphData[gn,"PolyhedralEmbeddings"]

l={{gn,{0,Union[emb,{pname}]}}}

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

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

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

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: {"TetrahedronFourCompound", 6}

Initialization

<<MathWorld`Polyhedra`

p=PolyhedronData[pname={"TetrahedronFourCompound",6},"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]//FullSimplify//Quiet

Midsphere[interior]

Construction

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

Graphics3D[int]

Graphics3D[{{Opacity[.3],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]]

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]]]

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

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

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]

ConvexHull

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

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

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

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

Counts[SimplifyNumericallyDistinct[PolyhedronEdgeLengths[convexhull]]]

Keys[%]//N

{
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

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]

GraphicsGrid[Partition[Graphics3D[{
{Green,Opacity[.7],PolyhedronData[#,"Polyhedron"]},
{Blue,Opacity[.2],PolyhedronData[#,"ConvexHull","Polyhedron"]}},Boxed->False,PlotLabel->Style[PolyhedronData[#,"Name"],Directive[14,Black,Italic,FontFamily->"Times"]]]&/@hullof,UpTo[3]],Dividers->All,ImageSize->800]

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[%]

Find rotation matrix

Graphics3D[{FaceForm[Green,Red],basesolid=PolyhedronData[hullname,"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"]]]}

HullOf

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

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

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

Insphere

sphere=PolyhedronData[pname,"Insphere"]

Insphere[p]

%/.x_?InexactNumberQ:>FullSimplify@RootApproximant[x]

sphere=MyInsphere[p]

Graphics3D[{{Opacity[.1],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"]

(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

polyhedra=PolyhedronData[pname,"Polyhedra"]

Length[polyhedra]

Graphics3D[polyhedra]

Graphics3D[Table[{Hue[(i/(Length[polyhedra]))],polyhedra[[i]]},{i,Length[polyhedra]}]]

PolyhedronData[pname,"PolyhedronIndices"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]//Timing

Skeleton

PolyhedronData[pname,"Skeleton"]

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

GraphData[gn]

emb=GraphData[gn,"PolyhedralEmbeddings"]

l={{gn,{0,Union[emb,{pname}]}}}

PropertyReplace[l,"PolyhedralEmbeddings","14.0"]

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

g=PolyhedronGraph[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

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

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"]

Construction

<<MathWorld`Polyhedra`

{"TetrahedronFourCompound", 1} from PolyhedronRotationCompound[PolyhedronData["Tetrahedron", "Polyhedron"], "Face", -2]

Graphics3D[PolyhedronRotationCompound[PolyhedronData["Tetrahedron","Polyhedron"],"Face",-2,Debug->True]]

PolyhedronData[{"TetrahedronFourCompound", 1}]

Pieces for compound XXX ?

Graphics3D[Polyhedron[{{0,0,Sqrt[3/2]/2},{-(1/Sqrt[3]),0,-1/(2Sqrt[6])},{-2/(3Sqrt[3]),-1/3,5/(6Sqrt[6])},{-2/(3Sqrt[3]),0,-7/(6Sqrt[6])},{-2/(3Sqrt[3]),1/3,5/(6Sqrt[6])},{-1/(2Sqrt[3]),-1/2,-1/(2Sqrt[6])},{-1/(2Sqrt[3]),1/2,-1/(2Sqrt[6])},{-1/(6Sqrt[3]),-1/2,5/(6Sqrt[6])},{-1/(6Sqrt[3]),1/2,5/(6Sqrt[6])},{1/(3Sqrt[3]),-1/3,-7/(6Sqrt[6])},{1/(3Sqrt[3]),1/3,-7/(6Sqrt[6])},{1/(2Sqrt[3]),-1/2,-1/(2Sqrt[6])},{1/(2Sqrt[3]),1/2,-1/(2Sqrt[6])},{5/(6Sqrt[3]),-1/6,5/(6Sqrt[6])},{5/(6Sqrt[3]),1/6,5/(6Sqrt[6])},{1/Sqrt[3],0,-1/(2Sqrt[6])}},{{12,2,13},{2,12,1},{13,1,12},{1,13,2},{4,9,16},{9,4,8},{16,8,4},{8,16,9},{3,7,10},{7,3,15},{10,15,3},{15,10,7},{6,11,14},{11,6,5},{14,5,6},{5,14,11}}]]

<<SolidGeometry`;
<<Simplify`;
Off[$MaxExtraPrecision::"meprec"];

poly=Flatten[Polyhedron[Tetrahedron4Compound,"C3"]];

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

Timing[Length[lines=FaceIntersections[poly]]]

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

Timing[Length[p=First/@Union[Select[DeleteCases[points,{}],#[[1]].#[[1]]≤.8&]]]]

Timing[Length[p2=Union[Map[Simplify,p,{2}]]]]

Show[Graphics3D[{Polyhedron[Tetrahedron4Compound,"C3"],
PointSize[.005],
Point/@p2,
MapIndexed[Text[#2[[1]],#1+{0,0,.02},Background->White]&,p2]
}],Boxed->False,ViewPoint->{1,0,1}]

Triangle

t1=p2[[{79,135,72}]]

u1=Map[ToExact,Polygon2D[t1][[1]],{3}]

t2=p2[[{79,137,72}]]

u2=Map[ToExact,Polygon2D[t2][[1]],{3}]

Show[Graphics[piece3=ClosedLine/@{u1,{#[[1]],-#[[2]]}&/@u2}],AspectRatio->Automatic]

Complicated Piece

q3=p2[[{138,11,141,137,72,135,71,136}]]

Sort[Union[FullSimplify[Sqrt[#.#]&/@Subtract@@@Partition[q3,2,1,1]]],Less]

N[%]

q3=p2[[RotateLeft[{138,11,141,137,72,135,71,136}]]]

Sort[Union[FullSimplify[Sqrt[#.#]&/@Subtract@@@Partition[q3,2,1,1]]],Less]

N[%]

InputForm[r3=Map[ToExact,Polygon2D[q3][[1]],{3}]]

Big Triangle

InputForm[q4=p2[[{79,97,95}]]]

Crashes v4.2, so use v5.0

InputForm[r4=Map[ToExact,Polygon2D[q4][[1]],{3}]]

r3={{0, 0}, {3/10, (3*Sqrt[3])/10}, {2/7, Sqrt[3]/7}, {2/9, 1/(3*Sqrt[3])}, 
 {9/32, (3*Sqrt[3])/32}, {5/18, 1/(6*Sqrt[3])}, {5/14, Sqrt[3]/14}, {3/5, 0}};

q2=p2[[{71,136,79}]]

Sqrt[#.#]&[Subtract@@p2[[{71,79}]]]

InputForm[r2=Map[ToExact,Polygon2D[q2][[1]],{3}]]

r2={{0, 0}, {1/(18*Sqrt[7]), Sqrt[7/3]/18 + 1/(9*Sqrt[21])}, {2/(9*Sqrt[7]), 0}};

q1=RotateLeft[p2[[{136,79,96,138}]],2]

InputForm[r1=Map[ToExact,Polygon2D[q1][[1]],{3}]]

Show[Graphics[piece1={
ClosedLine/@Table[RotationMatrix[n Pi/3].#&/@r3,{n,4,6}]
}],AspectRatio->Automatic]

Show[Graphics[piece2=ClosedLine/@{
r5=({1/3,0}+RotationMatrix[Pi/3].(#-{1/3,0}))&/@r1,
{1/3-#[[1]],#[[2]]}&/@r5,
r4}],AspectRatio->Automatic]

Sqrt[#.#]&[Subtract@@r2[[{1,3}]]]

Show[Graphics[piece3=ClosedLine/@{
r2,
{#[[1]],-#[[2]]}&/@r2
}],
AspectRatio->Automatic]

Show[Graphics[net={
piece1,
piece2/.Line[x_]:>Line[#+{1,0}&/@x],
piece3/.Line[x_]:>Line[#+{2-1/8,1/8}&/@x]
}],AspectRatio->Automatic]

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

net2={Line[{{0,0},{-(3/5),0},{-(5/14),((Sqrt[3])/14)},{-(5/18),(1/(6 (Sqrt[3])))},{-(9/32),((3 (Sqrt[3]))/32)},{-(2/9),(1/(3 (Sqrt[3])))},{-(2/7),((Sqrt[3])/7)},{-(3/10),((3 (Sqrt[3]))/10)},{0,0}}],Line[{{0,0},{-(3/10),((3 (Sqrt[3]))/10)},{-(1/14),((3 (Sqrt[3]))/14)},{-(1/18),(1/(2 (Sqrt[3])))},{0,((3 (Sqrt[3]))/16)},{(1/18),(1/(2 (Sqrt[3])))},{(1/14),((3 (Sqrt[3]))/14)},{(3/10),((3 (Sqrt[3]))/10)},{0,0}}],Line[{{0,0},{(3/10),((3 (Sqrt[3]))/10)},{(2/7),((Sqrt[3])/7)},{(2/9),(1/(3 (Sqrt[3])))},{(9/32),((3 (Sqrt[3]))/32)},{(5/18),(1/(6 (Sqrt[3])))},{(5/14),((Sqrt[3])/14)},{(3/5),0},{0,0}}],Line[{{(7/6),(1/(2 (Sqrt[3])))},{(47/30),(1/(2 (Sqrt[3])))},{(61/42),(1/(14 (Sqrt[3])))},{(4/3),0},{(7/6),(1/(2 (Sqrt[3])))}}],Line[{{(7/6),(1/(2 (Sqrt[3])))},{(23/30),(1/(2 (Sqrt[3])))},{(37/42),(1/(14 (Sqrt[3])))},{1,0},{(7/6),(1/(2 (Sqrt[3])))}}],Line[{{1,0},{(7/6),(1/(2 (Sqrt[3])))},{(4/3),0},{1,0}}],Line[{{(15/8),(1/8)},{(187/96),(1/32) (4+(Sqrt[3]))},{(143/72),(1/8)},{(15/8),(1/8)}}],Line[{{(15/8),(1/8)},{(331/168),(1/168) (21-8 (Sqrt[3]))},{(143/72),(1/8)},{(15/8),(1/8)}}]};

Show[Graphics[{Take[net2,-2],p3=(Take[net2,-2]/.Line[x_]:>Line[{5-1/2-#[[1]],#[[2]]}&/@x])}],AspectRatio->Automatic]

net3=Join[net2,p3]

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

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

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

v//InputForm

Show[Graphics[NetDiagram[Tetrahedron4Compound,"C3"]],AspectRatio->Automatic]

<<Simplify`
Off[$MaxExtraPrecision::"meprec"];

s=FullSimplify/@ToExact/@NetEdgeLengths[Tetrahedron4Compound,"C3"]

sides=Sort[Union[s],Less]

lengths=Sort[Transpose[{s/.Thread[sides->Range[Length[sides]]],NetEdges[Tetrahedron4Compound,"C3"]}]]

Show[Graphics[NetDiagram[Tetrahedron4Compound,"C3"]],AspectRatio->Automatic,
PlotRange->All]

Sort[Union[NetEdgeLengths[Tetrahedron4Compound,"C3"]//FullSimplify],Less]

NetPieces[Tetrahedron4Compound,"C3"]

NetSurfaceArea[Tetrahedron4Compound,"C3"]//FullSimplify

N[%]

PolyhedronSymmetricSurfaceArea[Polyhedron[Tetrahedron]]

N[%]

{"TetrahedronFourCompound", 2} from PolyhedronRotationCompound[PolyhedronData["Tetrahedron", "Polyhedron"], "Face", 4]

Graphics3D[PolyhedronRotationCompound[PolyhedronData["Tetrahedron","Polyhedron"],"Face",4,Debug->True]]

{"TetrahedronFourCompound", 3} from PolyhedronRotationCompound[PolyhedronData["Tetrahedron", "Polyhedron"], "Face"]

Graphics3D[PolyhedronRotationCompound[PolyhedronData["Tetrahedron","Polyhedron"],"Face",Debug->True]]

{"TetrahedronFourCompound", 3} pieces

<<SolidGeometry`;
<<Simplify`;
Off[$MaxExtraPrecision::"meprec"];

poly=Flatten[Polyhedron[Tetrahedron4Compound,"C3"]];

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

Timing[Length[lines=FaceIntersections[poly]]]

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

Timing[Length[p=First/@Union[Select[DeleteCases[points,{}],#[[1]].#[[1]]≤.8&]]]]

Timing[Length[p2=Union[Map[Simplify,p,{2}]]]]

Show[Graphics3D[{Polyhedron[Tetrahedron4Compound,"C3"],
PointSize[.005],
Point/@p2,
MapIndexed[Text[#2[[1]],#1+{0,0,.02},Background->White]&,p2]
}],Boxed->False,ViewPoint->{1,0,1}]

Triangle

t1=p2[[{79,135,72}]]

u1=Map[ToExact,Polygon2D[t1][[1]],{3}]

t2=p2[[{79,137,72}]]

u2=Map[ToExact,Polygon2D[t2][[1]],{3}]

Show[Graphics[piece3=ClosedLine/@{u1,{#[[1]],-#[[2]]}&/@u2}],AspectRatio->Automatic]

Complicated Piece

q3=p2[[{138,11,141,137,72,135,71,136}]]

Sort[Union[FullSimplify[Sqrt[#.#]&/@Subtract@@@Partition[q3,2,1,1]]],Less]

N[%]

q3=p2[[RotateLeft[{138,11,141,137,72,135,71,136}]]]

Sort[Union[FullSimplify[Sqrt[#.#]&/@Subtract@@@Partition[q3,2,1,1]]],Less]

N[%]

InputForm[r3=Map[ToExact,Polygon2D[q3][[1]],{3}]]

Big Triangle

InputForm[q4=p2[[{79,97,95}]]]

Crashes v4.2, so use v5.0

InputForm[r4=Map[ToExact,Polygon2D[q4][[1]],{3}]]

r3={{0, 0}, {3/10, (3*Sqrt[3])/10}, {2/7, Sqrt[3]/7}, {2/9, 1/(3*Sqrt[3])}, 
 {9/32, (3*Sqrt[3])/32}, {5/18, 1/(6*Sqrt[3])}, {5/14, Sqrt[3]/14}, {3/5, 0}};

q2=p2[[{71,136,79}]]

Sqrt[#.#]&[Subtract@@p2[[{71,79}]]]

InputForm[r2=Map[ToExact,Polygon2D[q2][[1]],{3}]]

r2={{0, 0}, {1/(18*Sqrt[7]), Sqrt[7/3]/18 + 1/(9*Sqrt[21])}, {2/(9*Sqrt[7]), 0}};

q1=RotateLeft[p2[[{136,79,96,138}]],2]

InputForm[r1=Map[ToExact,Polygon2D[q1][[1]],{3}]]

Show[Graphics[piece1={
ClosedLine/@Table[RotationMatrix[n Pi/3].#&/@r3,{n,4,6}]
}],AspectRatio->Automatic]

Show[Graphics[piece2=ClosedLine/@{
r5=({1/3,0}+RotationMatrix[Pi/3].(#-{1/3,0}))&/@r1,
{1/3-#[[1]],#[[2]]}&/@r5,
r4}],AspectRatio->Automatic]

Sqrt[#.#]&[Subtract@@r2[[{1,3}]]]

Show[Graphics[piece3=ClosedLine/@{
r2,
{#[[1]],-#[[2]]}&/@r2
}],
AspectRatio->Automatic]

Show[Graphics[net={
piece1,
piece2/.Line[x_]:>Line[#+{1,0}&/@x],
piece3/.Line[x_]:>Line[#+{2-1/8,1/8}&/@x]
}],AspectRatio->Automatic]

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

net2={Line[{{0,0},{-(3/5),0},{-(5/14),((Sqrt[3])/14)},{-(5/18),(1/(6 (Sqrt[3])))},{-(9/32),((3 (Sqrt[3]))/32)},{-(2/9),(1/(3 (Sqrt[3])))},{-(2/7),((Sqrt[3])/7)},{-(3/10),((3 (Sqrt[3]))/10)},{0,0}}],Line[{{0,0},{-(3/10),((3 (Sqrt[3]))/10)},{-(1/14),((3 (Sqrt[3]))/14)},{-(1/18),(1/(2 (Sqrt[3])))},{0,((3 (Sqrt[3]))/16)},{(1/18),(1/(2 (Sqrt[3])))},{(1/14),((3 (Sqrt[3]))/14)},{(3/10),((3 (Sqrt[3]))/10)},{0,0}}],Line[{{0,0},{(3/10),((3 (Sqrt[3]))/10)},{(2/7),((Sqrt[3])/7)},{(2/9),(1/(3 (Sqrt[3])))},{(9/32),((3 (Sqrt[3]))/32)},{(5/18),(1/(6 (Sqrt[3])))},{(5/14),((Sqrt[3])/14)},{(3/5),0},{0,0}}],Line[{{(7/6),(1/(2 (Sqrt[3])))},{(47/30),(1/(2 (Sqrt[3])))},{(61/42),(1/(14 (Sqrt[3])))},{(4/3),0},{(7/6),(1/(2 (Sqrt[3])))}}],Line[{{(7/6),(1/(2 (Sqrt[3])))},{(23/30),(1/(2 (Sqrt[3])))},{(37/42),(1/(14 (Sqrt[3])))},{1,0},{(7/6),(1/(2 (Sqrt[3])))}}],Line[{{1,0},{(7/6),(1/(2 (Sqrt[3])))},{(4/3),0},{1,0}}],Line[{{(15/8),(1/8)},{(187/96),(1/32) (4+(Sqrt[3]))},{(143/72),(1/8)},{(15/8),(1/8)}}],Line[{{(15/8),(1/8)},{(331/168),(1/168) (21-8 (Sqrt[3]))},{(143/72),(1/8)},{(15/8),(1/8)}}]};

Show[Graphics[{Take[net2,-2],p3=(Take[net2,-2]/.Line[x_]:>Line[{5-1/2-#[[1]],#[[2]]}&/@x])}],AspectRatio->Automatic]

net3=Join[net2,p3]

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

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

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

v//InputForm

Show[Graphics[NetDiagram[Tetrahedron4Compound,"C3"]],AspectRatio->Automatic]

<<Simplify`
Off[$MaxExtraPrecision::"meprec"];

s=FullSimplify/@ToExact/@NetEdgeLengths[Tetrahedron4Compound,"C3"]

sides=Sort[Union[s],Less]

lengths=Sort[Transpose[{s/.Thread[sides->Range[Length[sides]]],NetEdges[Tetrahedron4Compound,"C3"]}]]

Show[Graphics[NetDiagram[Tetrahedron4Compound,"C3"]],AspectRatio->Automatic,
PlotRange->All]

Sort[Union[NetEdgeLengths[Tetrahedron4Compound,"C3"]//FullSimplify],Less]

NetPieces[Tetrahedron4Compound,"C3"]

NetSurfaceArea[Tetrahedron4Compound,"C3"]//FullSimplify

N[%]

PolyhedronSymmetricSurfaceArea[Polyhedron[Tetrahedron]]

N[%]

{"TetrahedronFourCompound", 4} from VertexSubsetCompound[{"CubeTwoCompound", 1}, "Tetrahedron"]

compound=VertexSubsetCompound[{"CubeTwoCompound",1},"Tetrahedron"]

Graphics3D[compound]

(hulls=VertexSubsetHulls[compound,"Platonic"])//Timing

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

{"TetrahedronFourCompound", 5} from VertexSubsetCompound[{"CubeTwoCompound", 2}, "Tetrahedron"]

compound=VertexSubsetCompound[{"CubeTwoCompound",2},"Tetrahedron"]

Graphics3D[compound]

(hulls=VertexSubsetHulls[compound,"Platonic"])//Timing

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

{"TetrahedronFourCompound", 6} from VertexSubsetCompound[{"CubeTwoCompound", 3},"Tetrahedron"]]

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

PolyhedronData

PolyhedronDataString

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

WriteString[file,With[
{
base="Tetrahedron",
n=4,
facecnt=PolyhedronFaceCount[compound],
ind=6
},
PolyhedronDataString[compound,
"StandardName"->{base<>Capitalize[IntegerName[n]]<>"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]