Octahedral Equation

Author

Eric W. Weisstein
October 15, 2002

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

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

Initialization

<<Platonic`
<<PolyhedronOperations`;

Code

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

R=Sqrt[2]/2;
r=Sqrt[6]/6;
ρ=1/2;

{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, 4])Projection

Off[$MaxExtraPrecision::"meprec"]

With[{i=OctahedronExact},
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[OctahedronExact,#]&/@{R,ρ,r}]]

Vertices

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

Face Centers

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

Edge Midpoints

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

(Subscript[C, 3])Projections

Off[$MaxExtraPrecision::"meprec"]

With[{i=OctahedronExactZ},
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[OctahedronExactZ,#]&/@{R,ρ,r}]]

Vertices

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

Face Centers

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

Edge Midpoints

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

e1=RootReduce[ (z+Root[1-((#1)^2)+((#1)^4)&,1]) (z+Root[1-((#1)^2)+((#1)^4)&,2]) (z+Root[1-((#1)^2)+((#1)^4)&,3]) (z+Root[1-((#1)^2)+((#1)^4)&,4]) ]

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

e3=FullSimplify/@Collect[(z+Root[1+10 ((#1)^2)+99 ((#1)^4)+10 ((#1)^6)+((#1)^8)&,3]) (z+Root[1+10 ((#1)^2)+99 ((#1)^4)+10 ((#1)^6)+((#1)^8)&,4]) (z+Root[1+10 ((#1)^2)+99 ((#1)^4)+10 ((#1)^6)+((#1)^8)&,7]) (z+Root[1+10 ((#1)^2)+99 ((#1)^4)+10 ((#1)^6)+((#1)^8)&,8]),z]

Expand[(-I+z) (I+z) e1 e2 e3]