Chamfered Tetrahedron

Author

Eric W. Weisstein
October 6, 2022

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

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

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

Graphic

PolyhedronData["*ChamferedTetrahedron"]

Varying chamfering ratios

With[{p=Tetrahedron[]},GraphicsRow[Graphics3D[{Opacity[.8],#},ViewPoint->20{0,0,1},Boxed->False]&/@Prepend[Table[ResourceFunction["ChamferedPolyhedron"][p,r],{r,.2,.99,.2}],p]]]

Graphic

Graphics3D[{Opacity[.8],PolyhedronData["EquilateralChamferedTetrahedron","Polyhedron"]},Boxed->False]

Graphics3D[{FaceForm[Green,Red],PolyhedronData["EquilateralChamferedTetrahedron","Polyhedron"]},Boxed->False]

Net

PolyhedronData["EquilateralChamferedTetrahedron","Net"]

PolyhedronData["EquilateralChamferedTetrahedron","Net","Colored"]

Properties

Initialization

<<MathWorld`Polyhedra`

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

vol=PolyhedronData[pname,"Volume"]

Centroid

PolyhedronData[pname,"Centroid"]

(xbar=RegionCentroid[poly])//Timing

ToAlgebraicRoot/@xbar//Quiet

PolyhedronCentroid[poly]//Quiet//Timing

Circumsphere

PolyhedronData[pname,"Circumsphere"]

Circumsphere[poly]//Timing

MyCircumsphere[poly]//Timing

EdgeLengths

PolyhedronData[pname,"EdgeLengths"]

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[poly]]//Quiet//Union

PolyhedronEdgeLengths[poly]//RootReduce//Union//Quiet//Timing

GeneralizedDiameter

PolyhedronData[pname,"GeneralizedDiameter"]

GeneralizedDiameter[poly]//FullSimplify//Quiet

RootReduce[%]

FullSimplify[%]

InertiaTensor

PolyhedronData[pname,"InertiaTensor"]

(i=MomentOfInertia[poly,{0,0,0}])//Timing

(ii=Map[ToAlgebraicRoot,i,{2}])//Quiet//Timing

iii=RootReduce[(ii/vol)]//FullSimplify

N[iii]

Equal@@Tr[iii,List]

(i=PolyhedronInertiaTensor[poly,vol])//Timing

Insphere

PolyhedronData[pname,"Insphere"]

Insphere[poly]//Timing

MyInsphere[poly]//Timing

MeanCylindricalRadius

PolyhedronData[pname,"MeanCylindricalRadius"]

N[%]

Integrate over polyhedron

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

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

Divergence theorem [unevaluated integral]

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

N[rxy]

ResourceFunction["LogSimplify"][rxy]//FullSimplify

MeanSphericalRadius

PolyhedronData[pname,"MeanSphericalRadius"]

Integrate

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

(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

Integrate over z first

{{xmin,xmax},{ymin,ymax},{zmin,zmax}}=MinMax/@Transpose[PolyhedronCoordinates[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"]

(rxy2=((Integrate[x^2+y^2,{x,y,z}∈poly])/vol)//FullSimplify)//Timing

MeanSquareCylindricalRadius[poly]//FullSimplify//Timing

MeanSquareSphericalRadius

PolyhedronData[pname,"MeanSquareSphericalRadius"]

(rxyz2=((Integrate[x^2+y^2+(z^2),{x,y,z}∈poly])/vol)//FullSimplify)//Timing

MeanSquareSphericalRadius[poly]//FullSimplify//Timing

Midsphere

PolyhedronData[pname,"Midsphere"]

Midsphere[poly]//Timing

Midsphere[poly,Method->"PointLineDistance","SolveMethod"->"NSolve"]//Timing

Net

PolyhedronData[pname,"Net"]

Total[Area/@Flatten[PolyhedronData[pname,"Net","Polygon"]]]//ToAlgebraicRoot//FullSimplify//Timing

PolyhedronData[pname,"SurfaceArea"]

Region

PolyhedronData[pname,"Region"]

RegionFunction

ineq=Collect[#,{x,y,z},RootReduce]&/@PolyhedronInequalities[poly,{x,y,z}]

ineq/.{x->#,y->#2,z->#3}

FullSimplify/@%

FullSimplify@%

Skeleton

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

PolyhedronData[pname,"Skeleton"]

%//RecognizeGraph

GraphData["ChamferedTetrahedralGraph","Graph","Perspective"]

SurfaceArea

PolyhedronData[pname,"SurfaceArea"]

SurfaceArea[poly]//ToAlgebraicRoot//FullSimplify//Quiet//Timing

PolyhedronSurfaceArea[poly]//RootReduce//FullSimplify//Timing

Volume

PolyhedronData[pname,"Volume"]

Volume[poly]//RootReduce//Timing

PolyhedronVolume[poly]//FullSimplify//Quiet//Timing

Volume[PolyhedronData[pname,"Region"]]//FullSimplify//Timing

Construction

"EquilateralChamferedTetrahedron"

Mangaldan

from Jan Mangaldan, July 2022

EquilateralChamferedTetrahedron=Polyhedron[]

Weisstein using ResourceFunction

f[p_,r_?NumericQ]:=Module[{e=PolyhedronEdgeLengths[ChamferedPolyhedron[p,r]]},Divide@@MinMax[e]]

data=Table[{r,f[Tetrahedron[],r]},{r,.1,.9,.01}]

ListPlot[data]

peakpos=FindPeaks[data[[All,2]]]

peaks=data[[peakpos[[All,1]]]]

ListLinePlot[
{data,peaks},
Joined->{True,False},
PlotStyle->{Automatic,PointSize[.03]}
]

({r}=FindArgMax[f[Tetrahedron[],r],{r,8/10,82/100},WorkingPrecision->100])//Timing

rexact=ToAlgebraicRoot[N[r,50]]

Graphics3D[p=ChamferedPolyhedron[Tetrahedron[],rexact]]

SimplifyNumericallyDistinct[PolyhedronEdgeLengths[p]]//Union//Quiet

Net construction

Graphics3D[{Opacity[.8],PolyhedronData["EquilateralChamferedTetrahedron","Polyhedron"]},Boxed->False]

PolyhedronEdgeLengths[PolyhedronData["EquilateralChamferedTetrahedron","Polyhedron"]]//FullSimplify//Union

Graphics3D[{{Opacity[.8],PolyhedronData["EquilateralChamferedTetrahedron","Polyhedron"]},MapIndexed[Text[#2[[1]],#,Background->White]&,v=PolyhedronData["EquilateralChamferedTetrahedron","Vertices"]]},Boxed->False]

VectorAngle[v[[13]]-v[[2]],v[[5]]-v[[2]]]//FullSimplify

VectorAngle[v[[2]]-v[[13]],v[[11]]-v[[13]]]//FullSimplify

PolyhedronData["EquilateralChamferedTetrahedron","FaceCountRules"]

u=RotationMatrix[Pi/4].{1,0}

v={{0,0},{0,1},{1,0},{0,-1},{-1,0},v[[4]]+RotationMatrix[-Pi/3].(v[[7]]-v[[4]])};
v=Join[v,{v[[4]]+{1,-1}u,v[[3]]+{1,-1}u}];
v=Join[v,{v[[7]]+{1,0}}];
v=Join[v,{1,-1}v[[#]]&/@{4,7,9,8}];
v=Join[v,{-1,1}v[[#]]&/@{11,12,13}];
v=Join[v,{v[[3]]+RotationMatrix[-Pi/3].(v[[13]]-v[[3]])}];
v=Join[v,{v[[9]]+{1,0},v[[8]]+RotationMatrix[3Pi/4].{0,-1}}];
v=Join[v,{v[[18]]+RotationMatrix[Pi/4].{1,0},v[[19]]+{1,0},v[[15]]-{1,0},v[[16]]-u}];
v=Join[v,{v[[22]]-u,v[[23]]-{1,0}}];
v=Join[v,{v[[24]]+RotationMatrix[Pi/3].(v[[22]]-v[[24]]),v[[10]]+RotationMatrix[Pi/3].(v[[11]]-v[[10]])}];
v=Join[v,{v[[27]]+RotationMatrix[3Pi/4].(v[[11]]-v[[27]]),v[[11]]+RotationMatrix[-3Pi/4].(v[[27]]-v[[11]])}];
v=Join[v,{v[[28]]+RotationMatrix[Pi/2].(v[[27]]-v[[28]]),v[[29]]+RotationMatrix[-Pi/2].(v[[11]]-v[[29]])}];
v=Delete[v,List/@{22,26,24,25,23}];
v=Join[v,{v[[6]]+RotationMatrix[-3Pi/4].(v[[7]]-v[[6]]),v[[7]]+RotationMatrix[3Pi/4].(v[[6]]-v[[7]])}];
v=Join[v,{v[[27]]+RotationMatrix[-Pi/2].(v[[6]]-v[[27]]),v[[28]]+RotationMatrix[Pi/2].(v[[7]]-v[[28]])}];
v=Join[v,{v[[29]]+RotationMatrix[-Pi/3].(v[[30]]-v[[29]])}];
f=Sort@{{8,3,1,4,7,9},{3,13,12,11,10,1},{10,14,15,16,5,1},{17,13,3},{21,19,8,9,18,20},{6,7,4},{10,11,22},{11,24,26,25,23,22},{28,7,6,27,29,30},{30,29,31}};
Graphics[{FaceForm[LightYellow],EdgeForm[Black],Polygon[v,f],MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]

Area[Polygon[v,f]]

PolyhedronData["EquilateralChamferedTetrahedron","SurfaceArea"]

v2=RotationMatrix[-Pi/2].#&/@v;

Graphics[{FaceForm[LightYellow],EdgeForm[Black],Polygon[v2,f],MapIndexed[Text[#2[[1]],#,Background->White]&,v2]}]

f

v2//FullSimplify

PolyhedronData

PolyhedronDataString

file=OpenWrite["~/champ.m"]

WriteString[file,PolyhedronDataString[EquilateralChamferedTetrahedron,
"StandardName"->"EquilateralChamferedTetrahedron",
"Name"->"equilateral chamfered tetrahedron",
"AlternateStandardNames"->{}
]]