Escher's Solid

Author

Eric W. Weisstein
September 11, 2023

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

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

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

Solid

PolyhedronData["EscherSolid","Orientations"]

PolyhedronData["EscherSolid"]

Net

PolyhedronData["EscherSolid","Net"]

PolyhedronData["EscherSolid","Net","Colored"]

Properties

Initialization

<<MathWorld`Polyhedra`

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

vol=PolyhedronData[pname,"Volume"]

Centroid

PolyhedronData[pname,"Centroid"]

RegionCentroid[p]

PolyhedronCentroid[p]

Circumsphere

PolyhedronData[pname,"Circumsphere"]

Circumsphere[p]

MyCircumsphere[p]

Convex

PolyhedronData[pname,"Convex"]

ConvexPolyhedronQ[p]

ConvexHull

PolyhedronData[pname,"ConvexHull"]

convexhull=ConvexHullRegion[PolyhedronData[pname,"Vertices"]]

v=PolyhedronCoordinates[convexhull]

Sort[(convexhull[[2]]/.i_Integer:>v[[i]])/.Thread[PolyhedronData[pname,"Vertices"]->Range[PolyhedronData[pname,"V"]]]]

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

{Graphics3D[{Red,Opacity[.5],p}],Graphics3D[{Blue,Opacity[.5],PolyhedronData[pname,"ConvexHull"][[1]]}]}

Show[%]

DehnInvariant

PolyhedronData[pname,"DehnInvariant"]

DehnInvariant[p,Debug->True]

DihedralAngles

PolyhedronData[pname,"DihedralAngles"]//Tally

DihedralAngles[p]//FullSimplify//Tally

EdgeCount

PolyhedronData[pname,"EdgeCount"]

EdgeLengths

PolyhedronData[pname,"EdgeLengths"]

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

lens=SimplifyNumericallyDistinct[PolyhedronEdgeLengths[p]];//Quiet

(distinctlens=Mean/@Split[Sort[lens],Abs[#1-#2]<1.*^-10&])//N//Quiet

v=PolyhedronCoordinates[p];

colors=With[{n=Length[distinctlens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[distinctlens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[p],Boxed->False]//Quiet

FaceCount

PolyhedronData[pname,"FaceCount"]

GeneralizedDiameter

PolyhedronData[pname,"GeneralizedDiameter"]

GeneralizedDiameter[p]//FullSimplify

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[p]

MyInsphere[p]

Graphics3D[{{Opacity[.2],p},{Red,MyInsphere[p]}}]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

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

PolyhedronInertiaTensor[p]//FullSimplify//Timing

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

Integrate over polyhedron

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

N[Log[2]]

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

Divergence theorem

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

N[rxy,20]

LogSimplify[rxy]

FullSimplify[%]

N[%,20]

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

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

Integrate

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

Divergence theorem

(rxyz=MeanSphericalRadius[p,Debug->True])//Timing

CAD

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

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

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

Boole Integrate doing z integral first

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}=CoordinateBounds[p]

ineq=PolyhedronData[pname,"RegionFunction"][x,y,z]

(i1=Integrate[Boole[ineq](Sqrt[(x^2)+(y^2)+(z^2)]),{z,zmin,zmax}])//Timing

NIntegrate[(i1/vol),{x,xmin,xmax},{y,ymin,ymax}]

(i2=Integrate[(i1/vol),{x,xmin,xmax},{y,ymin,ymax}])//Timing

MeanSquareCylindricalRadius

PolyhedronData[pname,"MeanSquareCylindricalRadius"]

Integrate over Polyhedron

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

Divergence theorem

(rxy=MeanSquareCylindricalRadius[p,Debug->False])//Timing

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

Integrate

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

Divergence theorem

(rxy=MeanSquareSphericalRadius[p,Debug->False])//Timing

Midsphere

PolyhedronData[pname,"Midsphere"]

Midsphere[p]

Net

PolyhedronData[pname,"Net"]

Polygons

PolyhedronData[pname,"FaceCount"]

Graphics3D/@PolyhedronData[pname,"Polygons"]

Show[%]

Polyhedra

PolyhedronData[pname,"Polyhedra"]

Graphics3D[%]

PolyhedronData[pname,"PolyhedronIndices"]

polygons=PolyhedronData[pname,"Polygons"]

Region

PolyhedronData[pname,"ImplicitRegion"]

PolyhedronData[pname,"Region"]

PolyhedronData[pname,"RegionFunction"]

RegionFunction

PolyhedronData[pname,"RegionFunction"]

This is for the convex hull:

Collect[#,{x,y,z},RootReduce]&/@PolyhedronInequalities[p,{x,y,z}]

ineq=FullSimplify[%]

Region[ImplicitRegion[ineq,{x,y,z}]]

Integrate[Boole[ineq],{x,y,z}∈FullRegion[3]]

Volume[p]

SimplePolyhedron

PolyhedronData[pname,"Simple"]

SimplePolyhedronQ[p]

Skeleton

PolyhedronData[pname,"Skeleton"]

PolyhedronData[pname,"Skeleton","Name"]

GraphData[%,"PolyhedralEmbeddings"]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[p]

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

VertexCount

PolyhedronData[pname,"VertexCount"]

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]//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 as a cumulated RhombicDodecahedron

PolyhedronData["RhombicDodecahedron","EdgeLengths"]

poly=Cumulate[PolyhedronData["RhombicDodecahedron","Polyhedron"],Sqrt[2/3]]

Graphics3D[poly]

v=PolyhedronVertices[poly];

Length[poly[[2]]]

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

Tally[PolyhedronEdgeLengths[poly]]

Graphics3D[poly0,ViewPoint->{0,0,Infinity}]

Net construction

Table[{poly=UnfoldPolyhedron[p,WorkingPrecision->1000],Graphics[{FaceForm[LightYellow],EdgeForm[Black],poly}]},100]

PolyhedronData

PolyhedronDataString

PolyhedronDataString[p,
"StandardName"->"EscherSolid",
"Name"->"Escher's solid",
"AlternateNames" ->{"Escher polyhedron","Escher solid"},
"AlternateStandardNames"->{},
"Information" ->"EschersSolid",
"Classes"->{"SpaceFilling"}
]