Barth Decic

Author

Eric W. Weisstein
May 23, 2008

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

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

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

Equation

BarthW=With[{ϕ=GoldenRatio},
8(x^2-ϕ^4 y^2) (y^2-ϕ^4 z^2) (z^2-ϕ^4 x^2)(x^4+y^4+z^4-2 x^2 y^2-2 x^2 z^2-2 y^2 z^2)+(3+5ϕ) (x^2+y^2+z^2-w^2)^2(x^2+y^2+z^2-(2-ϕ) w^2)^2 w^2]

Barth=BarthW/.w->1

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

Surface

V5

<<Graphics`ContourPlot3D`

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

With[{ϕ=GoldenRatio,w=1,r=5},
ContourPlot3D[
8(x^2-ϕ^4 y^2) (y^2-ϕ^4 z^2) (z^2-ϕ^4 x^2)(x^4+y^4+z^4-2 x^2 y^2-2 x^2 z^2-2 y^2 z^2)+(3+5ϕ) (x^2+y^2+z^2-w^2)^2(x^2+y^2+z^2-(2-ϕ) w^2)^2 w^2,
{x,-r,r},{y,-r,r},{z,-r,r},PlotPoints->9,Boxed->False,BoxRatios->{1,1,1},ContourStyle->{EdgeForm[]}]
]//Timing

V6

With[{r=2.5},
ContourPlot3D[eqn==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=2.5},
ContourPlot3D[eqn==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,PlotPoints->30]
]

plot[r_,opts___?OptionQ]:=ContourPlot3D[Barth==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->4][[1]]

Graphics3D[plot[2.5],Boxed->False,Axes->False]

Properties

Gaussian Curvature

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

Singular Points

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

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

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

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

{Max[Norm/@nodes],Max/@Transpose[Abs/@nodes]}//N

exact=RootApproximant[nodes];//Timing

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

ToRadicals[exact]

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]

Graphics3D[{plot[1.333#1],Opacity[.5],#2},Boxed->False]&@@@Transpose[{ds,chs}]

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