Aerial Tour of Differential Geometry

Manipulate[
LocatorPane[Dynamic[stick,{(update=update0)&,(stick=#)&,(stick={0.,0.};update=∞)&}],
Graphics[{
Inset[
Show[
sights/.sightsToPlots,
Graphics3D[{
{Switch[#[[1,1]],-5.`,Hue[0],6.`,Hue[2/3.],_,Hue[1/3.]],Sphere[#,0.08]}&/@Delete[Partition[Tuples[Append[#,Mean[#]]&/@{{-5.`,5.`},{-5.`,5.`},{-5.`,5.`}}],9],{-1,-1}],
Dynamic[
Refresh[
If[dt≠0&&update≠∞,
With[{TT=Normalize[tv],NN=Normalize[(tv\[Cross]vv)\[Cross]tv],BB=tv\[Cross]vv},
vp+=TT dt/5000.;
tv=TT-3.5stick[[2]]NN dt/5000.;
vv=NN+(3.5stick[[2]]TT+2.5stick[[1]]BB)dt/5000.;
rt=BB;
]];
{Red,If[view===Hold[{vp+vv,vp,tv}]||view===Hold[{vp+{0.`,0.`,3.`},vp,{1.,0.,0.}}]||view===Hold[{vp+{0.`,0.`,-3.`},vp,{1.,0.,0.}}],{EdgeForm[],Cone[{vp-0.2tv,vp},0.025],FaceForm[Darker[Purple],Lighter[Orange]],Polygon[{vp,vp-0.2tv-0.08(rt),vp-0.2tv+0.08(rt)}]},{}]},
UpdateInterval->update,TrackedSymbols:>{view}
]]
}],
Lighting->"Neutral",PlotRange->{{-5.`,6.`},{-4.`,7.`},{-5.`,5.5`}},PlotRangePadding->5.15,ImagePadding->100,ViewVector->Dynamic@Most[ReleaseHold[view]],ViewVertical->Dynamic@Last[ReleaseHold[view]],ViewAngle->35°,SphericalRegion->True,ImageSize->{450,400},Boxed->False,Axes->False]],
Dynamic@With[{x={.1,0,0}.Transpose[{rt,Normalize[rt\[Cross]tv]}],y={0,.1,0}.Transpose[{rt,Normalize[rt\[Cross]tv]}],z={0,0,.1}.Transpose[{rt,Normalize[rt\[Cross]tv]}],P={0,-0.9}},
{Thick,Darker@Blue,Line[{P,P+x}],Line[{P,P+y}],Darker@Red,Line[{P,P+z}],Black,Thin,Disk[P+{0.25,0},0.1,ArcTan@@z+{π/2,3π/2}],Circle[P+{0.25,0},0.1],Line[{P+{0.25,0},P+0.7z+{0.25,0}}],Circle[P-{0.25,0},0.1],Line[{P-{0.25,0},P-{0.25,0}+(0.09#[ArcTan@@Most[tv]]&/@{Cos,Sin})}],Point[P+vp.{x,y,z}/8]}
],
{LightGray,Line[{{{-1.2,0},{1.2,0}},{{0,-1},{0,1}}}]}
},ImageSize->{475,425},PlotLabel->Style["click and hold stick to fly","Label"],PlotRangeClipping->True,Background->LightBlue]
],

Row[{Control[{{dt,120.,"air speed"},0.,400.,Appearance->"Labeled"}],Control[{{update0,0.1,"step rate"},{0->"fast",0.1->"medium",0.25->"slow"},SetterBar,ControlPlacement->Left}]}],
{{sights,"helix"},{"Boy's","Costa","cow","cube of spheres","helix","Klein bottle","Kuen","Nobbly Wobbly","Schwarz D","torus","trefoil"},ControlType->SetterBar},
Item[Style["view",Bold],ControlPlacement->Left],
Control[{{view,Hold[{vp,vp+tv,vv}],""},Grid[Partition[Setter[Dynamic[view],#[[1]],#[[2]],BaseStyle->"Label",Appearance->"Palette",Alignment->Center,ImageSize->39]&/@{Hold[{vp,vp+vv,tv}]->"up",Hold[{vp,vp+tv,vv}]->"front",Hold[{vp+{0.`,0.`,3.`},vp,{1.,0.,0.}}]->Style["above",Italic],Hold[{vp,vp+-rt,vv}]->"left",Hold[{vp+vv,vp,tv}]->Style["top",Italic],Hold[{vp,vp+rt,vv}]->"right",Hold[{vp,vp+-vv,tv}]->"down",Hold[{vp,vp+-tv,vv}]->"rear",Hold[{vp+{0.`,0.`,-3.`},vp,{1.,0.,0.}}]->Style["below",Italic]},3],
Spacings->{0,0}
]&,ControlPlacement->Left}],
{{stick,{0,0}},None},{{vp,{2.`,-6.`,0.`}},None},{{vv,{0.`,0.`,1.`}},None},{{tv,{-0.24253562503633297`,0.9701425001453319`,0.`}},None},{{rt,{0.9701425001453319`,0.24253562503633297`,0.`}},None},{{update,∞},None},
TrackedSymbols:>{sights},AutorunSequencing->{{3,11}},
Initialization:>(
helix=With[{pp=With[{X=#,rad=0.20},
With[{TT=Chop[#/(Sqrt[#.#])&@D[X,θ]]},
With[{NN=Chop[#/(Sqrt[#.#])&@D[TT,θ]]},
With[{BB=Chop[TT\[Cross]NN]},
X+rad (Cos[α]NN+Sin[α]BB)
]]]]&@({Cos[θ],θ/6.,Sin[θ]})},
ParametricPlot3D[pp+{0,-1.5,0},{θ,0,5π},{α,0,2π},ColorFunction->Function[{x,y,z,θ,α},Hue[Mod[θ/4,1],0.7,1]],ColorFunctionScaling->False,Mesh->None,PlotPoints->{5 8+1,9},MaxRecursion->1,PerformanceGoal->"Speed"]
];torus:=torus=RevolutionPlot3D[{2+Cos[t],Sin[t]},{t,0,2π},PlotStyle->FaceForm[Red,Blue],Mesh->{3,5},MeshShading->{{Automatic,FaceForm[Yellow,Green]},{FaceForm[Yellow,Green],Automatic}},MeshStyle->None,PlotPoints->{3*1+1,7},MaxRecursion->2,NormalsFunction->None];cow:=cow=MapAt[Scale[Rotate[#,-π/4,{0,0,1}],5]&,Insert[ExampleData[{"Geometry3D","Cow"}],FaceForm[ColorData["GreenBrownTerrain"][0.75],Darker@Red],{1,2,2,1}],{1,2}];
knobblywobbly:=knobblywobbly=With[{v={0.16245984811645317`,0.5`,0.8506508083520399`},w={0.6708203932499368`,-0.6881909602355868`,0.276393202250021`}},With[{pp=Function[{vw},With[{X=#,rad=0.7},
With[{TT=Chop[#/(Sqrt[#.#])&@D[X,θ]]},
With[{BB=Chop@Normalize[vw[[1]]\[Cross]vw[[2]]]},
With[{NN=Chop[BB\[Cross]TT]},
0.4(X+rad (Cos[α]NN+Sin[α]BB))
]]]]&@(((5+Cos[5θ])(Cos[θ]vw[[1]]+Sin[θ]vw[[2]])))]/@Join[
Table[{RotationMatrix[2π k/5,{0,0,1}].v,RotationMatrix[2π k/5,{0,0,1}].w},{k,0,4}],
{{#,{0,0,1}\[Cross]#}&@Normalize[RotationMatrix[2π /20,{0,0,1}].{v[[1]],v[[2]],0}]}
]},
ParametricPlot3D[pp,{θ,0+π/40,2π+π/40},{α,0,2π},Mesh->None,PlotPoints->{5 6+1,9},PlotStyle->Table[Hue[k/6],{k,0,5}],MaxRecursion->1,PerformanceGoal->"Speed"]
]];
trefoil:=trefoil=With[{pp=With[{X=#,rad=0.3},
With[{TT=Chop[#/(Sqrt[#.#])&@D[X,θ]//Simplify]},
With[{NN=Chop[#/(Sqrt[#.#])&@D[TT,θ]]},
With[{BB=Chop[TT\[Cross]NN]//Simplify},
X+rad (Cos[α]NN+Sin[α]BB)
]]]]&@({Sin[θ]+2 Sin[2 θ],Cos[θ]-2 Cos[2 θ],-Sin[3 θ]})},
ParametricPlot3D[0.7pp,{θ,0,2π},{α,0,2π},ColorFunction->Function[{x,y,z,θ,α},ColorData["DarkRainbow"][((Sin[3θ])^2)]],ColorFunctionScaling->False,Mesh->None,PlotPoints->{3 16+1,9},MaxRecursion->0,PerformanceGoal->"Speed",NormalsFunction->None]
];balls:=balls=Graphics3D[{FaceForm[Magenta,Green],Tube[Flatten[Table[{{i,j,k},{i,j,k+0.001}},{i,-1,1},{j,-1,1},{k,-1,1}],2],0.495]}];Boys[w_]:=With[{g1=-(3/2)Im[((w(1-(w^4)))/((w^6)+(Sqrt[5])(w^3)-1))],g2=-(3/2)Re[((w(1+(w^4)))/((w^6)+(Sqrt[5])(w^3)-1))],g3=Im[(((1+(w^6)))/((w^6)+(Sqrt[5])(w^3)-1))]-(1/2)},
With[{g=(g1^2)+(g2^2)+(g3^2)},
{(g1/g),(g2/g),(g3/g)}
]];boys:=boys=ParametricPlot3D[{0,0,-1}-Boys[((1-(r^2)) (r^1.5)+(r^2) (0.9+0.1 r))(Cos[θ]+I Sin[θ])],{r,0,1},{θ,0,2π},PlotPoints->{25,31},Mesh->None,MaxRecursion->0,PlotStyle->FaceForm[RGBColor[0.8235294117647058`,0.13333333333333333`,0.38823529411764707`],RGBColor[0.5,0.6,1.]],BoundaryStyle->None,NormalsFunction->None];CostaN[u_,v_]:=(*Weisstein,Eric W."Costa Minimal Surface." From MathWorld--A Wolfram Web Resource.http://mathworld.wolfram.com/CostaMinimalSurface.html*)With[
{
g=WeierstrassInvariants[N@{1/2,I/2}],
e1=WeierstrassP[1/2,WeierstrassInvariants[N@{1/2,I/2}]]
},
With[
{
wz1=WeierstrassZeta[u+I v,g],
wz2=WeierstrassZeta[u+I v-1/2,g],
wz3=WeierstrassZeta[u+I v-I/2,g],
wp=WeierstrassP[u+I v,g]
},
{
Re[-wz1+Pi u+Pi^2/(4e1)+Pi/(2e1)(wz2-wz3)]/2,
Re[-I wz1+Pi v+Pi^2/(4e1)-I Pi/(2e1)(wz2-wz3)]/2,
Sqrt[2Pi]/4Log[Abs[(wp-e1)/(wp+e1)]]
}
]
];
costa:=costa=ParametricPlot3D[Evaluate[0.5CostaN[u,v]],{u,0,1},{v,0,1},RegionFunction->Function[{x,y,z},0.5(x)^2+0.5(y)^2+1.2(z)^2≤3.89],PlotPoints->33,MaxRecursion->3,PlotStyle->FaceForm[Blend[{Yellow,Red},0.2],Lighter[Purple,0.5]],PerformanceGoal->"Speed",NormalsFunction->None];
Relax[poly_GraphicsComplex]:=
With[{faces0=poly[[2,1]],N0=Length[poly[[1]]]},
With[{edges0=Union@@(Sort/@Partition[#,2,1,1]&/@faces0)},
With[{pts0=Flatten[
{#,Function[{e},Mean[#[[e]]]]/@edges0}&@poly[[1]],1]
},
With[{faces=Flatten[(({{#[[1,2]],Sort[#[[2]]],Sort[#[[1]]]}&/@Partition[#,2,1,1],{Sort/@#}})&/@(Partition[#,2,1,1]&/@faces0))/.MapIndexed[#1->N0+First[#2]&,Union@@(Sort/@Partition[#,2,1,1]&/@faces0)],
2]},
With[{pts=Table[If[MemberQ[pts0[[p]],-1/2|1/2],pts0[[p]],Mean[pts0[[DeleteCases[Union@@Select[faces,MemberQ[#,p]&],p]]]]],{p,Length[pts0]}]},
GraphicsComplex[
pts,
Polygon[
faces
]
]
]]]]];
AddVertexNormals[schwarzD_]:=Append[schwarzD,VertexNormals->With[{pts=schwarzD[[1]]},Function[{P0},
Switch[P0,
1|6,{0,0,-1},
2|5,{0,-1,0},
3|4,{-1,0,0},
6,{},
_,With[{faces=Select[schwarzD[[2,1]],MemberQ[#,P0]&]},
Switch[Length[faces],
6,Mean[If[#.{1,1,1}>0,-#,#]&/@(Cross@@#&/@((#-pts[[P0]])&/@pts[[DeleteCases[#,P0]]]&/@faces))],
3,(If[Abs[pts[[P0]][[1]]]≠1/2,{0,1,1},If[Abs[pts[[P0]][[2]]]≠1/2,{1,0,1},{1,1,0}]])Mean[If[#.{1,1,1}>0,-#,#]&/@(Cross@@#&/@((#-pts[[P0]])&/@pts[[DeleteCases[#,P0]]]&/@faces))],
_,Throw["huh?"]
]
]]]/@Range[Length[pts]]]];
schwarzD:=schwarzD=Graphics3D[Scale[#,0.7,{0,0,0}]&@{EdgeForm[],
Table[If[EvenQ[i+j+k],Translate[If[OddQ[k],#,Rotate[#,π,{0,0,1}]]&@(If[Mod[i-(((-1))^k)j-k,4]==0,#,Rotate[#,π,If[OddQ[k],{1,1,0},{1,-1,0}]]]&@(If[EvenQ[j+k],Rotate[#,π,{1,0,0}],#]&@(If[EvenQ[i+k],Rotate[#,π,{0,1,0}],#]&@AddVertexNormals[Relax@Relax@GraphicsComplex[
Append[Most@Rest@Tuples[{-1/2,1/2},3],{0,0,0}],
Polygon[Append[#,7]&/@Partition[{1,3,2,6,4,5},2,1,1]]
]]/.Polygon[faces_List]:>{
FaceForm[Yellow,Lighter@Magenta],Polygon[Select[faces,!MemberQ[#,34|42|39|25]&&!MemberQ[#,10|13|14|17|18|19]&]],
FaceForm[Lighter@Blue,Red],Polygon[Select[faces,MemberQ[#,34|42|39|25]&&MemberQ[#,10|13|14|17|18|19]&]],FaceForm[Yellow,Red],Polygon[Select[faces,!MemberQ[#,34|42|39|25]&&MemberQ[#,10|13|14|17|18|19]&]],
FaceForm[Lighter@Blue,Lighter@Magenta],Polygon[Select[faces,MemberQ[#,34|42|39|25]&&!MemberQ[#,10|13|14|17|18|19]&]]}))),{i,j,k}],{}],{i,-1,2},{j,-1,2},{k,-1,2}]
}];kuen:=kuen=ParametricPlot3D[{((2 Cosh[v] (Cos[u]+u Sin[u]))/((u^2)+((Cosh[v])^2))),((2 Cosh[v] (-u Cos[u]+Sin[u]))/((u^2)+((Cosh[v])^2))),v-((2 Cosh[v] Sinh[v])/((u^2)+((Cosh[v])^2)))},{u,-4.25,4.25},{v,-4.5,4.5},PlotStyle->FaceForm[White,Red],Mesh->None,PerformanceGoal->"Quality",PlotRange->All];klein:=klein=ParametricPlot3D[0.6{(2+Cos[v/2]*Sin[u]-Sin[v/2]*Sin[2*u])*Cos[v],(2+Cos[v/2]*Sin[u]-Sin[v/2]*Sin[2*u])*Sin[v],1.5(Sin[v/2]*Sin[u]+Cos[v/2]*Sin[2*u])},{u,0,2*Pi},{v,0,2π},PlotStyle->FaceForm[Darker@Magenta,Blend[{Yellow,Orange}]],Mesh->None,PerformanceGoal->"Quality"];
sightsToPlots={"cow":>cow,"Boy's":>boys,"Costa":>costa,"cube of spheres":>balls,"helix":>helix,"Klein bottle":>klein,"Kuen":>kuen,"Nobbly Wobbly":>knobblywobbly,"Schwarz D":>schwarzD,"torus":>torus,"trefoil":>trefoil}
)]

Caption

Grab the locator with the mouse and start flying. The x coordinate controls the torsion and the y coordinate controls the curvature of the path flown. Select various surfaces and figures from differential geometry and topology. Shoot the helical tube!

Details

The small red, green, and blue spheres merely help to orient one's flight. There is no other background. The view directions, front/rear, left/right, and up/down, are from the point that is flying; the view directions top/above/below are toward the point that is flying. The "top" is defined as from the tip of the normal vector to the path when the "stick" is pulled straight "back", that is, when the locator is directly below center. Hint: the wings of the flying craft are purple on top; on the bottom they are orange.

You may select more than one sight at a time, although the more there are, the longer it takes for them to be rendered. The sights include the following:

Boy's surface — a closed, nonorientable surface due to Werner Boy. Hence it is one-sided, like a Möbius band or Klein bottle. However, each of the polygons constituting the model of the surface are colored differently on each side, so the color mismatches of adjacent polygons reveal the one-sidedness. Like all closed, nonorientable surfaces, it cannot be embedded in space and so the model intersects itself.

Costa surface — a minimal surface.

Cow — topologically a sphere.

Cube of spheres — not that interesting mathematically, perhaps, but fun to fly around.

Helix — actually a helical tube; a helix has constant curvature and torsion. Theoretically, once the path is properly aligned, one can fly through the whole tube without moving the mouse.

Klein bottle — a closed, nonorientable surface.

Kuen surface — another minimal surface.

Nobbly Wobbly — a toy, which is connected with the outer automorphism of (Subscript[S, 6]) (the symmetric group of degree six). See B. Howard, J. Millson, A. Snowden, and R. Vakil, "A Description of the Outer Automorphism of (Subscript[S, 6]), and the Invariants of Six Points in Projective Space," Journal of Combinatorial Theory, Series A, 115(7), 2008 pp. 1296–1303.

Schwarz D surface — a triply periodic minimal surface.

Torus — a genus-one surface.

Trefoil — actually a tubular neighborhood around the trefoil knot.

THIS NOTEBOOK IS THE SOURCE CODE FROM

"Aerial Tour of Differential Geometry" from The Wolfram Demonstrations Project
 http://demonstrations.wolfram.com/AerialTourOfDifferentialGeometry/

Contributed by: Michael Rogers (Oxford College of Emory University)

A full-function Wolfram Mathematica system (Version 6 or higher) is required to edit this notebook.
GET WOLFRAM MATHEMATICA »

© The Wolfram Demonstrations Project & Contributors   |   Terms of Use   |   Make a new version of this Demonstration »