Chmutov Surface

Author

Eric W. Weisstein
May 23, 2008

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

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

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

Definitions

LowerDiagonalMatrix[f_,n_Integer?NonNegative]:=Array[If[#≥#2,f[##],0]&,{n,n}]

UpperDiagonalMatrix[f_,n_Integer?NonNegative]:=Array[If[#≤#2,f[##],0]&,{n,n}]

ChmutovMat[n_,{x1_,x2_}]:=x1 IdentityMatrix[n]+LowerDiagonalMatrix[If[#1==2&&#2==1,x2,0]+If[#1==3&&#2==1,2,0]+x2 KroneckerDelta[#2-#1,-1]+KroneckerDelta[#2-#1,-2]&,n]+UpperDiagonalMatrix[KroneckerDelta[#2-#1,1]&,n]

ChmutovP[n_,{x1_,x2_}]:=Total[Det[ChmutovMat[n,#]]&/@{{x1,x2},{x2,x1}}]

ChmutovSurface[n_,{x_,y_,z_}]:=ChmutovP[n,{x,y}]+ChebyshevT[n,z]

Chmutov's Original Version

ChmutovMat[7,{(Subscript[x, 1]),(Subscript[x, 2])}]//MatrixForm

ChmutovSurface[1,{x,y,z}]==0

ChmutovSurface[#,{x,y,z}]==0&/@Range[4]//Simplify//ColumnForm//TraditionalForm

1

eqn=Evaluate[ChmutovSurface[1,{x,y,z}]]

ContourPlot3D[Evaluate[ChmutovSurface[1,{x,y,z}]]==0,{x,-1,1},{y,-1,1},{z,-1,1}]

2

ChmutovSurface[2,{x,y,z}]

Expand[(((x-1))^2)+(((y-1))^2)+((z^2)/((((1/(Sqrt[2]))))^2))-1]

SingularPoints[ChmutovSurface[2,{x,y,z}],{x,y,z}]

ContourPlot3D[Evaluate[ChmutovSurface[2,{x,y,z}]],{x,-1,3},{y,-1,3},{z,-1,3/2}]

3

ChmutovSurface[3,{x,y,z}]

SingularPoints[ChmutovSurface[3,{x,y,z}],{x,y,z}]

Factor[ChmutovSurface[3,{x,y,z}][[1]]]

With[{r=5},ContourPlot3D[Evaluate[ChmutovSurface[3,{x,y,z}]],{x,-r,r},{y,-r,r},{z,-r,r},PlotPoints->30]]

3

ChmutovSurface[4,{x,y,z}]

Factor[ChmutovSurface[4,{x,y,z}][[1]]]

SingularPoints[ChmutovSurface[3,{x,y,z}],{x,y,z}]

With[{r=3},ContourPlot3D[Evaluate[ChmutovSurface[4,{x,y,z}]],{x,-r,r},{y,-r,r},{z,-r,r},PlotPoints->30]]

4

ChmutovSurface[4,{x,y,z}]

SingularPoints[ChmutovSurface[5,{x,y,z}],{x,y,z}]

Singular Points

pts[d_]:=Switch[Mod[d,6],
0,5d^3-13d^2+12d,
2|4,5d^3-13d^2+16d-8,
1|5,5d^3-14d^2+13d-4,
3,5d^3-14d^2+9d
]/12

pts/@Range[10]

Banchoff's Modification

Banchoff[n_,{x_,y_,z_}]:=ChebyshevT[n,x]+ChebyshevT[n,y]+ChebyshevT[n,z]

BanchoffPlot[n_,s_:1.23,opts___]:=
ContourPlot3D[Banchoff[n,{x,y,z}]==0,{x,-s,s},{y,-s,s},{z,-s,s},opts,Boxed->False,Axes->False]

AlgebraicDegree[#,{x,y,z}]&/@Table[Banchoff[n,{x,y,z}],{n,2,10,2}]

rmax=MaxValue[{x^2+y^2+z^2,Banchoff[#,{x,y,z}]==0},{x,y,z}]&/@Range[2,12,2]//FullSimplify

N[rmax]

max=MaxValue[{x,Banchoff[#,{x,y,z}]==0},{x,y,z}]&/@Range[2,10,2]//FullSimplify

N[max]

Order 2

FullSimplify[Banchoff[2,{x,y,z}]==0]

ChmutovPlot[2,1.225,PlotPoints->10]

BanchoffPlot[2]

RegionPlot3D[Banchoff[2,{x,y,z}]<0,{x,-2,2},{y,-2,2},{z,-2,2}]

Integrate[Boole[Banchoff[2,{x,y,z}]<0],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞}]

Order 4

FullSimplify[Banchoff[4,{x,y,z}]==0]

POVCoefficients[ChmutovSurface[4,{x,y,z}],{x,y,z}]

ChmutovPlot[4,1.2,PlotPoints->20]

RegionPlot3D[Banchoff[4,{x,y,z}]<0,{x,-2,2},{y,-2,2},{z,-2,2}]

NIntegrate[Boole[Evaluate[Banchoff[4,{x,y,z}]<0]],{x,-2,2},{y,-2,2},{z,-2,2}]

Integrate[Boole[Banchoff[4,{x,y,z}]<0],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞}]

Order 6

FullSimplify[ChmutovSurface[6,{x,y,z}]==0]

POVCoefficients[ChmutovSurface[6,{x,y,z}],{x,y,z}]

ChmutovPlot[6,1.4,PlotPoints->30]

Orders 2, 4, 6

Show[GraphicsArray[{
ChmutovPlot[2,1.225,PlotPoints->10,DisplayFunction->Identity],
ChmutovPlot[4,1.2,PlotPoints->20,DisplayFunction->Identity],
ChmutovPlot[6,1.4,PlotPoints->30,DisplayFunction->Identity]
}]]

BanchoffPlot/@Range[2,8,2]

Order 8

FullSimplify[ChmutovSurface[8,{x,y,z}]==0]

POVCoefficients[ChmutovSurface[8,{x,y,z}],{x,y,z}]

ChmutovPlot[8,1.4,PlotPoints->30]

Order 10

FullSimplify[ChmutovSurface[10,{x,y,z}]==0]

POVCoefficients[ChmutovSurface[10,{x,y,z}],{x,y,z}]

ChmutovPlot[10,1.4,PlotPoints->30]