Midsphere

Author

Eric W. Weisstein
May 19, 2020

This notebook downloaded from http://mathworld.wolfram.com/notebooks/SolidGeometry/Midsphere.nb.

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

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

Platonic

V5

Show[GraphicsArray[DualSpheresPlot[Flatten[Polyhedron[#]],Through[{Inradius,Midradius,Circumradius}[#]]]&/@Platonics
],GraphicsSpacing->-.1]//Timing

V6

Graphics3D[{Opacity[0.5],{Yellow,PolyhedronData[#,"Faces"]},{Red,PolyhedronData[#,"Midsphere"]}}]&/@PolyhedronData["Platonic"]

Archimedean

V5

Show[GraphicsArray[DualSpheresPlot[CuboctahedronExact//N,{3/4,Sqrt[3]/2,1}]]]

Show[GraphicsArray[DualSpheresPlot[TruncatedCubeExact//N,{Sqrt[7+4Sqrt[2]](5+2Sqrt[2])/17,(2+Sqrt[2])/2,Sqrt[7+4Sqrt[2]]/2}]]]

Show[GraphicsArray[DualSpheresPlot[TruncatedIcosahedronExact//N,{9/872(21+Sqrt[5])Sqrt[58+18Sqrt[5]],
3/4(1+Sqrt[5]),
1/4Sqrt[58+18Sqrt[5]]}]]]

V6

Graphics3D[{Opacity[0.5],{Yellow,PolyhedronData[#,"Faces"]},{Red,PolyhedronData[#,"Midsphere"]}}]&/@PolyhedronData["Archimedean"]

Archimedean Dual

Graphics3D[{Opacity[0.5],{Yellow,PolyhedronData[#,"Faces"]},{Red,PolyhedronData[#,"Midsphere"]}}]&/@PolyhedronData["ArchimedeanDual"]

Compute

Missing

missing=Select[PolyhedronData[All],PolyhedronData[#,"Midsphere"]===Missing["NotAvailable"]&]

"AcuteGoldenRhombohedron"

Graphics3D[p=PolyhedronData["AcuteGoldenRhombohedron","Polyhedron"]]

Midsphere[p//N]//Timing

Midsphere[p,"Simplification"->Identity]//Timing

Midsphere[p,"Simplification"->Together]//Timing

Midsphere[p,"Simplification"->Function[Numerator[Together[#]]]]//Timing

Midsphere[p,"Simplification"->Function[FullSimplify[Numerator[Together[#]]]]]//Timing

Midsphere[p,"Simplification"->FullSimplify]//Timing

TimeConstrained[Midsphere[p,"Simplification"->RootReduce],30]//Timing

TimeConstrained[Midsphere[p,"Simplification"->Function[FullSimplify[Together[#]]]],30]//Timing

{"Antiprism", 4}

Graphics3D[p=PolyhedronData[{"Antiprism",4},"Polyhedron"]]

Midsphere[p//N]//Timing

(s=Midsphere[p,"Simplification"->Identity])//Timing

(s=Midsphere[p,"Simplification"->Together])//Timing

(s=Midsphere[p,"Simplification"->Expand])//Timing

(s=Midsphere[p,"Simplification"->Function[FullSimplify[Numerator[Together[#]]]]])//Timing

PolyhedronData[{"Antiprism",4},"Midsphere"]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"Antiprism", 5}

Graphics3D[p=PolyhedronData[{"Antiprism",5},"Polyhedron"]]

Midsphere[p//N]//Timing

(s=Midsphere[p,Method->"PointLineDistance",Debug->True,"Simplification"->Identity])//Timing

(s=Midsphere[p,Method->"PointLineDistance",Debug->True,"Simplification"->Function[Numerator[Together[#]]]])//Timing

(s=Midsphere[p,Method->"PointLineDistance","Simplification"->FullSimplify])//Timing

(s=Midsphere[p,Method->"PointsTangentAndPerpendicular"])//Timing

TimeConstrained[Midsphere[p,"Simplification"->Expand],30]//Timing

TimeConstrained[Midsphere[p,"Simplification"->Identity],30]//Timing

PolyhedronData[{"Antiprism",5},"Midsphere"]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"Antiprism", 6}

Graphics3D[p=PolyhedronData[{"Antiprism",6},"Polyhedron"]]

(s=Midsphere[p,"Simplification"->Together])//Timing

PolyhedronData[{"Antiprism",6},"Midsphere"]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"Antiprism", 7}

Graphics3D[p=PolyhedronData[{"Antiprism",7},"Polyhedron"]]

Midsphere[p//N]

TimeConstrained[(s=Midsphere[p,"Simplification"->Together]),30]//Timing

TimeConstrained[(s=Midsphere[p,"Simplification"->Function[RootReduce[Together[#]]]]),30]//Timing

s=PolyhedronData[{"Antiprism",7},"Midsphere"]

N[%]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"Antiprism", 8}

Graphics3D[p=PolyhedronData[{"Antiprism",8},"Polyhedron"]]

Midsphere[p//N]

(s=Midsphere[p])//Timing

N[s]

s=PolyhedronData[{"Antiprism",8},"Midsphere"]

N[%]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"Antiprism", 9}

Graphics3D[p=PolyhedronData[{"Antiprism",9},"Polyhedron"]]

Midsphere[p//N]

(s=Midsphere[p,Debug->True,"Simplification"->Function[RootReduce[Expand[#]]]])//Timing

(s=Midsphere[p,Debug->True])//Timing

s=PolyhedronData[{"Antiprism",9},"Midsphere"]

N[%]

Midsphere[p//N]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"Antiprism", 10}

Graphics3D[p=PolyhedronData[{"Antiprism",10},"Polyhedron"]]

Midsphere[p//N]

(s=Midsphere[p,Debug->True])//Timing

Midsphere[p//N]

s=PolyhedronData[{"Antiprism",10},"Midsphere"]

N[%]

Midsphere[p//N]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"AugmentedDodecahedron"

Graphics3D[p=PolyhedronData["AugmentedDodecahedron","Polyhedron"]]

Midsphere[p//N]//Timing

TimeConstrained[s=Midsphere[p],30]//Timing

TimeConstrained[s=Midsphere[p,Method->"PointLineDistance",Debug->True],30]//Timing

TimeConstrained[s=Midsphere[p,Method->"PointLineDistance","Simplification"->FullSimplify,Debug->True],300]//Timing

"AugmentedHexagonalPrism"

Graphics3D[p=PolyhedronData["AugmentedHexagonalPrism","Polyhedron"]]

Midsphere[p]//Timing

TimeConstrained[Midsphere[p,"Simplification"->FullSimplify],30]//Timing

TimeConstrained[Midsphere[p,"Simplification"->Function[FullSimplify[Numerator@Together[#]]]],30]//Timing

TimeConstrained[Midsphere[p,"Simplification"->Identity],30]//Timing

"AugmentedPentagonalPrism"

Graphics3D[p=PolyhedronData["AugmentedPentagonalPrism","Polyhedron"]]

Midsphere[p]//Timing

"AugmentedSphenocorona"

Graphics3D[p=PolyhedronData["AugmentedSphenocorona","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"AugmentedTriangularPrism"

Graphics3D[p=PolyhedronData["AugmentedTriangularPrism","Polyhedron"]]

Midsphere[p]//Timing

"AugmentedTridiminishedIcosahedron"

Graphics3D[p=PolyhedronData["AugmentedTridiminishedIcosahedron","Polyhedron"]]

Midsphere[p]//Timing

"AugmentedTruncatedCube"

Graphics3D[p=PolyhedronData["AugmentedTruncatedCube","Polyhedron"]]

Midsphere[p]//Timing

"AugmentedTruncatedDodecahedron"

PolyhedronData["AugmentedTruncatedDodecahedron","Midsphere"]

Graphics3D[p=PolyhedronData["AugmentedTruncatedDodecahedron","Polyhedron"]]

Midsphere[p,Debug->True]//Timing

"AugmentedTruncatedTetrahedron"

Graphics3D[p=PolyhedronData["AugmentedTruncatedTetrahedron","Polyhedron"]]

Midsphere[p]//Timing

"BigyrateDiminishedRhombicosidodecahedron"

PolyhedronData["BigyrateDiminishedRhombicosidodecahedron","Midsphere"]

Graphics3D[p=PolyhedronData["BigyrateDiminishedRhombicosidodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True])//Timing

s=PolyhedronData["SmallRhombicosidodecahedron","Midsphere"]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"BiaugmentedPentagonalPrism"

Graphics3D[p=PolyhedronData["BiaugmentedPentagonalPrism","Polyhedron"]]

Midsphere[p]//Timing

"BiaugmentedTriangularPrism"

Graphics3D[p=PolyhedronData["BiaugmentedTriangularPrism","Polyhedron"]]

Midsphere[p]//Timing

"BiaugmentedTruncatedCube"

Graphics3D[p=PolyhedronData["BiaugmentedTruncatedCube","Polyhedron"]]

Midsphere[p]//Timing

"BilinskiDodecahedron"

Midsphere[p=PolyhedronData["BilinskiDodecahedron","Polyhedron"]]//Timing

Graphics3D[p]

"Bilunabirotunda"

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

Midsphere[p]//Timing

"CsaszarPolyhedron"

Graphics3D[p=PolyhedronData["CsaszarPolyhedron","Polyhedron"]]

Midsphere[p]//Timing

"Cube"

(s=Midsphere[p=PolyhedronData["Cube","Polyhedron"],Debug->True])//Timing

(s=Midsphere[p=PolyhedronData["Cube","Polyhedron"],Method->"PointLineDistance",Debug->True])//Timing

PolyhedronData["Cube","Midsphere"]

Graphics3D[{Opacity[.7],Yellow,s,Red,p=PolyhedronData["Cube","Polyhedron"]}]

"CubeFiveCompound"

(s=Midsphere[p=PolyhedronData["CubeFiveCompound","Polyhedron"],Debug->True])//Timing

Graphics3D[{Opacity[.7],Yellow,s=Sphere[{0,0,0},(1/(Sqrt[2]))],Red,p=PolyhedronData["CubeFiveCompound","Polyhedron"]}]

{"CubeFourCompound", 1}

(s=Midsphere[p=PolyhedronData[{"CubeFourCompound",1},"Polyhedron"]])//Timing

Graphics3D[{s,p}]

{"CubeFourCompound", 2}

(s=Midsphere[p=PolyhedronData[{"CubeFourCompound",2},"Polyhedron"]])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"CubeOctahedronCompound"

(s=Midsphere[p=PolyhedronData["CubeOctahedronCompound","Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"CubeOctahedronFiveCompound"

Graphics3D[p=PolyhedronData["CubeOctahedronFiveCompound","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

s=PolyhedronData["CubeOctahedronFiveCompound","Midsphere"]

Graphics3D[{Red,s,Opacity[.6],Yellow,p}]

PolyhedronData["CubeOctahedronFiveCompound","EdgeLengths"]

Graphics3D[{Opacity[.6],Yellow,s,Red,#}]&/@PolyhedronData["CubeOctahedronFiveCompound","Polyhedra"]

Graphics3D[{Red,s,Opacity[.4],Yellow,p}]

"CubeOctahedronThreeCompound"

(s=Midsphere[p=PolyhedronData["CubeOctahedronThreeCompound","Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"CubeSixCompound"

(s=Midsphere[p=PolyhedronData["CubeSixCompound","Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"CubeTenCompound"

(s=Midsphere[p=PolyhedronData["CubeTenCompound","Polyhedron"],Debug->True])//Timing

Graphics3D[{Opacity[.7],Yellow,s=Sphere[{0,0,0},(1/(Sqrt[2]))],Red,p=PolyhedronData["CubeTenCompound","Polyhedron"]}]

"CubeThreeCompound"

(s=Midsphere[p=PolyhedronData["CubeThreeCompound","Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"CubeTwoCompound", 1}

PolyhedronData[{"CubeTwoCompound",1},"Midradius"]

(s=Midsphere[p=PolyhedronData[{"CubeTwoCompound",1},"Polyhedron"],Debug->True]//FullSimplify)//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"CubeTwoCompound", 2}

s=Midsphere[p=PolyhedronData[{"CubeTwoCompound",2},"Polyhedron"]]

Graphics3D[{p,s}]

"Cuboctahedron"

(s=Midsphere[p=PolyhedronData["Cuboctahedron","Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"CuboctahedronStellation", 1}

(s=Midsphere[p=PolyhedronData[{"CuboctahedronStellation",1},"Polyhedron"]])//Timing

Graphics3D[p]

"DeltoidalHexecontahedron"

40+ GB and probably a lot more than that

Graphics3D[p=PolyhedronData["DeltoidalHexecontahedron","Polyhedron"]]

Midsphere[p//N]

TimeConstrained[s=Midsphere[p],60]//Timing

s=PolyhedronData["DeltoidalHexecontahedron","Midsphere"]

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"DeltoidalIcositetrahedron"

Graphics3D[p=PolyhedronData["DeltoidalIcositetrahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

PolyhedronData["DeltoidalIcositetrahedron","Midsphere"]

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"DiminishedRhombicosidodecahedron"

Graphics3D[p=PolyhedronData["DiminishedRhombicosidodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

s=PolyhedronData["SmallRhombicosidodecahedron","Midsphere"]//FullSimplify

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

{"Dipyramid", 3}

PolyhedronData[{"Dipyramid",3},"Midsphere"]

Graphics3D[p=PolyhedronData[{"Dipyramid",3},"Polyhedron"]]

(s=Midsphere[p,Debug->False])//Timing

{"Dipyramid", 4}

PolyhedronData[{"Dipyramid",4},"Midsphere"]

s=Midsphere[p=PolyhedronData[{"Dipyramid",4},"Polyhedron"],Debug->True]

Graphics3D[{Opacity[.5],Yellow,Sphere[{0,0,0},.47],Red,p}]

{"Dipyramid", 5}

Graphics3D[p=PolyhedronData[{"Dipyramid",5},"Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"DisdyakisDodecahedron"

Graphics3D[p=PolyhedronData["DisdyakisDodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

PolyhedronData["DisdyakisDodecahedron","Midsphere"]

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"DisdyakisTriacontahedron"

Graphics3D[p=PolyhedronData["DisdyakisTriacontahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

PolyhedronData["DisdyakisTriacontahedron","Midradius"]//FullSimplify

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"Disphenocingulum"

Graphics3D[p=PolyhedronData["Disphenocingulum","Polyhedron"]]

Midsphere[p//N]

p[[1]]

(s=Midsphere[p,Debug->True])//Timing

"Dodecahedron"

(s=Midsphere[p=PolyhedronData["Dodecahedron","Polyhedron"],Debug->True])//Timing

PolyhedronData["Dodecahedron","Midradius"]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"DodecahedronFiveCompound"

Graphics3D[p=PolyhedronData["DodecahedronFiveCompound","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

s=PolyhedronData["Dodecahedron","Midsphere"]

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

Graphics3D[{Opacity[.6],Yellow,s,Red,#}]&/@PolyhedronData["DodecahedronFiveCompound","Polyhedra"]

"DodecahedronIcosahedronCompound"

Graphics3D[p=PolyhedronData["DodecahedronIcosahedronCompound","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

s=PolyhedronData[#,"Midsphere"]&/@{"Dodecahedron","Icosahedron"}

Graphics3D[{Opacity[.6],Yellow,s[[1]],Red,#}]&/@PolyhedronData["DodecahedronIcosahedronCompound","Polyhedra"]

"DodecahedronSixCompound"

Graphics3D[p=PolyhedronData["DodecahedronSixCompound","Polyhedron"]]

(s=Midsphere[p,Debug->True])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

s=PolyhedronData["Dodecahedron","Midsphere"]

Graphics3D[{Opacity[.6],Yellow,s,Red,#}]&/@PolyhedronData["DodecahedronSixCompound","Polyhedra"]

"DodecahedronSmallTriambicIcosahedronCompound"

Graphics3D[p=PolyhedronData["DodecahedronSmallTriambicIcosahedronCompound","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

s=PolyhedronData[#,"Midsphere"]&/@{"SmallTriambicIcosahedron","Dodecahedron"}

Graphics3D[{Opacity[.6],Yellow,s[[2]],Red,#}]&/@PolyhedronData["DodecahedronSmallTriambicIcosahedronCompound","Polyhedra"]

"DodecahedronSmallTriambicIcosahedronCompoundHull"

Graphics3D[p=PolyhedronData["DodecahedronSmallTriambicIcosahedronCompoundHull","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

{"DodecahedronStellation", 1}

Graphics3D[p=PolyhedronData[{"DodecahedronStellation",1},"Polyhedron"]]

(s=Midsphere[p=PolyhedronData[{"DodecahedronStellation",1},"Polyhedron"],"Simplification"->FullSimplify,Debug->True])//Timing

Midsphere[PolyhedronData[{"DodecahedronStellation",1},"Polyhedron"]//N]

N[(3+Sqrt[5])/4]

s=Sphere[{0,0,0},(3+Sqrt[5])/4]

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

{"DodecahedronStellation", 2}

Graphics3D[p=PolyhedronData[{"DodecahedronStellation",2},"Polyhedron"]]

(s=Midsphere[p=PolyhedronData[{"DodecahedronStellation",2},"Polyhedron"],Debug->True]//FullSimplify)//Timing

{"DodecahedronStellation", 3}

Graphics3D[p=PolyhedronData[{"DodecahedronStellation",3},"Polyhedron"]]

Graphics3D[{Opacity[.5],Take[PolyhedronData[{"DodecahedronStellation",3},"Polygons"],14]}]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

{(1/4) (1+(Sqrt[5])),GoldenRatio/2}//N

Graphics3D[{Red,s,Opacity[.54],Yellow,p}]

Graphics3D[{Red,s,Yellow,Opacity[.5],Take[PolyhedronData[{"DodecahedronStellation",3},"Polygons"],14]}]

"DodecahedronTwoCompound"

(s=Midsphere[p=PolyhedronData["DodecahedronTwoCompound","Polyhedron"],Debug->True]//FullSimplify)//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"DuererSolid"

PolyhedronData["DuererSolid","Midsphere"]

(s=Midsphere[p=PolyhedronData["DuererSolid","Polyhedron"]])//FullSimplify//Timing

Graphics3D[p]

"Echidnahedron"

Graphics3D[p=PolyhedronData["Echidnahedron","Polyhedron"]]

Midsphere[p//N]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"ElongatedDodecahedron"

Graphics3D[p=PolyhedronData["ElongatedDodecahedron","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"ElongatedPentagonalCupola"

Graphics3D[p=PolyhedronData["ElongatedPentagonalCupola","Polyhedron"]]

(s=Midsphere[p])//Timing

"ElongatedPentagonalDipyramid"

Graphics3D[p=PolyhedronData["ElongatedPentagonalDipyramid","Polyhedron"]]

(s=Midsphere[p])//Timing

"ElongatedPentagonalGyrobicupola"

Graphics3D[p=PolyhedronData["ElongatedPentagonalGyrobicupola","Polyhedron"]]

(s=Midsphere[p])//Timing

"ElongatedPentagonalGyrobirotunda"

Graphics3D[p=PolyhedronData["ElongatedPentagonalGyrobirotunda","Polyhedron"]]

(s=Midsphere[p])//Timing

"ElongatedPentagonalGyrocupolarotunda"

Graphics3D[p=PolyhedronData["ElongatedPentagonalGyrocupolarotunda","Polyhedron"]]

(s=Midsphere[p])//Timing

"ElongatedPentagonalOrthobicupola"

Graphics3D[p=PolyhedronData["ElongatedPentagonalOrthobicupola","Polyhedron"]]

(s=Midsphere[p])//Timing

"ElongatedPentagonalOrthobirotunda"

Graphics3D[p=PolyhedronData["ElongatedPentagonalOrthobirotunda","Polyhedron"]]

(s=Midsphere[p])//Timing

"ElongatedPentagonalOrthocupolarotunda"

Graphics3D[p=PolyhedronData["ElongatedPentagonalOrthocupolarotunda","Polyhedron"]]

(s=Midsphere[p])//Timing

"ElongatedPentagonalPyramid"

Graphics3D[p=PolyhedronData["ElongatedPentagonalPyramid","Polyhedron"]]

(s=Midsphere[p])//Timing

"ElongatedPentagonalRotunda"

Graphics3D[p=PolyhedronData["ElongatedPentagonalRotunda","Polyhedron"]]

(s=Midsphere[p])//Timing

"ElongatedSquareCupola"

Graphics3D[p=PolyhedronData["ElongatedSquareCupola","Polyhedron"]]

(s=Midsphere[p,Debug->True])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"ElongatedSquareDipyramid"

Graphics3D[p=PolyhedronData["ElongatedSquareDipyramid","Polyhedron"]]

(s=Midsphere[p])//Timing

"ElongatedSquareGyrobicupola"

Graphics3D[p=PolyhedronData["ElongatedSquareGyrobicupola","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"ElongatedSquarePyramid"

Graphics3D[p=PolyhedronData["ElongatedSquarePyramid","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"ElongatedTriangularCupola"

Graphics3D[p=PolyhedronData["ElongatedTriangularCupola","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"ElongatedTriangularDipyramid"

Graphics3D[p=PolyhedronData["ElongatedTriangularDipyramid","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"ElongatedTriangularGyrobicupola"

Graphics3D[p=PolyhedronData["ElongatedTriangularGyrobicupola","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"ElongatedTriangularOrthobicupola"

Graphics3D[p=PolyhedronData["ElongatedTriangularOrthobicupola","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"ElongatedTriangularPyramid"

Graphics3D[p=PolyhedronData["ElongatedTriangularPyramid","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"EquilateralAugmentedCube"

PolyhedronData["EquilateralAugmentedCube","Midsphere"]

Graphics3D[p=PolyhedronData["EquilateralAugmentedCube","Polyhedron"]]

(s=Midsphere[p])//Timing

"EquilateralAugmentedTetrahedron"

PolyhedronData["EquilateralAugmentedTetrahedron","Midsphere"]

Graphics3D[p=PolyhedronData["EquilateralAugmentedTetrahedron","Polyhedron"]]

(s=Midsphere[p])//Timing

"EscherSolid"

PolyhedronData["EscherSolid","Midsphere"]

Graphics3D[p=PolyhedronData["EscherSolid","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"GreatDodecahedron"

Graphics3D[p=PolyhedronData["GreatDodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

N[%24]

GoldenRatio/2.

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"GreatIcosahedron"

Graphics3D[p=PolyhedronData["GreatIcosahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

N[(1/4) (-1+(Sqrt[5]))]

1/(2.GoldenRatio)

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"GreatRhombicosidodecahedron"

PolyhedronData["GreatRhombicosidodecahedron","Midradius"]

(s=Midsphere[p=PolyhedronData["GreatRhombicosidodecahedron","Polyhedron"],Debug->True])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"GreatRhombicTriacontahedron"

(s=Midsphere[p=PolyhedronData["GreatRhombicTriacontahedron","Polyhedron"]])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"GreatRhombicuboctahedron"

(s=Midsphere[p=PolyhedronData["GreatRhombicuboctahedron","Polyhedron"]])//FullSimplify//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"GreatStellatedDodecahedron"

(s=Midsphere[p=PolyhedronData["GreatStellatedDodecahedron","Polyhedron"]])//Timing

Midsphere[N[p=PolyhedronData["GreatStellatedDodecahedron","Polyhedron"],20]]

N[1-GoldenRatio/2,20]

s=Sphere[{0,0,0},1-GoldenRatio/2]

Graphics3D[{Opacity[.6],Red,s,Yellow,p}]

"GyrateBidiminishedRhombicosidodecahedron"

Graphics3D[p=PolyhedronData["GyrateBidiminishedRhombicosidodecahedron","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"GyrateRhombicosidodecahedron"

Graphics3D[p=PolyhedronData["GyrateRhombicosidodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

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

s=PolyhedronData["SmallRhombicosidodecahedron","Midsphere"]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

s=PolyhedronData["SmallRhombicosidodecahedron","Midsphere"]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"Gyrobifastigium"

Graphics3D[p=PolyhedronData["Gyrobifastigium","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"GyroelongatedPentagonalBicupola"

Graphics3D[p=PolyhedronData["GyroelongatedPentagonalBicupola","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"GyroelongatedPentagonalBirotunda"

Graphics3D[p=PolyhedronData["GyroelongatedPentagonalBirotunda","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"GyroelongatedPentagonalCupola"

Graphics3D[p=PolyhedronData["GyroelongatedPentagonalCupola","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"GyroelongatedPentagonalCupolarotunda"

PolyhedronData["GyroelongatedPentagonalCupolarotunda","Midsphere"]

Graphics3D[p=PolyhedronData["GyroelongatedPentagonalCupolarotunda","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"GyroelongatedPentagonalPyramid"

Graphics3D[p=PolyhedronData["GyroelongatedPentagonalPyramid","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"GyroelongatedPentagonalRotunda"

Graphics3D[p=PolyhedronData["GyroelongatedPentagonalRotunda","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"GyroelongatedSquareBicupola"

Graphics3D[p=PolyhedronData["GyroelongatedSquareBicupola","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"GyroelongatedSquareCupola"

Graphics3D[p=PolyhedronData["GyroelongatedSquareCupola","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"GyroelongatedSquareDipyramid"

Graphics3D[p=PolyhedronData["GyroelongatedSquareDipyramid","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"GyroelongatedSquarePyramid"

Graphics3D[p=PolyhedronData["GyroelongatedSquarePyramid","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"GyroelongatedTriangularBicupola"

Graphics3D[p=PolyhedronData["GyroelongatedTriangularBicupola","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"GyroelongatedTriangularCupola"

Graphics3D[p=PolyhedronData["GyroelongatedTriangularCupola","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"Hebesphenomegacorona"

Graphics3D[p=PolyhedronData["Hebesphenomegacorona","Polyhedron"]]

PolyhedronCoordinates[p]

(s=Midsphere[p]//FullSimplify)//Timing

"Icosahedron"

(s=Midsphere[p=PolyhedronData["Icosahedron","Polyhedron"],Debug->True]//FullSimplify)//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"IcosahedronFiveCompound"

PolyhedronData["IcosahedronFiveCompound","Midsphere"]

(s=Midsphere[p=PolyhedronData["IcosahedronFiveCompound","Polyhedron"],Debug->True]//FullSimplify)//Timing

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

PolyhedronData["IcosahedronFiveCompound","Midsphere"]

Graphics3D[{Opacity[.6],Yellow,s=Sphere[{0,0,0},(1/4) (1+(Sqrt[5]))],Red,p=PolyhedronData["IcosahedronFiveCompound","Polyhedron"]}]

"IcosahedronSixCompound"

Graphics3D[p=PolyhedronData["IcosahedronSixCompound","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

s=PolyhedronData["Icosahedron","Midsphere"]

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

Graphics3D[{Red,s,Opacity[.3],Yellow,#},Boxed->False]&/@PolyhedronData["IcosahedronSixCompound","Polyhedra"]

{"IcosahedronStellation", 3}

Graphics3D[p=PolyhedronData[{"IcosahedronStellation",3},"Polyhedron"]]

Graphics3D/@PolyhedronData[{"IcosahedronStellation",3},"Polygons"]

(s=Midsphere[p]//FullSimplify)//Timing

Midsphere[N[p,50]]

N[1+GoldenRatio/2,50]

s=Sphere[{0,0,0},1+GoldenRatio/2]

Graphics3D[{Opacity[.7],Red,s,Yellow,p}]

{"IcosahedronStellation", 11}

Graphics3D[p=PolyhedronData[{"IcosahedronStellation",11},"Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"IcosahedronTwoCompound"

Graphics3D[p=PolyhedronData["IcosahedronTwoCompound","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

s=PolyhedronData["Icosahedron","Midsphere"]

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"Icosidodecahedron"

(s=Midsphere[p=PolyhedronData["Icosidodecahedron","Polyhedron"],Debug->True]//FullSimplify)//Timing

PolyhedronData["Icosidodecahedron","Midsphere"]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"IcosidodecahedronStellation", 1}

PolyhedronData[{"IcosidodecahedronStellation",1},"Midradius"]

Graphics3D[p=PolyhedronData[{"IcosidodecahedronStellation",1},"Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"JessensOrthogonalIcosahedron"

Graphics3D[p=PolyhedronData["JessensOrthogonalIcosahedron","Polyhedron"]]

(s=Midsphere[p])//Timing

"MathematicaPolyhedron"

PolyhedronData["MathematicaPolyhedron","Midsphere"]

Graphics3D[p=PolyhedronData["MathematicaPolyhedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"MetabiaugmentedDodecahedron"

Graphics3D[p=PolyhedronData["MetabiaugmentedDodecahedron","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"MetabiaugmentedHexagonalPrism"

Graphics3D[p=PolyhedronData["MetabiaugmentedHexagonalPrism","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"MetabiaugmentedTruncatedDodecahedron"

Graphics3D[p=PolyhedronData["MetabiaugmentedTruncatedDodecahedron","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"MetabidiminishedIcosahedron"

Graphics3D[p=PolyhedronData["MetabidiminishedIcosahedron","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"MetabidiminishedRhombicosidodecahedron"

Graphics3D[p=PolyhedronData["MetabidiminishedRhombicosidodecahedron","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"MetabigyrateRhombicosidodecahedron"

Graphics3D[p=PolyhedronData["MetabigyrateRhombicosidodecahedron","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"MetagyrateDiminishedRhombicosidodecahedron"

Graphics3D[p=PolyhedronData["MetagyrateDiminishedRhombicosidodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

s=PolyhedronData["SmallRhombicosidodecahedron","Midsphere"]//FullSimplify

Graphics3D[{Opacity[.7],Red,s,Yellow,p}]

"ObtuseGoldenRhombohedron"

PolyhedronData["ObtuseGoldenRhombohedron","Midsphere"]

Midsphere[p=PolyhedronData["ObtuseGoldenRhombohedron","Polyhedron"]]//Timing

Graphics3D[p]

"Octahedron"

(s=Midsphere[p=PolyhedronData["Octahedron","Polyhedron"],Method->"PointsTangentAndPerpendicular"])//Timing

(s=Midsphere[p=PolyhedronData["Octahedron","Polyhedron"],Method->"PointLineDistance"])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"OctahedronThreeCompound"

(s=Midsphere[p=PolyhedronData["OctahedronThreeCompound","Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"OctahedronFiveCompound"

PolyhedronData["OctahedronFiveCompound","Midsphere"]

Graphics3D[p=PolyhedronData["OctahedronFiveCompound","Polyhedron"]]

(s=Midsphere[p=PolyhedronData["OctahedronFiveCompound","Polyhedron"],Debug->True]//FullSimplify)//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

s=PolyhedronData["Octahedron","Midsphere"]

Graphics3D[{Opacity[.7],Yellow,s,Red,#}]&/@PolyhedronData["OctahedronFiveCompound","Polyhedra"]

"OctahedronTenCompound"

(s=Midsphere[p=PolyhedronData["OctahedronTenCompound","Polyhedron"],Debug->True])//Timing

Graphics3D[{Red,s=Sphere[{0,0,0},(1/2)],Opacity[.2],Yellow,p=PolyhedronData["OctahedronTenCompound","Polyhedron"]}]

"OctahedronThreeCompound"

(s=Midsphere[p=PolyhedronData["OctahedronThreeCompound","Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"OctahedronFourCompound", 1}

(s=Midsphere[p=PolyhedronData[{"OctahedronFourCompound",1},"Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"OctahedronFourCompound", 2}

(s=Midsphere[p=PolyhedronData[{"OctahedronFourCompound",2},"Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"ParabiaugmentedDodecahedron"

Graphics3D[p=PolyhedronData["ParabiaugmentedDodecahedron","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"ParabiaugmentedHexagonalPrism"

Graphics3D[p=PolyhedronData["ParabiaugmentedHexagonalPrism","Polyhedron"]]

(s=Midsphere[p]//FullSimplify)//Timing

"ParabiaugmentedTruncatedDodecahedron"

PolyhedronData["ParabiaugmentedTruncatedDodecahedron","Midsphere"]

Graphics3D[p=PolyhedronData["ParabiaugmentedTruncatedDodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"ParabidiminishedRhombicosidodecahedron"

Graphics3D[p=PolyhedronData["ParabidiminishedRhombicosidodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

PolyhedronData["SmallRhombicosidodecahedron","Midsphere"]//FullSimplify

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

s=Sphere[{0,0,0},(Sqrt[(5/2)+(Sqrt[5])])];

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"ParabigyrateRhombicosidodecahedron"

Graphics3D[p=PolyhedronData["ParabigyrateRhombicosidodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

s=PolyhedronData["SmallRhombicosidodecahedron","Midsphere"]//FullSimplify

Graphics3D[{Opacity[.6],Yellow,s,Red,#}]&/@PolyhedronData["ParabigyrateRhombicosidodecahedron","Polyhedra"]

"ParagyrateDiminishedRhombicosidodecahedron"

Graphics3D[p=PolyhedronData["ParagyrateDiminishedRhombicosidodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

s=PolyhedronData["SmallRhombicosidodecahedron","Midsphere"]//FullSimplify

Graphics3D[{Opacity[.6],Yellow,s,Red,#}]&/@PolyhedronData["ParagyrateDiminishedRhombicosidodecahedron","Polyhedra"]

"PentagonalCupola"

Graphics3D[p=PolyhedronData["PentagonalCupola","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"PentagonalGyrobicupola"

Graphics3D[p=PolyhedronData["PentagonalGyrobicupola","Polyhedron"]]

(s=Midsphere[p])//Timing

"PentagonalGyrocupolarotunda"

Graphics3D[p=PolyhedronData["PentagonalGyrocupolarotunda","Polyhedron"]]

(s=Midsphere[p])//Timing

"PentagonalHexecontahedron"

PolyhedronData["PentagonalHexecontahedron","Vertices"]

Graphics3D[p=PolyhedronData["PentagonalHexecontahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"PentagonalIcositetrahedron"

Graphics3D[p=PolyhedronData["PentagonalIcositetrahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

s=RootReduce[s]

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"PentagonalOrthobicupola"

Graphics3D[p=PolyhedronData["PentagonalOrthobicupola","Polyhedron"]]

(s=Midsphere[p])//Timing

"PentagonalOrthobirotunda"

Graphics3D[p=PolyhedronData["PentagonalOrthobirotunda","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"PentagonalOrthocupolarotunda"

Graphics3D[p=PolyhedronData["PentagonalOrthocupolarotunda","Polyhedron"]]

(s=Midsphere[p])//Timing

"PentagonalPrismSixCompound"

(s=Midsphere[p=PolyhedronData["PentagonalPrismSixCompound","Polyhedron"],Debug->True])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

s=PolyhedronData["PentagonalPrism","Midsphere"]

Graphics3D[{Opacity[.6],Yellow,s,Red,#}]&/@PolyhedronData["PentagonalPrismSixCompound","Polyhedra"]

"PentagonalRotunda"

Graphics3D[p=PolyhedronData["PentagonalRotunda","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"PentakisDodecahedron"

Graphics3D[p=PolyhedronData["PentakisDodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

{"Prism", {6, 2}}

PolyhedronData[{"Prism",{6,2}},"Midsphere"]

(s=Midsphere[p=PolyhedronData[{"Prism",{6,2}},"Polyhedron"]])//Timing

{"Prism", {8, 2}}

PolyhedronData[{"Prism",{8,2}},"Midsphere"]

(s=Midsphere[p=PolyhedronData[{"Prism",{8,2}},"Polyhedron"]])//Timing

{"Pyramid", 4}

PolyhedronData[{"Pyramid",4},"Midsphere"]

s=Midsphere[p=PolyhedronData[{"Pyramid",4},"Polyhedron"],1,Debug->True]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

s=Midsphere[p=PolyhedronData[{"Pyramid",4},"Polyhedron"]]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"Pyramid", 5}

Graphics3D[p=PolyhedronData[{"Pyramid",5},"Polyhedron"]]

(s=Midsphere[p=PolyhedronData[{"Pyramid",5},"Polyhedron"],1,Debug->True])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

(s=Midsphere[p=PolyhedronData[{"Pyramid",5},"Polyhedron"],Debug->True])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"RhombicDodecahedron"

(s=Midsphere[p=PolyhedronData["RhombicDodecahedron","Polyhedron"],Debug->True])//Timing

PolyhedronData["RhombicDodecahedron","Midsphere"]

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

{"RhombicDodecahedronStellation", 1}

Graphics3D[p=PolyhedronData[{"RhombicDodecahedronStellation",1},"Polyhedron"]]

(s=Midsphere[p])//Timing

{"RhombicDodecahedronStellation", 2}

Graphics3D[p=PolyhedronData[{"RhombicDodecahedronStellation",2},"Polyhedron"]]

(s=Midsphere[p])//Timing

{"RhombicDodecahedronStellation", 3}

Graphics3D[p=PolyhedronData[{"RhombicDodecahedronStellation",3},"Polyhedron"]]

(s=Midsphere[p])//Timing

"RhombicEnneacontahedron"

Graphics3D[p=PolyhedronData["RhombicEnneacontahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"RhombicHexecontahedron"

Graphics3D[p=PolyhedronData["RhombicHexecontahedron","Polyhedron"]]

(s=Midsphere[p])//Timing

"RhombicIcosahedron"

Graphics3D[p=PolyhedronData["RhombicIcosahedron","Polyhedron"]]

Midsphere[p]//Timing

"RhombicTriacontahedron"

Graphics3D[p=PolyhedronData["RhombicTriacontahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"SmallRhombicosidodecahedron"

(s=Midsphere[p=PolyhedronData["SmallRhombicosidodecahedron","Polyhedron"],Debug->True])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"SmallRhombicuboctahedron"

(s=Midsphere[p=PolyhedronData["SmallRhombicuboctahedron","Polyhedron"],Debug->True])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"SmallStellatedDodecahedron"

Graphics3D[p=PolyhedronData["SmallStellatedDodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"SmallTriakisOctahedron"

(s=Midsphere[p=PolyhedronData["SmallTriakisOctahedron","Polyhedron"],Debug->True]//FullSimplify)//Timing

PolyhedronData["SmallTriakisOctahedron","Midsphere"]

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"SmallTriambicIcosahedron"

(s=Midsphere[p=PolyhedronData["SmallTriambicIcosahedron","Polyhedron"],Debug->True])//Timing

Graphics3D[{Opacity[.7],Yellow,s={},Red,p=PolyhedronData["SmallTriambicIcosahedron","Polyhedron"]}]

"SnubCube"

(s=Midsphere[p=PolyhedronData["SnubCube","Polyhedron"],Debug->True])//FullSimplify//Timing

bug((HyperlinkTemplate[393069, https://bugs.wolfram.com/show?number=393069None, https://bugs.wolfram.com/show?number=393069, HyperlinkActionRecycled, HyperlinkActive, , ])): Graphics3D[Sphere[{0, 0, 0}, Root[{1 + 5 # + 7 #^2 + #^3& , # + 4 #2^2& }, {1, 2}]]] pinks and gives badge of shame

r=Root[{1+5 #+7 #^2+#^3&,#+4 #2^2&},{1,2}];

Graphics3D[Sphere[{0,0,0},r]]

N[r]

r2=RootReduce[r]

PolyhedronData["SnubCube","Midsphere"]

Graphics3D[Sphere[{0,0,0},r2]]

Graphics3D[{Opacity[.7],Yellow,s=Sphere[{0,0,0},r2],Red,p=PolyhedronData["SnubCube","Polyhedron"]}]

"SnubDodecahedron"

(s=Midsphere[p=PolyhedronData["SnubDodecahedron","Polyhedron"]])//FullSimplify//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"SnubDisphenoid"

Graphics3D[p=PolyhedronData["SnubDisphenoid","Polyhedron"]]

(s=Midsphere[p])//Timing

"SnubSquareAntiprism"

Graphics3D[p=PolyhedronData["SnubSquareAntiprism","Polyhedron"]]

PolyhedronCoordinates[p]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"Sphenocorona"

Graphics3D[p=PolyhedronData["Sphenocorona","Polyhedron"]]

(s=Midsphere[p])//Timing

"Sphenomegacorona"

Graphics3D[p=PolyhedronData["Sphenomegacorona","Polyhedron"]]

(s=Midsphere[p])//Timing

"SquareCupola"

Graphics3D[p=PolyhedronData["SquareCupola","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"SquareGyrobicupola"

Graphics3D[p=PolyhedronData["SquareGyrobicupola","Polyhedron"]]

(s=Midsphere[p])//Timing

"SquareOrthobicupola"

Graphics3D[p=PolyhedronData["SquareOrthobicupola","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"StellatedOctahedron"

(s=Midsphere[p=PolyhedronData["StellatedOctahedron","Polyhedron"]])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"SzilassiPolyhedron"

Graphics3D[p=PolyhedronData["SzilassiPolyhedron","Polyhedron"]]

Midsphere[p]//Timing

"TetragonalAntiwedge"

SOlved by hand but not yet automatically

PolyhedronData["TetragonalAntiwedge","VertexCoordinates"]

Graphics3D[p=PolyhedronData["TetragonalAntiwedge","Polyhedron"]]

(s=Midsphere[p,Debug->True])//Timing

sapprox=Midsphere[N[p,250]]

r=RootApproximant[sapprox[[-1]]]

r-sapprox[[-1]]

FullSimplify[r]

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

N[%,20]

vertices=p[[1]]

edges=Union[Sort/@Join@@(Partition[#,2,1,1]&/@p[[2]])]

n=Length[edges]

v=edges/.i_Integer:>vertices[[i]];

s=.

eqn1=Table[#.#&[v[[i,1]]-s[i] Subtract@@v[[i]]-{0,0,0}]-r^2,{i,n}]//RootReduce

ssolnN=NSolve[Thread[eqn1==0],Array[s,10]]//Union

ssoln=Solve[Thread[eqn1==0],Array[s,10]]//Union

ssoln1=SimplifyNumericallyDistinct[ssoln,Debug->True,"Simplification"->RootReduce]

eqn2=RootReduce[Table[Dot[-Subtract@@v[[i]],v[[i,1]]-s[i] Subtract@@v[[i]]-{0,0,0}],{i,n}]]

eqn2/.ssolnN[[1]]//Chop

RootReduce[eqn2/.ssoln[[1]]]

s=Sphere[{0,0,0},((Sqrt[1+(Sqrt[GoldenRatio])])/2)]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"TetragonalDisphenoidSixCompound"

Graphics3D[p=PolyhedronData["TetragonalDisphenoidSixCompound","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

"Tetrahedron"

Graphics3D[p=PolyhedronData["Tetrahedron","Polyhedron"]]

Asked Adam 2020-05-18:

This is expected. There is more equations than variables, so whether you get any solutions depends on what rational coefficients get chosen when the system is rationalized.

In[9]:= GroebnerBasis[Rationalize[eqns, 0], {x, y, z, r}//Reverse]
Out[9]= {1}

In[10]:= GroebnerBasis[Rationalize[eqns, 10^-6], {x, y, z, r}//Reverse]
                           2
Out[10]= {x, y, z, -1 + 8 r }

Midsphere[p//N[#,20]&,Debug->True]

Midsphere[p//N,Debug->True]

eqns={0.0625-0.5 (r)^2+0.816497 z+1. (z)^2,-0.408248 y+1. y z,-0.408248 x+1. x z,0.0625-0.5 (r)^2-0.57735 x+1. (y)^2-0.408248 z,-0.57735 y+1. x y,0.0625-0.5 (r)^2+0.57735 x+1. (x)^2-0.408248 z,-1.125 z+1. (r)^2 z,-1.125 y+1. (r)^2 y,-1.125 x+1. (r)^2 x,0.140625-1.25 (r)^2+1. (r)^4};

eqns/.{x->0,y->0,z->0,r->(1/(2 (Sqrt[2])))}

Solve[Append[Thread[eqns==0],r>0],{x,y,z,r}]

s=Midsphere[p,1]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

s=Midsphere[p=PolyhedronData["Tetrahedron","Polyhedron"],All,Method->"PointsTangentAndPerpendicular"]

s=Midsphere[p=PolyhedronData["Tetrahedron","Polyhedron"],All,Method->"PointLineDistance"]

s=Midsphere[p=PolyhedronData["Tetrahedron","Polyhedron"],1,Method->"PointLineDistance"]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"TetrahedronFiveCompound"

PolyhedronData["TetrahedronFiveCompound","Midsphere"]

Graphics3D[p=PolyhedronData["TetrahedronFiveCompound","Polyhedron"]]

(s=Midsphere[p,Debug->True])//Timing

s=PolyhedronData["Tetrahedron","Midsphere"]

Graphics3D[{Opacity[.7],Yellow,s,Red,#}]&/@PolyhedronData["TetrahedronFiveCompound","Polyhedra"]

{"TetrahedronFourCompound", 1}

(s=Midsphere[p=PolyhedronData[{"TetrahedronFourCompound",1},"Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

{"TetrahedronFourCompound", 2}

(s=Midsphere[p=PolyhedronData[{"TetrahedronFourCompound",2},"Polyhedron"],Debug->True])//Timing

Graphics3D[{Opacity[.7],Yellow,s=Sphere[{0,0,0},(1/(2 (Sqrt[2])))],Red,p=PolyhedronData[{"TetrahedronFourCompound",2},"Polyhedron"]}]

{"TetrahedronFourCompound", 3}

(s=Midsphere[p=PolyhedronData[{"TetrahedronFourCompound",3},"Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"TetrahedronSixCompound"

Graphics3D[p=PolyhedronData["TetrahedronSixCompound","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"TetrahedronTenCompound"

PolyhedronData["TetrahedronTenCompound","Midsphere"]

Graphics3D[p=PolyhedronData["TetrahedronTenCompound","Polyhedron"]]

p[[1]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

s=PolyhedronData["Tetrahedron","Midsphere"]

Graphics3D[{Opacity[.7],Yellow,s,Red,#}]&/@PolyhedronData["TetrahedronTenCompound","Polyhedra"]

"TetrahedronThreeCompound"

(s=Midsphere[p=PolyhedronData["TetrahedronThreeCompound","Polyhedron"],Debug->True])//Timing

Graphics3D[{Opacity[.7],Yellow,s=Sphere[{0,0,0},(1/(2 (Sqrt[2])))],Red,p=PolyhedronData["TetrahedronThreeCompound","Polyhedron"]}]

{"TetrahedronTwoCompound", 1}

PolyhedronData[{"TetrahedronTwoCompound",1},"Midsphere"]

(s=Midsphere[p=PolyhedronData[{"TetrahedronTwoCompound",1},"Polyhedron"]])//Timing

Graphics3D[{Opacity[.6],Red,s,Yellow,p}]

{"TetrahedronTwoCompound", 2}

PolyhedronData[{"TetrahedronTwoCompound",2},"Midsphere"]

(s=Midsphere[p=PolyhedronData[{"TetrahedronTwoCompound",2},"Polyhedron"]])//Timing

Graphics3D[{Opacity[.6],Red,s,Yellow,p}]

"TetrakisHexahedron"

(s=Midsphere[p=PolyhedronData["TetrakisHexahedron","Polyhedron"],Debug->True]//FullSimplify)//Timing

PolyhedronData["TetrakisHexahedron","Midsphere"]

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"TrapezoRhombicDodecahedron"

Graphics3D[p=PolyhedronData["TrapezoRhombicDodecahedron","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"TriakisIcosahedron"

Graphics3D[p=PolyhedronData["TriakisIcosahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True]//FullSimplify)//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"TriakisTetrahedron"

(s=Midsphere[p=PolyhedronData["TriakisTetrahedron","Polyhedron"],Debug->True]//FullSimplify)//Timing

PolyhedronData["TriakisTetrahedron","Midsphere"]

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"TriakisTruncatedTetrahedron"

Graphics3D[p=PolyhedronData["TriakisTruncatedTetrahedron","Polyhedron"]]

(s=Midsphere[p])//Timing

"TriangularCupola"

Graphics3D[p=PolyhedronData["TriangularCupola","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"TriangularHebesphenorotunda"

Graphics3D[p=PolyhedronData["TriangularHebesphenorotunda","Polyhedron"]]

(s=Midsphere[p])//Timing

"TriangularOrthobicupola"

Graphics3D[p=PolyhedronData["TriangularOrthobicupola","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.6],Yellow,s,Red,p}]

"TriaugmentedDodecahedron"

Graphics3D[p=PolyhedronData["TriaugmentedDodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True])//Timing

"TriaugmentedHexagonalPrism"

Graphics3D[p=PolyhedronData["TriaugmentedHexagonalPrism","Polyhedron"]]

(s=Midsphere[p])//Timing

"TriaugmentedTriangularPrism"

Graphics3D[p=PolyhedronData["TriaugmentedTriangularPrism","Polyhedron"]]

(s=Midsphere[p])//Timing

"TriaugmentedTruncatedDodecahedron"

Graphics3D[p=PolyhedronData["TriaugmentedTruncatedDodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True])//FullSimplify//Timing

"TridiminishedIcosahedron"

Graphics3D[p=PolyhedronData["TridiminishedIcosahedron","Polyhedron"]]

(s=Midsphere[p])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"TridiminishedRhombicosidodecahedron"

Graphics3D[p=PolyhedronData["TridiminishedRhombicosidodecahedron","Polyhedron"]]

s=PolyhedronData["SmallRhombicosidodecahedron","Midsphere"]//FullSimplify

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"TrigyrateRhombicosidodecahedron"

Graphics3D[p=PolyhedronData["TrigyrateRhombicosidodecahedron","Polyhedron"]]

(s=Midsphere[p,Debug->True])//Timing

s=PolyhedronData["SmallRhombicosidodecahedron","Midsphere"]//FullSimplify

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"TruncatedCube"

(s=Midsphere[p=PolyhedronData["TruncatedCube","Polyhedron"]])//FullSimplify//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"TruncatedDodecahedron"

(s=Midsphere[p=PolyhedronData["TruncatedDodecahedron","Polyhedron"],Debug->True])//Timing

PolyhedronData["TruncatedDodecahedron","Midsphere"]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"TruncatedIcosahedron"

(s=Midsphere[p=PolyhedronData["TruncatedIcosahedron","Polyhedron"]])//Timing

PolyhedronData["TruncatedIcosahedron","Midradius"]

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"TruncatedOctahedron"

(s=Midsphere[p=PolyhedronData["TruncatedOctahedron","Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]

"TruncatedTetrahedron"

(s=Midsphere[p=PolyhedronData["TruncatedTetrahedron","Polyhedron"]])//Timing

Graphics3D[{Opacity[.7],Yellow,s,Red,p}]