Compact Manifold

Author

Eric W. Weisstein
August 13, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Topology/CompactManifold.nb.

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

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

Graphic

<<Graphics`Shapes`
<<Graphics`ContourPlot3D`
<<Graphics`Arrow`

sphere=Graphics3D[{EdgeForm[],Sphere[]},Boxed->False,PlotLabel->StyleForm["sphere",FontFamily->"Times",FontSlant->"Italic"]];
torus=Graphics3D[{EdgeForm[],Torus[]},Boxed->False,PlotLabel->StyleForm["torus",FontFamily->"Times",FontSlant->"Italic"]];

klein=With[
{
bx=6 Cos[u] (1+Sin[u]),
by=16 Sin[u],
rad=4 (1-Cos[u]/2)
},
Module[{X=If[Pi<u≤2 Pi,bx+rad Cos[v+Pi],bx+rad Cos[u] Cos[v]],
Y=If[Pi<u≤2 Pi,by,by+rad Sin[u] Cos[v]],
Z=rad Sin[v]
},
ParametricPlot3D[{X,Y,Z,EdgeForm[]},{u,0,2 Pi},{v,0,2 Pi},PlotPoints->{48,12},Axes->False,Boxed->False,
DisplayFunction->Identity,
ViewPoint->{1.4,-2.6,-1.7},
PlotLabel->StyleForm["Klein bottle",FontFamily->"Times",FontSlant->"Italic"]
]
]];

torusImplicit[{x_,y_,z_},R_,r_]=(x^2+y^2+z^2)^2-2(R^2+r^2) (x^2+y^2)+2(R^2-r^2) z^2+(R^2-r^2)^2;
torus2=Module[{f,cp,polys},f=Product[torusImplicit[{x+i,y,z},1,1/4],{i,-5/4,5/4,5/2}]-2;
cp=ContourPlot3D[Evaluate[f],{x,0,3},{y,0,2},{z,0,0.6},PlotPoints->2{24,20,12},MaxRecursion->0,DisplayFunction->Identity];
polys=Cases[cp,_Polygon,{0,Infinity}];
Graphics3D[{EdgeForm[],
Flatten[{#,Map[#{-1,1,1}&,#,{-2}]}]&[Flatten[{#,Map[# {1,-1,1}&,#,{-2}]}]&[Flatten[{polys,Map[# {1,1,-1}&,polys,{-2}]}]]]
},Boxed->False,
PlotLabel->StyleForm["double torus",FontFamily->"Times",FontSlant->"Italic"]]
];//Timing

CrossCap[f_:1]:=Module[{t,p},Graphics3D[{EdgeForm[],ParametricPlot3D[crosscap[{t,p},f],{t,0,2Pi},{p,0,Pi/2},Boxed->False,DisplayFunction->Identity,Ticks->None][[1]]},PlotLabel->StyleForm["cross surface",FontFamily->"Times",FontSlant->"Italic"],ViewPoint->{.2,-2,.7},
Boxed->False]
]

x[t_,p_]:=Cos[t]Sin[p]
y[t_,p_]:=Sin[t]Sin[p]
z[t_,p_]:=Cos[p]

crosscap[{t_,p_},f_]:={f x[t,p]z[t,p],f y[t,p]z[t,p],(z[t,p]^2-x[t,p]^2)/2}

cross=CrossCap[];

rpp=Graphics[{{GrayLevel[.7],Rectangle[-{1,1},{1,1}]},
Arrow@@@Partition[Sqrt[2]Through[{Cos,Sin}[Pi/2 (#+1/2)]]&/@Range[4],2,1,1]},
PlotLabel->StyleForm["real projective plane",FontFamily->"Times",FontSlant->"Italic"],
AspectRatio->Automatic];

Show[GraphicsArray[
{
{sphere,torus,torus2},
{{},cross,klein}
}],GraphicsSpacing->{-.1,-.1}]