Hexagrammic Prism

Author

Eric W. Weisstein
September 21, 2023

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

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

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

Variants

variants=PolyhedronData["HexagrammicPrism*"]

GraphicsRow[Graphics3D[{PolyhedronData[#,"Polyhedron"]},Boxed->False]&/@variants,Dividers->All]

Polyhedron: "HexagrammicPrismHull"

PolyhedronData["HexagrammicPrismHull"]

Polyhedron

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

Solid and Dual

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

Net

PolyhedronData["HexagrammicPrismHull","Net"]

PolyhedronData["HexagrammicPrismHull","Net","Colored"]

Properties

Initialization

<<MathWorld`Polyhedra`

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

AdjacentFaceIndices

PolyhedronData["HexagrammicPrismHull","AdjacentFaceIndices"]

AdjacentFaceIndices[p]===%

Centroid

Graphics3D[{AbsolutePointSize[10],
Point[{0,0,0}],{Blue,Point[PolyhedronData[pname,"Centroid"]]},Opacity[.2],PolyhedronData[pname,"GraphicsComplex"]}]

PolyhedronData[pname,"Centroid"]

RegionCentroid[p]

PolyhedronCentroid[p]

Circumsphere

PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

(sphere=MyCircumsphere[p])//Timing

SimplifyNumericallyDistinct[Norm/@PolyhedronData["HexagrammicPrismHull","VertexCoordinates"]]//Union

Convex

ConvexPolyhedronQ[p]

SimplifyNumericallyDistinct[Norm/@PolyhedronData["HexagrammicPrismHull","VertexCoordinates"]]//Union

DihedralAngles

PolyhedronData[pname,"DihedralAngles"]//Tally

DihedralAngles[p]//FullSimplify//Tally

EdgeCount

PolyhedronData["HexagrammicPrismHull","Lines"]//Length

EdgeLengths

PolyhedronData[pname,"EdgeLengths"]

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

Faces

Rule@@@Tally[Length/@PolyhedronData["HexagrammicPrismHull","FaceIndices"]]

GeneralizedDiameter

PolyhedronData["HexagrammicPrismHull","GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify//Quiet

GeneralizedDiameter

PolyhedronData[pname,"GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify//Quiet

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

((MomentOfInertia[p,{0,0,0}])/(Volume[p]))//RootReduce

PolyhedronInertiaTensor[p,Debug->True]

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

MeanCylindricalRadius

((NIntegrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"]))//Timing

(i=((Integrate[(Sqrt[(x^2)+(y^2)]),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"])))//Timing

N[i]

MeanSquareCylindricalRadius

((NIntegrate[(x^2)+(y^2),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"]))//Timing

(i=((Integrate[(x^2)+(y^2),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"])))//Timing

N[i]

MeanSphericalRadius

((NIntegrate[(Sqrt[(x^2)+(y^2)+(z^2)]),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"]))//Timing

(i=((Integrate[(Sqrt[(x^2)+(y^2)+(z^2)]),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"])))//Timing

N[i]

MeanSquareSphericalRadius

((NIntegrate[(x^2)+(y^2)+(z^2),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"]))//Timing

(i=((Integrate[(x^2)+(y^2)+(z^2),{x,y,z}∈p])/(PolyhedronData[pname,"Volume"])))//Timing

N[i]

Midsphere

sphere=PolyhedronData[pname,"Midsphere"]

(sphere=Midsphere[p])//Timing

Net

PolyhedronData["HexagrammicPrismHull","Net"]

RegionFunction

reg=PolyhedronData["HexagrammicPrismHull","RegionFunction"]

bounds=RegionBounds[ImplicitRegion[Evaluate[N[reg[x,y,z]]],{x,y,z}]]

ranges=Flatten/@Transpose[{{x,y,z},.1{-1,1}+#&/@bounds}]

RegionPlot3D[Evaluate[N[reg[x,y,z]]],Evaluate[Sequence@@ranges],BoxRatios->Automatic,PlotPoints->40]

ranges=Flatten/@Transpose[{{x,y,z},.1{-1,1}+#&/@bounds}]

c=CirclePoints[{(Sqrt[3]),0},6];

Graphics[{ClosedLine/@(tris=Transpose[Partition[c,2]]),MapIndexed[Text[#2[[1]],#,Background->White]&,c]}]

Or@@Table[And@@PolyhedronInequalities[Polygon/@{Append[#,1/2]&/@tris[[i]],
Append[#,-1/2]&/@Reverse[tris[[i]]],
Sequence@@({Append[#2,-1/2],Append[#2,1/2],Append[#1,1/2],Append[#1,-1/2]}&@@@Partition[tris[[i]],2,1,1])},{x,y,z}],{i,2}]//FullSimplify

Skeleton

g=PolyhedronData["HexagrammicPrismHull","Skeleton"]

r=RecognizeGraph[g]

GraphData[r,"Graph","All"]

ToCommonEdges[GraphData[r],g]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

RootReduce[%]

SurfaceArea[p]//RootReduce

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

VertexSubsetHulls

PolyhedronData[pname,"VertexSubsetHulls"]

Platonic

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

Volume

PolyhedronData[pname,"Volume"]

Volume[p]//FullSimplify

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

Perspective projections

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

XXX

PolyhedronProjectionGraph[PolyhedronData["DuererSolid","Polyhedron"],]

Construction: {6, 2} = Hexagram

c=CirclePoints[{(Sqrt[3]),0},6];

Graphics[{ClosedLine/@Transpose[Partition[c,2]],MapIndexed[Text[#2[[1]],#,Background->White]&,c]}]

EuclideanDistance@@c[[{1,3}]]

p=RegionIntersection[Line[c[[{1,3}]]],Line[c[[{2,-1}]]]][[1,1]]//FullSimplify

r=Norm[p]//FullSimplify

1/EuclideanDistance[c[[1]],p]//FullSimplify

Graphics[{EdgeForm[Black],FaceForm[LightYellow],Polygon/@Transpose[Partition[c,2]],AbsolutePointSize[5],Point[c2=CirclePoints[{r,π/6},6]]}]

Table[Graphics[Polygon[Flatten[Transpose[{c,RotateRight[c2,i]}],1]]],{i,0,4}]

Graphics[{EdgeForm[Black],FaceForm[LightYellow],Polygon[top=Flatten[Transpose[{c,c2}],1]]}]

Length[top]

v=Join[Append[#,1/2]&/@top,Append[#,-1/2]&/@top]//FullSimplify

v={{(Sqrt[3]),0,(1/2)},{((Sqrt[3])/2),(1/2),(1/2)},{((Sqrt[3])/2),(3/2),(1/2)},{0,1,(1/2)},{-((Sqrt[3])/2),(3/2),(1/2)},{-((Sqrt[3])/2),(1/2),(1/2)},{-(Sqrt[3]),0,(1/2)},{-((Sqrt[3])/2),-(1/2),(1/2)},{-((Sqrt[3])/2),-(3/2),(1/2)},{0,-1,(1/2)},{((Sqrt[3])/2),-(3/2),(1/2)},{((Sqrt[3])/2),-(1/2),(1/2)},{(Sqrt[3]),0,-(1/2)},{((Sqrt[3])/2),(1/2),-(1/2)},{((Sqrt[3])/2),(3/2),-(1/2)},{0,1,-(1/2)},{-((Sqrt[3])/2),(3/2),-(1/2)},{-((Sqrt[3])/2),(1/2),-(1/2)},{-(Sqrt[3]),0,-(1/2)},{-((Sqrt[3])/2),-(1/2),-(1/2)},{-((Sqrt[3])/2),-(3/2),-(1/2)},{0,-1,-(1/2)},{((Sqrt[3])/2),-(3/2),-(1/2)},{((Sqrt[3])/2),-(1/2),-(1/2)}};

SmallestRotation[l_]:=Sort[NestList[RotateRight,l,Length[l]-1]][[1]]

faces=Sort[SmallestRotation/@{Range[12],Reverse@Range[13,24],{24,13,1,12},Sequence@@Table[{i+12,i+13,i+1,i},{i,11}]}]

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

Graphics3D[{FaceForm[Green,Red],Polyhedron[v,faces]}]

Graphics3D[{FaceForm[Green,Red],p=Polyhedron[v,faces],MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]

Graphics3D[{FaceForm[Green,Red],Polygon[#[{{0,0,0},{1,0,0},{0,1,0}}]]}]&/@{Identity,Reverse}

vv=Take[v,12]

Graphics3D[{FaceForm[Green,Red],Polygon[#[vv]]}]&/@{Identity,Reverse}

Graphics3D[{FaceForm[Green,Red],Polygon[N@#[vv]]}]&/@{Identity,Reverse}

pentagram=Table[Append[Through[{Cos,Sin}[2π i/5]],0],{i,1,10,2}];

Graphics3D[{FaceForm[Green,Red],Polygon[#[pentagram]]}]&/@{Identity,Reverse}