Bilunabirotunda

Author

Eric W. Weisstein
May 12, 2021

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

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

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

Graphic

PolyhedronData (V11.1+)

PolyhedronData["Bilunabirotunda"]

PolyhedronData (pre V11.1)

PolyhedronData["Bilunabirotunda"]

Netlib

<<

PolyhedronName[JohnsonSolid[91]]

Show[Graphics3D[Polyhedron[JohnsonSolid[91]]],Boxed->False]

Net

PolyhedronData

PolyhedronData["Bilunabirotunda","Net"]

PolyhedronData["Bilunabirotunda","Net","Colored"]

Netlib

Show[Graphics[Net[JohnsonSolid[91]]],AspectRatio->Automatic]

Skeleton

With[{gc=PolyhedronData["Bilunabirotunda","Faces"]},{SkeletonGraph[gc],SkeletonGraph[gc,.8],SkeletonGraph[gc,1],SkeletonGraph[gc,2]}]

PolyhedronData["Bilunabirotunda","SkeletonGraph"]

PolyhedronData["Bilunabirotunda","SkeletonGraphName"]

GraphData[{"JohnsonSkeleton",91},"Graph","All"]

Construction

Netlib (numeric and weird orientation)

PolyhedronData["Bilunabirotunda","Faces"]

PolyhedronEdgeLengths[PolyhedronData["Bilunabirotunda","Faces"]]

GoldenRatio

gc=With[
{
x=(1/2)(GoldenRatio^2),
y=(1/2)GoldenRatio,
z=(1/2)GoldenRatio,
h=(1/2)
},
GraphicsComplex[{
{h,-h,-z},{h,-h,z},{-h,h,-z},{-h,h,z},{-h,-h,-z},{-h,-h,z},{h,h,-z},{h,h,z},{0,-y,0},{0,y,0},{-x,0,-h},{-x,0,h},{x,0,-h},{x,0,h}
},{Polygon[{4,6,2,8}],Polygon[{6,4,12}],Polygon[{2,6,9}],Polygon[{8,2,14}],Polygon[{4,8,10}],Polygon[{12,4,10,3,11}],Polygon[{6,12,11,5,9}],Polygon[{14,2,9,1,13}],Polygon[{8,14,13,7,10}],Polygon[{5,11,3}],Polygon[{9,5,1}],Polygon[{7,13,1}],Polygon[{10,7,3}],Polygon[{3,7,1,5}]}]];

Gosper (wrong)

(Wrong) embedding by
Bill Gosper
18 Sep 2016

gc=GraphicsComplex[{{0,-(1/Sqrt[2]),-(GoldenRatio/2)},{0,-(1/Sqrt[2]),GoldenRatio/2},{0,1/Sqrt[2],-(GoldenRatio/2)},{0,1/Sqrt[2],GoldenRatio/2},{-(1/Sqrt[2]),0,-(GoldenRatio/2)},{-(1/Sqrt[2]),0,GoldenRatio/2},{1/Sqrt[2],0,-(GoldenRatio/2)},{1/Sqrt[2],0,GoldenRatio/2},{-((1+Sqrt[5])/(4 Sqrt[2])),-((1+Sqrt[5])/(4 Sqrt[2])),0},{(1+Sqrt[5])/(4 Sqrt[2]),(1+Sqrt[5])/(4 Sqrt[2]),0},{-((3+Sqrt[5])/(4 Sqrt[2])),(3+Sqrt[5])/(4 Sqrt[2]),-((1+Sqrt[5])/(4 Sqrt[2]))},{-((3+Sqrt[5])/(4 Sqrt[2])),(3+Sqrt[5])/(4 Sqrt[2]),(1+Sqrt[5])/(4 Sqrt[2])},{(3+Sqrt[5])/(4 Sqrt[2]),-((3+Sqrt[5])/(4 Sqrt[2])),-((1+Sqrt[5])/(4 Sqrt[2]))},{(3+Sqrt[5])/(4 Sqrt[2]),-((3+Sqrt[5])/(4 Sqrt[2])),(1+Sqrt[5])/(4 Sqrt[2])}},{Polygon[{4,6,2,8}],Polygon[{6,4,12}],Polygon[{2,6,9}],Polygon[{8,2,14}],Polygon[{4,8,10}],Polygon[{12,4,10,3,11}],Polygon[{6,12,11,5,9}],Polygon[{14,2,9,1,13}],Polygon[{8,14,13,7,10}],Polygon[{5,11,3}],Polygon[{9,5,1}],Polygon[{7,13,1}],Polygon[{10,7,3}],Polygon[{3,7,1,5}]}];

