Johnson Solid

Author

Eric W. Weisstein
December 13, 2018

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

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

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

All

GraphicsGrid[Partition[Table[Graphics3D[Tooltip[PolyhedronData[{"Johnson",n},"GraphicsComplex"],Column[{n,PolyhedronData[{"Johnson",n},"#"]}]],Boxed->False,Method->{"ShrinkWrap"->True}],{n,92}],UpTo[10]],ImageSize->500]

To do

Solids with inexact coordinates

todo=Select[PolyhedronData["Johnson"],!FreeQ[PolyhedronData[#,"Vertices"],_?InexactNumberQ]&]

Length[todo]

Graphics3D[Tooltip[PolyhedronData[#,"GraphicsComplex"],#],Boxed->False,Method->{"ShrinkWrap"->True}]&/@todo

Convexity check

bad=DeleteCases[{#,ConvexPolyhedronQ[PolyhedronData[#,"Polyhedron"]]}&/@PolyhedronData["Johnson"],{_,True}]

Complement[bad[[All,1]],todo]

Sorted

By VertexCount

TextGrid[{#[[1,1]],#[[All,2]]}&/@SplitBy[SortBy[PolyhedronData["Johnson",{"V","#"}],First],First],Dividers->All,Alignment->Left]

By Volume

TextGrid[{N[#],#,#2}&@@@SortBy[PolyhedronData["Johnson",{"Volume","#"}],N[First[#]]&],Dividers->All,Alignment->Left]

By Diameter

TextGrid[{N[#],#,#2}&@@@SortBy[PolyhedronData["Johnson",{"GeneralizedDiameter","#"}],N[First[#]]&],Dividers->All,Alignment->Left]

Sorted by Number of Vertices

v=Table[JohnsonSolidVertices[n],{n,92}];

Transpose[{Union[l=Length/@v],Distribution[l]}]

ColumnForm[{#,Position[l,#]//Flatten}&/@Union[l]]

Show[Graphics3D[JohnsonSolid[71]],Boxed->False]

Solids

JohnsonSolid::ID="`1`. `2`";
On[JohnsonSolid::ID];
Off[General::stop];
Do[
	Message[JohnsonSolid::ID,i,JohnsonSolidName[i]];
	WriteLiveForm["j"<>If[i<10,"0",""]<>ToString[i]<>".m",
	Show[JohnsonSolid[i],Boxed->False]],
	{i,92}]

Nets

Example

With[{n=18},
Show[GraphicsArray[Graphics[#,AspectRatio->Automatic]&/@
{ClosedLine@@@Net[JohnsonSolid[n]],ColoredNet[JohnsonSolid[n]]}]]
]

Show[Graphics[ColoredNet[18,Labeled->True],AspectRatio->Automatic]]

With[{n=69},
Show[GraphicsArray[Graphics[#,AspectRatio->Automatic]&/@
{ClosedLine@@@Net[JohnsonSolid[n]],ColoredNet[JohnsonSolid[n]]}]]
]

All

JohnsonSolid::ID="`1`. `2`";
On[JohnsonSolid::ID];
Off[General::stop];
Do[
	Message[JohnsonSolid::ID,i,JohnsonSolidName[i]];
	WriteLiveForm["j"<>If[i<10,"0",""]<>ToString[i]<>".m",
	Show[JohnsonSolidNet[i],AspectRatio->Automatic]],
	{i,92}]

Notebook Generation

dir=SetDirectory[ToFileName[{"~","Mathematica","Notebooks","Math","Polyhedra"}]]

Create

names=StringReplace[StringReplace[PolyhedronName[JohnsonSolid[#]],{WordBoundary~~x:WordCharacter:>ToUpperCase[x]," "->""}],RegularExpression["(.*)\\(.*"]->"$1"]<>".nb"&/@Range[92];

files=FileNames["*"];

new=Complement[names,files];

pos=Position[names,_?(MemberQ[new,#]&),1,Heads->False]//Flatten

JohnsonNotebook/@pos;

"\\download{Polyhedra}{"<>StringDrop[#,-3]<>"}"&/@new

Exact Construction

<<ExtraPackages`UnfoldPolytope`

JohnsonSolid[1]:=Pyramid[4]
JohnsonSolid[2]:=Pyramid[5] 
JohnsonSolid[3]:=Cupola[3]
JohnsonSolid[4]:=Cupola[4]
JohnsonSolid[5]:=Cupola[5]
JohnsonSolid[6]:=Rotunda[5]
JohnsonSolid[7]:=ElongatedPyramid[3]
JohnsonSolid[8]:=ElongatedPyramid[4] 
JohnsonSolid[9]:=ElongatedPyramid[5] 
JohnsonSolid[10]:=GyroelongatedPyramid[4] 
JohnsonSolid[11]:=GyroelongatedPyramid[5] 
JohnsonSolid[12]:=Dipyramid[3] 
JohnsonSolid[13]:=Dipyramid[5] 
JohnsonSolid[14]:=ElongatedDipyramid[3]
JohnsonSolid[15]:=ElongatedDipyramid[4] 
JohnsonSolid[16]:=ElongatedDipyramid[5] 
JohnsonSolid[17]:=Module[{anti=Polyhedron[Antiprism[4]],top,bot,h=2^(-5/4)+1/Sqrt[2]},bot=Polygon[Append[#,{0,0,-h}]]&/@(Partition[anti[[1]]/.Polygon:>Identity,2,1,1]);
top=Polygon[Append[#,{0,0,h}]]&/@(Partition[anti[[2]]/.Polygon:>Identity,2,1,1]);
Flatten[{top,bot,Drop[anti,2]}/.Sec[Pi/8]:>Sqrt[4-2Sqrt[2]]]]
JohnsonSolid[18]:=ElongatedCupola[3] 
JohnsonSolid[19]:=ElongatedCupola[4]
JohnsonSolid[20]:=ElongatedCupola[5] 
JohnsonSolid[21]:=ElongatedRotunda[5]
JohnsonSolid[22]:=GyroelongatedCupola[3]
JohnsonSolid[23]:=GyroelongatedCupola[4] 
JohnsonSolid[24]:=GyroelongatedCupola[5] 
JohnsonSolid[25]:=GyroelongatedRotunda[5] 
JohnsonSolid[26]:=Gyrobifastigium
JohnsonSolid[27]:=Orthobicupola[3]
JohnsonSolid[28]:=Orthobicupola[4]
JohnsonSolid[29]:=Gyrobicupola[4]
JohnsonSolid[30]:=Orthobicupola[5]
JohnsonSolid[31]:=Gyrobicupola[5]
JohnsonSolid[32]:=Orthocupolarotunda[5]
JohnsonSolid[33]:=Gyrocupolarotunda[5]
JohnsonSolid[34]:=Orthobirotunda[5]
JohnsonSolid[35]:=ElongatedOrthobicupola[3]
JohnsonSolid[36]:=ElongatedGyrobicupola[3]
JohnsonSolid[37]:=ElongatedGyrobicupola[4]
JohnsonSolid[38]:=ElongatedOrthobicupola[5]
JohnsonSolid[39]:=ElongatedGyrobicupola[5]
JohnsonSolid[40]:=ElongatedOrthocupolarotunda[5]
JohnsonSolid[41]:=ElongatedGyrocupolarotunda[5]
JohnsonSolid[42]:=ElongatedOrthobirotunda[5]
JohnsonSolid[43]:=ElongatedGyrobirotunda[5]
JohnsonSolid[44]:=GyroelongatedBicupola[3]
JohnsonSolid[45]:=GyroelongatedBicupola[4]
JohnsonSolid[46]:=GyroelongatedBicupola[5]
JohnsonSolid[47]:=GyroelongatedCupolarotunda[5]
JohnsonSolid[48]:=GyroelongatedBirotunda[5]
JohnsonSolid[49]:=AugmentedPrism[3]
JohnsonSolid[50]:=AugmentedPrism[3,{1,2}]
JohnsonSolid[51]:=AugmentedPrism[3,{1,2,3}]
JohnsonSolid[52]:=AugmentedPrism[5]
JohnsonSolid[53]:=AugmentedPrism[5,{1,3}]
JohnsonSolid[54]:=AugmentedPrism[6]
JohnsonSolid[55]:=AugmentedPrism[6,{1,4}]
JohnsonSolid[56]:=AugmentedPrism[6,{1,3}]
JohnsonSolid[57]:=AugmentedPrism[6,{1,3,5}]
JohnsonSolid[58]:=AugmentedDodecahedron[]
JohnsonSolid[59]:=AugmentedDodecahedron[{1,2}]
JohnsonSolid[60]:=AugmentedDodecahedron[{1,3}]
JohnsonSolid[61]:=AugmentedDodecahedron[{1,3,5}]

Format

Off[N::"meprec"];

<<Utilities`Simplify`
Null
Null
Null

j=Orient[poly];
Print[ToExact/@PolyhedronEdgeLengths[j]];
Print[OrientedQ[Polyhedron[j]]];
Print[StringReplace[ToString[PolyhedronFaces[j]]," "->""]];
Print[StringReplace[ToString[InputForm@Map[RootReduce[Simplify[TrigToExp[#]]]&,PolyhedronVertices[j],{2}]],{" "->""}]];
Show[Graphics3D[Polyhedron[j]],Boxed->False,PlotRange->All]

(Subscript[J, 62])

Show[Graphics3D[{Polyhedron[Icosahedron,"C2"],
Line[{{-1,0,0},{1,0,0}}1.2],
MapIndexed[Text[#2[[1]],#1,Background->White]&,PolyhedronVertices[Icosahedron,"C2"]]}],Boxed->False,ViewPoint->{0,0,5}]

Show[Graphics3D[
{Line[{{-1,0,0},{1,0,0}}1.2],
poly=ConvexHull3D[PolyhedronVertices[Polygon/@(DeleteCases[PolyhedronFaces[Icosahedron,"C2"],{___,(4|6),___}]/.Thread[Range[12]->PolyhedronVertices[Icosahedron,"C2"]])]]
}],Boxed->False]

Show[UnfoldPolytope[poly]]

(Subscript[J, 63])

Show[Graphics3D[{Polyhedron[Icosahedron,"C3"],
Line[{{-1,0,0},{1,0,0}}1.2],
MapIndexed[Text[#2[[1]],#1,Background->White]&,PolyhedronVertices[Icosahedron,"C3"]]}],Boxed->False,ViewPoint->{0,0,5}]

Show[Graphics3D[
{Line[{{-1,0,0},{1,0,0}}1.2],
poly=ConvexHull3D[PolyhedronVertices[Polygon/@(DeleteCases[PolyhedronFaces[Icosahedron,"C3"],{___,(7|8|12),___}]/.Thread[Range[12]->PolyhedronVertices[Icosahedron,"C3"]])]]
}],Boxed->False,ViewPoint->{0,0,2}]

Show[UnfoldPolytope[poly]]

(Subscript[J, 64])

?CumulateFace

Show[Graphics3D[Drop[Polyhedron[JohnsonSolid[63]],{2}]],Boxed->False,ViewPoint->{0,0,-2}]

Polyhedron[JohnsonSolid[63]][[2,1]]

Show[Graphics3D[{
poly=Flatten[{Drop[Polyhedron[JohnsonSolid[63]],{2}],
CumulateFace[Polyhedron[JohnsonSolid[63]][[2,1]],Sqrt[6]/3]
}]
}],Boxed->False,ViewPoint->{0,.7,-2}]

(Subscript[J, 65])

PolyhedronName[JohnsonSolid[65]]

Show[Graphics3D[{
Polyhedron[TruncatedTetrahedron],
MapIndexed[Text[#2[[1]],#1,Background->White]&,PolyhedronVertices[TruncatedTetrahedron]]
}],Boxed->False,ViewPoint->{0,0,-2}]

Union[Last/@PolyhedronVertices[TruncatedTetrahedron][[{2,12,11,1,9,10}]]]

Show[Graphics3D[{
Drop[Polyhedron[TruncatedTetrahedron],{8}],
MapIndexed[Text[#2[[1]],#1,Background->White]&,PolyhedronVertices[TruncatedTetrahedron]]
}],Boxed->False,ViewPoint->{0,0,-2}]

Show[Graphics3D[Drop[Polyhedron[Cupola[3]],{2}]],Boxed->False,ViewPoint->{0,0,-2}]

Last/@PolyhedronVertices[Cupola[3]]

RotationMatrix[Pi/3].{1,2}

Show[Graphics3D[poly=Flatten[{
Drop[Polyhedron[TruncatedTetrahedron],{8}],
Drop[Polyhedron[Cupola[3]],{2}]/.Polygon[x_]:>Polygon[{Sequence@@(RotationMatrix[Pi/3].Most[#]),-((Sqrt[(3/2)])/2)-#[[3]]}&/@x]
}]],Boxed->False,ViewPoint->{0,0,-2}]

(Subscript[J, 66])

PolyhedronName[JohnsonSolid[66]]

Show[Graphics3D[{
Polyhedron[TruncatedCube],
MapIndexed[Text[#2[[1]],#1,Background->White]&,PolyhedronVertices[TruncatedCube]]
}],Boxed->False,ViewPoint->{0,0,-2}]

Union[Last/@PolyhedronVertices[TruncatedCube][[{4,18,20,2,6,12,10,8}]]]

Show[Graphics3D[{
Drop[Polyhedron[TruncatedCube],{1}],
MapIndexed[Text[#2[[1]],#1,Background->White]&,PolyhedronVertices[TruncatedCube]]
}],Boxed->False,ViewPoint->{0,0,-2}]

Show[Graphics3D[Drop[Polyhedron[Cupola[4]],{2}]],Boxed->False,ViewPoint->{0,0,-2}]

Last/@PolyhedronVertices[Cupola[4]]

Show[Graphics3D[poly=Flatten[{
Drop[Polyhedron[TruncatedCube],{1}],
Drop[Polyhedron[Cupola[4]],{2}]/.Polygon[x_]:>Polygon[{Sequence@@(RotationMatrix[0].Most[#]),(1/(2-2 (Sqrt[2])))-#[[3]]}&/@x]
}/.Polygon[x_]:>Polygon[{#[[1]],#[[2]],-#[[3]]}&/@x]]],Boxed->False,ViewPoint->{0,2,2}]

(Subscript[J, 67])

Show[Graphics3D[poly=Flatten[{
Drop[Polyhedron[TruncatedCube],{1,2}],
Drop[Polyhedron[Cupola[4]],{2}]/.Polygon[x_]:>Polygon[{Sequence@@(RotationMatrix[0].Most[#]),(1/(2-2 (Sqrt[2])))-#[[3]]}&/@x],
Drop[Polyhedron[Cupola[4]],{2}]/.Polygon[x_]:>Polygon[{Sequence@@(RotationMatrix[0].Most[#]),-(1/(2-2 (Sqrt[2])))+#[[3]]}&/@x]
}]],Boxed->False,ViewPoint->{0,2,0}]

(Subscript[J, 84])

j84:=Module[{x2,z1,z2,z3,v},{x2,z1,z2,z3}={Root[2-2*#1-3*#1^2+2*#1^3&,2],Root[-1-22*#1^2+64*#1^4+32*#1^6&,2],Root[-8-15*#1^2+8*#1^4+16*#1^6&,2],Root[-4-8*#1^2-#1^4+2*#1^6&,2]};
v={{-x2,0,z2},{0,1/2,z3},{0,-1/2,z3},{x2,0,z2},{1/2,0,0},{-1/2,0,0},{0,-x2,z1},{0,x2,z1}};
Polygon/@{v[[{3,2,1}]],v[[{2,3,4}]],v[[{7,3,1}]],v[[{3,7,4}]],v[[{5,4,7}]],v[[{7,6,5}]],v[[{1,6,7}]],v[[{2,8,1}]],v[[{4,8,2}]],v[[{8,4,5}]],v[[{8,5,6}]],v[[{8,6,1}]]}]

Show[Graphics3D[poly,Boxed->False]]

Vertex Subset Hulls

TruncatedCube

Print[{#,VertexSubsetHulls[#,"TruncatedCube",Debug->False,"MemoryConstraint"->4*^9,"Count"->1]//Timing}]&/@SortBy[PolyhedronData["*TruncatedCube*"],PolyhedronData[#, "V"]&];

TruncatedTetrahedron

Print[{#,VertexSubsetHulls[#,"TruncatedTetrahedron",Debug->False,"MemoryConstraint"->4*^9,"Count"->1]//Timing}]&/@SortBy[PolyhedronData["*TruncatedTetrahedron*"],PolyhedronData[#, "V"]&];

TruncatedDodecahedron

PolyhedronData["TruncatedDodecahedron","VertexSubsetHulls"]

Print[{#,VertexSubsetHulls[#,"TruncatedDodecahedron",Debug->False,"MemoryConstraint"->4*^9]//Timing}]&/@SortBy[PolyhedronData["*TruncatedDodecahedron*"],PolyhedronData[#, "V"]&];

{#,PolyhedronData[#,"VertexCoordinates"][[1,1]]}&/@PolyhedronData["*TruncatedDodecahedron*"]//Column

r=PolyhedronData["TruncatedDodecahedron","Circumradius"]//N

Graphics3D[{PointSize[.02],Point[{0,0,0}],Opacity[.2],PolyhedronData["AugmentedTruncatedDodecahedron","Faces"]}]

Select[PolyhedronData["AugmentedTruncatedDodecahedron","VertexCoordinates"],Abs[Norm[#]-r]<10^-2&]

AugmentedDodecahedron

Print[{#,VertexSubsetHulls[#,"Dodecahedron"]//Timing}]&/@SortBy[PolyhedronData["*AugmentedDodecahedron*"],PolyhedronData[#, "V"]&];

AugmentedSphenocorona

PolyhedronData["Sphenocorona"]

PolyhedronData["AugmentedSphenocorona"]

Print[{#,VertexSubsetHulls[#,"Sphenocorona"]//Timing}]&/@SortBy[PolyhedronData["*Sphenocorona*"],PolyhedronData[#, "V"]&];

AugmentedPrism

Print[{#,VertexSubsetHulls[#,{"Prism",4}]//Timing}]&/@SortBy[PolyhedronData["*ugmentedSquarePrism*"],PolyhedronData[#, "V"]&];

Print[{#,VertexSubsetHulls[#,{"Prism",5}]//Timing}]&/@SortBy[PolyhedronData["*ugmentedPentagonalPrism*"],PolyhedronData[#, "V"]&];

Print[{#,VertexSubsetHulls[#,{"Prism",6}]//Timing}]&/@SortBy[PolyhedronData["*ugmentedHexagonalPrism*"],PolyhedronData[#, "V"]&];

Platonic

Print[{#,VertexSubsetHulls[#,"Platonic",Debug->False]}]&/@SortBy[PolyhedronData["Johnson"],PolyhedronData[#, "V"]&]

Checks

Net

Net Vertices

inexact=Position[Table[NetVertices[i],{i,142}],_?InexactNumberQ];

Union[First/@inexact]

SolidName/@%

Solid 116 (J71)

badverts=Union[First/@Rest/@Select[inexact,First[#]==116&]]

v=NetVertices[116];
Show[Graphics[{ColoredNet[116,Labeled->True],
Text[#,v[[#]],Background->Green]&/@badverts
}],AspectRatio->Automatic]//Timing

Net edge lengths

Timing[edges=Table[Union[FullSimplify[Sqrt[(#1-#2).(#1-#2)]&@@@(Flatten[Partition[#,2,1]&@@@JohnsonNet[n],1])]],
{n,92}]
]

Flatten[Position[edges,_?(#≠{1}&),{1}]]

Now corrected

{14,15,16,50,71,88,89}+45

Transpose[{%,edges[[%]]}]//ColumnForm

Solids

Exact solid Vertices

exact = (#1[[1,1,1]] & ) /@ DownValues[JohnsonExact]

Timing[solidedges=Table[Union[N[Sqrt[(#1-#2).(#1-#2)]&@@@(Flatten[Partition[#,2,1]&@@@JohnsonExact[exact[[n]]],1])],SameTest->(Abs[#1-#2]<.000001&)],{n,Length[exact]}]
]

Complement[Range[92],%]

Approximate solid edge lengths

Timing[solidedges=Table[Union[FullSimplify[Sqrt[(#1-#2).(#1-#2)]&@@@(Flatten[Partition[#,2,1]&@@@JohnsonSolid[n],1])],SameTest->(Abs[#1-#2]<.000001&)],
{n,92}]
]