Clebsch Diagonal Cubic

Author

Eric W. Weisstein
February 6, 2023

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

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

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

Sources

https://mathematica.stackexchange.com/questions/279405/how-to-plot-clebsch-surface-with-those-27-lines#comment697874_279420

Equation

eqn=81(x^3+y^3+z^3)-189(x^2y+x^2z+y^2x+y^2z+z^2x+z^2y)+54x y z+126(x y+x z+y z)-9(x^2+y^2+z^2)-9(x+y+z)+1;

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

Regular

clebscheqn=((x0^3+x1^3+x2^3+x3^3+x4^3/.x4->-(x0+x1+x2+x3))/.x0->1)==0;

clebscheqn=Solve[clebscheqn,x3]

Plane at Infinity at (Subscript[x, 0])+(Subscript[x, 1])+(Subscript[x, 2])+((Subscript[x, 3])/2)

Not Correct

Expand[(x0^3+x1^3+x2^3+x3^3+x4^3/.x4->-(x0+x1+x2+x3))/.x3->-2(x0+x1+x2)/.{x0->x,x1->y,x2->z}]

TraditionalForm[eqn]

ContourPlot3D[eqn==0,Element[{x,y,z},Ball[]],Boxed->False,Axes->False,Mesh->None,RegionBoundaryStyle->None,Method->{"ShrinkWrap"->True}]

ContourPlot3D[eqn==0,Element[{x,y,z},Ball[]],Boxed->False,Axes->False,Mesh->None,RegionBoundaryStyle->None,ContourStyle->{Gray,Specularity[White,50]},
Lighting->{{RGBColor[0.5,0.5,1],ImageScaled[{0,1,0}]},{RGBColor[1,0.5,0.5],ImageScaled[{1,-1,0}]},{RGBColor[0.5,1,0.5],ImageScaled[{-1,-1,0}]}},Method->{"ShrinkWrap"->True}]

red=ContourPlot3D[eqn==0,Element[{x,y,z},Ball[]],Boxed->False,RegionBoundaryStyle->None,Axes->False,Mesh->None,PlotPoints->40,ContourStyle->{Red,Specularity[White,10]},
Lighting->{{White,ImageScaled[{0,1,0}]},{White,ImageScaled[{1,-1,0}]},{White,ImageScaled[{-1,-1,0}]}},Method->{"ShrinkWrap"->True}]

POVRay

<<Utilities`POVRay`

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

27 Lines

https://mathematica.stackexchange.com/questions/279405/how-to-plot-clebsch-surface-with-those-27-lines#comment697874_279420

lines=With[{expr=eqn==0},
(*Expression over a parametric infinite line.*)expr/. Thread[{x,y,z}->{a,b,c}+t {u,v,w}]//
(*Find lines which lie on the surface.*)
Solve[
(*Expression must be true for all t,that is,it must lie on the surface everywhere.*)
Resolve[ForAll[t,#]]&&
(*Constrain solutions:line offset and line direction vectors must be at right angle,and line direction vector must be unit length.*){a,b,c}.{u,v,w}==0&&u^2+v^2+w^2==1&&
(*Prevent finding lines with "direction" negated.*)
((w>0)||(w==0&&v>0)||(w==0&&v==0&&u>0)),{a,b,c,u,v,w},Reals]&//(*Line segments inside the plotted area.*)RegionIntersection[InfiniteLine[{a,b,c},{u,v,w}],Ball[]]/. N[#]&]

surfacewithlines=Show[{
ContourPlot3D[eqn==0,Element[{x,y,z},Ball[]],PlotPoints->100,ContourStyle->Opacity[9/10],Boxed->False,BoxRatios->Automatic,Axes->None,Mesh->None,RegionBoundaryStyle->None
],
Graphics3D[{Thick,CapForm["Butt"],lines}]
},Method->{"ShrinkWrap"->True}]

GraphicsRow[{red,surfacewithlines}]

Animate[Show[(*Plot the surface.*)ContourPlot3D[eqn==0,Element[{x,y,z},Ball[]],PlotPoints->100,ContourStyle->Opacity[9/10],Boxed->False,BoxRatios->Automatic,Axes->None,Mesh->None,RegionBoundaryStyle->None,SphericalRegion->True,ViewAngle->10 Degree,ViewPoint->Dynamic[{5 Sin[a],5 Cos[a],5/2}]],(*Plot line segments.*)Graphics3D[{Thick,CapForm["Butt"],lines}]],{a,0,2 Pi}]

Head[%1]

Properties

Gaussian Curvature

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

FullSimplify[k[[1]]]

Singular Points

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

Degenerate

f1[x_,y_]:=z/.Solve[(x+y)(y+z)(x+z)==0,z][[1]]
f2[x_,y_]:=z/.Solve[(x+y)(y+z)(x+z)==0,z][[2]]
d=20;
Show[{Plot3D[f1[x,y],{x,-d,d},{y,-d,d},DisplayFunction->Identity],Plot3D[f2[x,y],{x,-d,d},{y,-d,d},DisplayFunction->Identity]},ViewPoint->{1,-5,1},Boxed->False,Axes->False,DisplayFunction->$DisplayFunction]
Null