Endraß Octic

Author

Eric W. Weisstein
June 3, 2008

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Surfaces/EndrassOctic.nb.

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

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

Initialization

<<Utilities`POVray`

Definition

Equations

AlgebraicDegree[# ,{x,y,z}]&/@{EndrassOctic1,EndrassOctic2}

First Endrass Octic

EndrassOcticW1=64(x^2-w^2)(y^2-w^2)((x+y)^2-2w^2)((x-y)^2-2w^2)-
(-4(1+Sqrt[2])(x^2+y^2)^2+(8(2+Sqrt[2])z^2+2(2+7Sqrt[2])w^2)(x^2+y^2)-16z^4+8(1-2Sqrt[2])z^2w^2-(1+12Sqrt[2])w^4)^2;

EndrassOctic1 =EndrassOcticW1/. w->1

With[{r=4},
ContourPlot3D[EndrassOctic1==0,{x,-r,r},{y,-r,r},{z,-r,r},RegionFunction->(#1^2+#2^2+#3^2<r^2&),Boxed->False,Axes->False,Mesh->None]
]

With[{r=4},
ContourPlot3D[EndrassOctic1==0,{x,-r,r},{y,-r,r},{z,-r,r},RegionFunction->(#1^2+#2^2+#3^2<r^2&),Boxed->False,Axes->False,Mesh->None,MaxRecursion->4]
]

POVRay

POVCoefficients[Expand[N[EndrassOctic1]],{x,y,z}]

Gaussian Curvature

ByteCount/@(k=GaussianCurvature[EndrassOctic1,{x,y,z},Identity])//Timing

FullSimplify[k[[1]]]

ByteCount[%]

Singular Points

Length[nodes=SingularPoints[EndrassOcticW1,{x,y,z,w},WorkingPrecision->200]]//Timing

Length[nodes=SingularPoints[EndrassOctic1,{x,y,z},WorkingPrecision->100]]//Timing

ds=Union[N/@Norm/@nodes]

Sqrt[2]/2.

Length/@(groups=Function[d,Select[nodes,Abs[Norm[#]-d]<10^-3&]]/@ds)

Graphics3D[ConvexHull3D[#]]&/@groups

Length[nodes=SingularPoints[EndrassOctic1,{x,y,z},WorkingPrecision->200]]//Timing

exact=ToRadicals[RootApproximant[nodes]];//Timing

exact

Select[exact,Im[#]=={0.,0.,0.}&]

Length[%]

Second Endrass Octic

EndrassOcticW2=64(x^2-w^2)(y^2-w^2)((x+y)^2-2w^2)((x-y)^2-2w^2)-
(-4(1-Sqrt[2])(x^2+y^2)^2+(8(2-Sqrt[2])z^2+2(2-7Sqrt[2])w^2)(x^2+y^2)-16z^4+8(1+2Sqrt[2])z^2w^2-(1-12Sqrt[2])w^4)^2  ;

EndrassOctic2=EndrassOcticW2/. w->1

With[{r=3.8},
ContourPlot3D[EndrassOctic2==0,{x,-r,r},{y,-r,r},{z,-r,r},RegionFunction->(#1^2+#2^2+#3^2<r^2&),Boxed->False,Axes->False,Mesh->None]
]

With[{r=3.8},
ContourPlot3D[EndrassOctic2==0,{x,-r,r},{y,-r,r},{z,-r,r},RegionFunction->(#1^2+#2^2+#3^2<r^2&),Boxed->False,Axes->False,Mesh->None,MaxRecursion->4]
]

POV

POVCoefficients[Expand[N[EndrassOctic2]],{x,y,z}]

Gaussian Curvature

ByteCount/@(k=GaussianCurvature[EndrassOctic2,{x,y,z},Identity])//Timing

FullSimplify[k[[1]]]

ByteCount[%]

Singular Points

Length[nodes=SingularPoints[EndrassOcticW2,{x,y,z,w},WorkingPrecision->100]]//Timing

Length[nodes=SingularPoints[EndrassOctic2,{x,y,z},WorkingPrecision->100]]//Timing

Length[nodes=SingularPoints[EndrassOctic2,{x,y,z},WorkingPrecision->200]]//Timing

Select[nodes,Im[#]=={0.,0.,0.}&]//Length

exact=ToRadicals[RootApproximant[nodes]];//Timing

exact

Select[exact,Im[#]=={0.,0.,0.}&]

Length[%]