wrong; edge lengths != 1

OrientedQ[Normal[gc]]

And@@First[%]

Graphics3D[{{AbsolutePointSize[10],Black,Point[{0,0,0}]},Opacity[.5],FaceForm[{Blue,Red}],Normal[gc]},AxesOrigin->{0,0,0},Axes->True]

EdgeLengths

PolyhedronEdgeLengths[gc]//FullSimplify

N[%]

EuclideanDistance@@@Union[Flatten[Normal[gc]/.Polygon[x_]:>Partition[x,2,1,1],1]]//FullSimplify//Union

edges={#[[1,1]],#[[All,2]]}&/@SplitBy[Sort[{FullSimplify[EuclideanDistance@@#],#}&/@Flatten[Normal[gc]/.Polygon[x_]:>Partition[x,2,1,1],1]],First];

Graphics3D[{MapIndexed[Text[#2[[1]],#,Background->White]&,gc[[1]]],Thick,Transpose[{{Green,Red,Blue},Line/@edges[[All,2]]}]},Boxed->False]

v[[{2,8}]]

FullSimplify[edges[[2]]]

N[%79[[2]]]

Compute

Pentagon chord

SquaredEuclideanDistance[{1,0},Through[{Cos,Sin}[2Pi/3]]]

soln=With[{p2={1/2,-1/2,z},p9={0,-y,0},p14={x,0,1/2},s=SquaredEuclideanDistance},
Solve[s[p2,p14]==1&&s[p9,p2]==1&&s[p9,p14]==GoldenRatio^2,{x,y,z}]][[2,All,2]]//FullSimplify

N[soln]

Graphics3D[gcnew=With[{x=(1/4) (3+(Sqrt[5])),y=(1/4) (1+(Sqrt[5])),z=(1/4) (1+(Sqrt[5])),h=1/2},
GraphicsComplex[{
{h,-h,-z},{h,-h,z},{-h,h,-z},{-h,h,z},{-h,-h,-z},{-h,-h,z},{h,h,-z},{h,h,z},{0,-y,0},{0,y,0},{-x,0,-h},{-x,0,h},{x,0,-h},{x,0,h}
},{Polygon[{4,6,2,8}],Polygon[{6,4,12}],Polygon[{2,6,9}],Polygon[{8,2,14}],Polygon[{4,8,10}],Polygon[{12,4,10,3,11}],Polygon[{6,12,11,5,9}],Polygon[{14,2,9,1,13}],Polygon[{8,14,13,7,10}],Polygon[{5,11,3}],Polygon[{9,5,1}],Polygon[{7,13,1}],Polygon[{10,7,3}],Polygon[{3,7,1,5}]}]]]

Show[PolyhedronData["Bilunabirotunda"]]

PolyhedronEdgeLengths[gcnew]//FullSimplify

Properties

<<MathWorld`PolyhedronOperations`

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

Centroid

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

PolyhedronData[pname,"Centroid"]

RegionCentroid[p]//FullSimplify

PolyhedronCentroid[p]//FullSimplify

Circumsphere

PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

sphere=MyCircumsphere[p]

Convex

ConvexPolyhedronQ[p]

DihedralAngles

PolyhedronData[pname,"DihedralAngles"]//Tally

DihedralAngles[p]//FullSimplify//Tally

EdgeLengths

PolyhedronData[pname,"EdgeLengths"]

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

Faces

GeneralizedDiameter

PolyhedronData[pname,"GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify//Quiet

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

PolyhedronInertiaTensor[p]//Timing

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

sphere=MyInsphere[p]

MeanCylindricalRadius

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

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

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

N[i]

MeanSphericalRadius

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

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

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

N[i]

Midsphere

PolyhedronData[pname,"Midsphere"]

Midsphere[p]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

RootReduce[%]

SurfaceArea[p]//FullSimplify//Timing

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

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

PolyhedronDataString

{skel=SkeletonGraph[gc],GraphData[{"JohnsonSkeleton",91}]}

PolyhedronVertices[gc]

PolyhedronFaces[gc]

PolyhedronEdgeLengths[gc]//FullSimplify

PolyhedronEdges[gc]

PolyhedronDataString[gc,
"StandardName"->"Bilunabirotunda",
"Name"->"bilunabirotunda",
Debug->True
]