Barth Sextic

Author

Eric W. Weisstein
June 6, 2008

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

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

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

Equation

weqn=4(t^2 x^2-y^2)(t^2 y^2-z^2)(t^2 z^2-x^2)-
(1+2t)(x^2+y^2+z^2-w^2)^2w^2  /. t->GoldenRatio

eqn=4(t^2 x^2-y^2)(t^2 y^2-z^2)(t^2 z^2-x^2)-
(1+2t)(x^2+y^2+z^2-1)^2  /. t->GoldenRatio

AlgebraicDegree[eqn,{x,y,z}]

Surface

V5

<<ImplicitPlot3D`

n=2;
ImplicitPlot3D[4(t^2 x^2-y^2)(t^2 y^2-z^2)(t^2 z^2-x^2)-
(1+2t)(x^2+y^2+z^2-1)^2  /. t->GoldenRatio,{x,-n,n},{y,-n,n},{z,-n,n},PlotPoints->30]

<<Graphics`ContourPlot3D`

With[{t=GoldenRatio,r=2},
ContourPlot3D[
4(t^2 x^2-y^2)(t^2 y^2-z^2)(t^2 z^2-x^2)-
(1+2t)(x^2+y^2+z^2-1)^2 ,
{x,-r,r},{y,-r,r},{z,-r,r},PlotPoints->7,Boxed->False,BoxRatios->{1,1,1},ContourStyle->{EdgeForm[]}]
]//Timing

V6

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

plot[r_,opts___?OptionQ]:=ContourPlot3D[-(1+2 GoldenRatio) (((-1+(x^2)+(y^2)+(z^2)))^2)+4 ((GoldenRatio^2) (x^2)-(y^2)) ((GoldenRatio^2) (y^2)-(z^2)) (-(x^2)+(GoldenRatio^2) (z^2))==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,opts,MaxRecursion->5][[1]]

Graphics3D[plot[2],Boxed->False]

Proprties

Curvatures

GaussianCurvature[eqn,{x,y,z},Identity]//Timing

ByteCount/@Last[%]

Singular Points

(x,y,z)

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

exact=ToRadicals[RootApproximant[nodes]]

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

Length[vs=Split[SortBy[{RootReduce[Norm[#]],#}&/@exact,N],First[#1]==First[#2]&]]//Timing

Length/@vs

ds=ToRadicals[#[[1,1]]&/@vs]//FullSimplify

N[ds]

chs=ConvexHull3D[#[[All,2]]]&/@vs;//Timing

GraphicsGrid[{Graphics3D[#,Boxed->False]&/@chs},Spacings->-70,ImageSize->400]

GraphicsGrid[Partition[Graphics3D[{plot[2],Opacity[.5],#2},Boxed->False]&@@@Transpose[{ds,chs}],2],ImageSize->400,Spacings->-100]

(x,y,z,w)

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

N[nodes]