Tetrahedral Equation

Author

Eric W. Weisstein
October 15, 2002

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

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

Initialization

<<Platonic`
<<PolyhedronOperations`;

Code

Projection[v_List,r_:1]:={#[[1]],#[[2]]}/(1+#[[3]]/r)&/@Select[Simplify[v],#[[3]]≠-r&]

R=Sqrt[6]/4;
r=Sqrt[6]/12;
ρ=Sqrt[2]/4;

{R,r,ρ}//N

Project[icos_,r_,opts___]:=Module[{},
Graphics[{
PointSize[.05],
Map[Line,Map[Function[f,Projection[f,r]],PolyhedronEdges[icos],{1}]/r,{1}],
{PointSize[.07],Point/@VertexProjections[icos,r]},
{Red,Point/@FaceCenterProjections[icos,r]},
{Blue,Point/@EdgeMidpointProjections[icos,r]}
},
opts,
AspectRatio->Automatic,
PlotRange->All]
]

VertexProjections[icos_,r_]:=
Projection[PolyhedronVertices[icos],r]/r

FaceCenterProjections[icos_,r_]:=
Projection[PolyhedronFaceCenters[icos],r]/r

EdgeMidpointProjections[icos_,r_]:=
Projection[Midpoint/@PolyhedronEdges[icos],r]/r

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

(Subscript[C, 3])Projections

Off[$MaxExtraPrecision::"meprec"]

Simplify[Plus@@(Centroid/@(TetrahedronExactZ/.Polygon:>Identity))]

norm[v1_,v2_]:=Sqrt[(v1-v2).(v1-v2)]

norm@@@Partition[Union[Flatten[TetrahedronExactZ/.Polygon:>Identity,1]],2,1,1]

With[{i=TetrahedronExactZ},
Show[GraphicsArray[{{
Graphics3D[{
i,
PointSize[.05],
Point/@PolyhedronVertices[i],
{Red,Point/@PolyhedronFaceCenters[i]},
{Blue,Point/@Midpoint/@PolyhedronEdges[i]}
},Boxed->False,ViewPoint->{0,0,2}],
Graphics[HiddenWireframe[i,ViewPoint->{0,0,100},
PlotStyles->{{},Dashing[{1,1}.04]}],AspectRatio->Automatic]
}
}
]]]

Show[GraphicsArray[Project[TetrahedronExactZ,#]&/@{R,ρ,r}]]

Vertices

RootReduce/@Collect[RootReduce/@Times@@(Flatten/@VertexProjections[TetrahedronExactZ,R]/.{x_,y_}:>(z-(x+I y))),z]

Face Centers

RootReduce/@Collect[RootReduce/@Times@@(Flatten/@FaceCenterProjections[TetrahedronExactZ,r]/.{x_,y_}:>(z-(x+I y))),z]

Edge Midpoints

RootReduce/@Times@@(Flatten/@EdgeMidpointProjections[TetrahedronExactZ,ρ]/.{x_,y_}:>(z-(x+I y)))

e1=RootReduce/@Collect[ (z+Root[1+4 ((#1)^2)+15 ((#1)^4)+4 ((#1)^6)+((#1)^8)&,1]) (z+Root[1+4 ((#1)^2)+15 ((#1)^4)+4 ((#1)^6)+((#1)^8)&,2]) (z+Root[1+4 ((#1)^2)+15 ((#1)^4)+4 ((#1)^6)+((#1)^8)&,5]) (z+Root[1+4 ((#1)^2)+15 ((#1)^4)+4 ((#1)^6)+((#1)^8)&,6]),z]

e2=FullSimplify[ (z+Root[1-4 ((#1)^2)+((#1)^4)&,2]) (z+Root[1-4 ((#1)^2)+((#1)^4)&,4])  ]

Simplify[RootReduce/@Collect[e1 e2,z]]

(Subscript[C, 2])Projection

Off[$MaxExtraPrecision::"meprec"]

Plus@@(Centroid/@(TetrahedronExact/.Polygon:>Identity))

norm@@@Partition[Union[Flatten[TetrahedronExact/.Polygon:>Identity,1]],2,1,1]

With[{i=TetrahedronExact},
Show[GraphicsArray[{{
Graphics3D[{
i,
PointSize[.05],
Point/@PolyhedronVertices[i],
{Red,Point/@PolyhedronFaceCenters[i]},
{Blue,Point/@Midpoint/@PolyhedronEdges[i]}
},Boxed->False,ViewPoint->{0,0,2}],
Graphics[HiddenWireframe[i,ViewPoint->{0,0,2},
PlotStyles->{{},Dashing[{1,1}.04]}],AspectRatio->Automatic]
}
}
]]]

Show[GraphicsArray[Project[TetrahedronExact,#]&/@{R,ρ,r}]]

Vertices

v=Collect[Times@@(Flatten/@VertexProjections[TetrahedronExact,R]/.{x_,y_}:>(z-(x+I y))),z]

Face Centers

FullSimplify[RootReduce/@Times@@(Flatten/@FaceCenterProjections[TetrahedronExact,r]/.{x_,y_}:>(z-(x+I y)))]

Edge Midpoints

Collect[RootReduce[RootReduce/@Times@@(Flatten/@EdgeMidpointProjections[TetrahedronExact,ρ]/.{x_,y_}:>(z-(x+I y)))],z]