Cayley Cubic

Author

Eric W. Weisstein
June 6, 2008

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

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

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

Hunt Version

CayleyHunt=-5(x^2y+x^2z+y^2x+y^2z+z^2y+z^2x)+2(x y+x z+y z)

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

Plot

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

Singularity

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

POVRay

<<Utilities`POVRay`

POVCoefs[Expand[CayleyHunt]]

Endraß Version

WrongCayleyEndrass=(4(x^3+y^3+z^3+w^3)-(x+y+z+w)^3 ) /. w->1

CayleyEndrass=(4(x0^3+x1^3+x2^3+x3^3)-(x0+x1+x2+x3)^3 ) /. {
x0->1-z-Sqrt[2]x,
    x1->1-z+Sqrt[2]x,
    x2->1+z+Sqrt[2]y,
    x3->1+z-Sqrt[2]y}

Expand[CayleyEndrass/48]

CayleyEndrass=(x^2)+(y^2)-(x^2)z+(y^2)z+(z^2)-1

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

Plot

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

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

Singularities

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

POVRay

<<Utilities`POVRay`

POVCoefs[Expand[CayleyEndrass/48]]

Properties

Endrass1

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

ByteCount/@(kk=FullSimplify[k])

kk[[-1]]

Endrass2

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

ByteCount/@(kk=FullSimplify[k])

kk[[2]]

Hessian

TraditionalForm[eqn=25(x^3(y+z)+y^3(x+z)+z^3(x+y))+50(x^2y^2+x^2z^2+y^2z^2)-125(x^2y z+y^2 x z+z^2 x y)+60x y z-4(x y+x z+y z)]

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

With[{r=1},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,MaxRecursion->4]]

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

ByteCount/@%

FullSimplify[%%[[1]]]

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

RootApproximant[SingularPoints[eqn,{x,y,z},WorkingPrecision->100]]

Length[%]