Small Triakis Octahedron

Author

Eric W. Weisstein
January 5, 2024

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

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

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

Figure

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

Solid

PolyhedronData["SmallTriakisOctahedron","Orientations"]

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

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,{"SmallTriakisOctahedron"}}
],
Dividers->All,ImageSize->800,Alignment->Top
]

Augmentation

Graphics3D/@Table[AugmentedPolyhedron[PolyhedronData["SmallTriakisOctahedron","Polyhedron"],x],{x,-1,1,.2}]

Net

PolyhedronData["SmallTriakisOctahedron","Net"]

PolyhedronData["SmallTriakisOctahedron","Net","Colored"]

NetPrintout[PolyhedrdonData["SmallTriakisOctahedron","Polyhedron"],"SmallTriakisOctahedron.pdf"]

Properties

Initialization

<<MathWorld`Polyhedra`

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

vol=PolyhedronData[pname,"Volume"]

Centroid

PolyhedronData[pname,"Centroid"]

RegionCentroid[p]//FullSimplify

PolyhedronCentroid[p]//FullSimplify

Circumsphere

PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

MyCircumsphere[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->200]

DihedralAngles

PolyhedronData[pname,"DihedralAngles"]//Tally

DihedralAngles[p]//FullSimplify//Tally

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]

EdgeLengths

PolyhedronData[pname,"EdgeLengths"]

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

Faces

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

PolyhedronFaceCounts[poly]

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]//FullSimplify

MyInsphere[p]//FullSimplify//Timing

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

PolyhedronInertiaTensor[p]//Timing

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

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

Integrate over polyhedron

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

N[rxy]

Divergence theorem [unevaluated integral]

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

N[rxy]

LogSimplify[rxy]//FullSimplify

CAD

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

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

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

CAD over  1/16 [complicated unsimplified terms with large integer coefficients]

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

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

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

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

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

rxy=;

N[rxy,20]

ByteCount[rxy]

ByteCount[rxysimp=FullSimplify[rxy]]//Timing

<<MathWorld`Polyhedra`

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

ByteCount[rxysimp3=Simplify[rxysimp2]]//Timing

ByteCount[rxysimp4=FullSimplify[rxysimp3]]//Timing

rxysimp4

N[rxysimp4,20]

N[rxysimp4-rxy,10^5]

On 10/2/23 2:33 PM, Adam Strzebonski wrote:
> Hi Eric,
>
> Collect[TrigToExp[rxysimp], Log[_]] // RootReduce with some manual postprocessing gives:

Collect[TrigToExp[rxysimp2], Log[_]] // RootReduce

N[%]

rxyadam=(30+66*Sqrt[2]+9*(10+7*Sqrt[2])*Log[1+Sqrt[2]]-4*Sqrt[102+72*Sqrt[2]]*Log[10-6*Sqrt[2]-5*Sqrt[3]+4*Sqrt[6]])/432;

N[rxy-rxyadam,10^4]

rxyadam//Expand

(5/72)+(11/(36 (Sqrt[2])))+FullSimplify[(5/24) Log[1+(Sqrt[2])]+((7 Log[1+(Sqrt[2])])/(24 (Sqrt[2])))]-(1/108) (Sqrt[102+72 (Sqrt[2])]) Log[10-6 (Sqrt[2])-5 (Sqrt[3])+4 (Sqrt[6])]

N[%,20]

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

N[%]

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

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

N[i]

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

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

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

N[rxyz]

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

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

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

N[i]

Midsphere

PolyhedronData[pname,"Midsphere"]

Midsphere[p]//FullSimplify//Timing

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

RootReduce[%]

SurfaceArea[p]//FullSimplify//Timing

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

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,Method->"GaussLaw"]//FullSimplify

Perspective projections

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

{1,1,2 (1+(Sqrt[2])),π/4}

PolyhedronProjectionGraph[PolyhedronData["SmallTriakisOctahedron","Polyhedron"],{1,1,2 (1+(Sqrt[2])),π/4},VertexLabels->"Name"]

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

v=GraphEmbedding[g];

FullSimplify[CollinearPoints[v[[{8,11,14}]]],x>0]

Solve[%,x]//FullSimplify

N[%]

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

{1, 0, 1}

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

{0, 0, 1}

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

{1, 1, 1}

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

Construction

Solid

SmallTriakisOctahedronExact:=OrientCentered[Dual[Polyhedron[TruncatedCube],Method->Semiregular]]

Net

<<ExtraPackages`UnfoldPolytope`

UnfoldPolytope[Flatten[Normal[PolyhedronData["SmallTriakisOctahedron","Faces"]]]]

e=PolyhedronData["SmallTriakisOctahedron","EdgeLengths"]

PolyhedronData["SmallTriakisOctahedron","NetImage"]

x=e[[2]]/2;

y=Sqrt[1-x^2]//FullSimplify

Graphics[{FaceForm[LightYellow],EdgeForm[Black],Polygon[{{0,0},{x,y},{2x,0}}],
Polygon[{{0,0},{(1/8) (2+3 (Sqrt[2])),(Sqrt[(37/32)+(13/(8 (Sqrt[2])))])},{x,y}}],
Polygon[{{2x,0},{2x-(1/8) (2+3 (Sqrt[2])),(Sqrt[(37/32)+(13/(8 (Sqrt[2])))])},{x,y}}]
}]

α=ArcCos[{1,0}.Normalize[{x,y}]]//FullSimplify

RotationMatrix[2α].{2x,0}//FullSimplify

x2=x-(1/8) (2+3 (Sqrt[2]));

piece={Polygon[{{0,0},{x,y},{2x,0}}],
Polygon[{{0,0},{(1/8) (2+3 (Sqrt[2])),(Sqrt[(37/32)+(13/(8 (Sqrt[2])))])},{x,y}}],
Polygon[{{2x,0},{2x-(1/8) (2+3 (Sqrt[2])),(Sqrt[(37/32)+(13/(8 (Sqrt[2])))])},{x,y}}]};

Graphics[{FaceForm[LightYellow],EdgeForm[Black],piece}]

bigpiece[n_:0,m_:0]:=Flatten[{piece,piece/.Polygon[v_]:>Polygon[{1,-1}#&/@v]}]/.Polygon[v_]:>Polygon[({1,0}(2x+2x2) n+m{x+x2,(Sqrt[(37/32)+(13/(8 (Sqrt[2])))])}+#)&/@v];

Graphics[{LightYellow,EdgeForm[Black],g=Flatten[{bigpiece[#,0]&/@Range[0,2],bigpiece[#,1]&/@Range[0,2]}]}]

Graphics[{LightYellow,EdgeForm[Black],g2=Delete[g,List/@{4,5,6,16,17,18,19,20,21,31,32,33}]}]

gc=NetFromPolygon[FullSimplify[g2]]

Graphics[{{LightYellow,EdgeForm[Black],gc},MapIndexed[Text[#2[[1]],#,Background->White]&,SortBy[gc[[1]],N]]}]

PolyhedronData["SmallTriakisOctahedron","NetImage"]