Moebius Strip

Author

Eric W. Weisstein
June 10, 2014

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

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

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

Additional Authors

Möbius gears animation by
Michael Trott
November 19, 2001

Definition

Moebius[R_][s_,t_]:={(R+s Cos[t/2])Cos[t],(R+s Cos[t/2])Sin[t],s Sin[t/2]}

Plots

Built-In

<<Graphics`Shapes`

Show[Graphics3D[MoebiusStrip[]],Boxed->False]

Show[Graphics3D[{EdgeForm[],MoebiusStrip[]}],Boxed->False]

Equation

Moebius[a][u,v]

eqns=Append[Thread[{x,y,z}==TrigExpand[Moebius[a][u,v]]],Sin[v/2]^2+Cos[v/2]^2==1]

{eqn}=Factor/@GroebnerBasis[eqns,{x,y,z},{u,Cos[v/2],Sin[v/2]},MonomialOrder->EliminationOrder]

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

eqn/.R->1

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

Parametrically

MobiusStrip[n_:2,R_:4,w:_1,opts___]:=
  ParametricPlot3D[Evaluate[Mobius[s,t,n,R]],{s,-w,w},{t,0,2Pi},DisplayFunction->Identity, PlotPoints->{5,30},opts][[1]]

e=({(R+ s Cos[θ/2])Cos[θ],(R+ s Cos[θ/2])Sin[θ],s Sin[θ/2]} /. s->-1)-
	({(R+ s Cos[θ/2])Cos[θ],(R+ s Cos[θ/2])Sin[θ],s Sin[θ/2]} /. s->1)

FullSimplify[Expand[Sqrt[e.e]]]

PowerExpand[FullSimplify[Sqrt[((R+ s Cos[θ/2])Cos[θ])^2+((R+ s Cos[θ/2])Sin[θ])^2]]]

PowerExpand[FullSimplify[Sqrt[((R+ s Cos[θ/2])Cos[θ])^2+((R+ s Cos[θ/2])Sin[θ])^2+(s Sin[θ/2])^2]]]

V5

Show[Graphics3D[{EdgeForm[],MobiusStrip[2,4,2,PlotPoints->{15,15}]}],Boxed->False]

V6

ParametricPlot3D[Moebius[2][s,t],{s,-.5,.5},{t,0,2π},Mesh->{5,40}]

LiveGraphics3D

<<Utilities`LiveGraphics3D`

WriteLiveForm["mobius.m",Show[Graphics3D[MobiusStrip[2,4,1]]]]

WriteLiveForm["mobius.m",Show[Graphics3D[{EdgeForm[],MobiusStrip[2,4,1]}],opts]]

V6

ParametricPlot3D[Moebius[1][s,t],{s,-#,#},{t,0,2Pi},Boxed->False,Axes->False,Mesh->None]&/@{.2,.5,1,2}

Möbius Gears

From mtrott@wolfram.com Mon Nov 19 15:33:31 2001
Date:Mon,19 Nov 2001 21:00:38+0000
From:Michael Trott<mtrott@wolfram.com>
Subject:Moebius gear

idea from http://www.sover.net/~tlongtin/index_old.html

gearTooth[mp_,Ri_,Ro_,δ_,n_,φ0_,h_,{ppt_,ppz_,ppφ_}]:=(f=(Ro+δ Cos[n (φ+φ0)]){Cos[φ],Sin[φ]};
points2D=Table[Evaluate[(1-t) Ri {Cos[φ],Sin[φ]}+t f+mp],{t,0,1,1/ppt},{φ,0,2Pi,2Pi/ppφ}]//N;
{upperPolys,lowerPolys}=Function[s,Table[Polygon[Append[#,s h]&/@{points2D[[i,j]],points2D[[i,j+1]],points2D[[i+1,j+1]],points2D[[i+1,j]]}],{i,ppt},{j,ppφ}]]/@{+1,-1};
{outerVerticalPolys,innerVerticalPolys}=Table[aux1=Append[#,First[#]]&[Transpose[{Append[#,+h]&/@points2D[[k]],Append[#,-h]&/@points2D[[k]]}]];
aux2=Apply[Table[#1+ζ (#2-#1),{ζ,0,1,1/ppz}]&,aux1,{1}];
Table[Polygon[{aux2[[i,j]],aux2[[i,j+1]],aux2[[i+1,j+1]],aux2[[i+1,j]]}],{i,ppφ+1},{j,ppz}],{k,-1,1,2}];
{upperPolys,lowerPolys,innerVerticalPolys,outerVerticalPolys,Line[Append[#,-h]&/@points2D[[-1]]],Line[Append[#,+h]&/@points2D[[-1]]],Line[Append[#,-h]&/@points2D[[+1]]],Line[Append[#,+h]&/@points2D[[+1]]]})

gearChain[o_,φ0_]:=Flatten[Transpose[{Table[gearTooth[{X,0},7/12,1,1/8,11,+φ0,1/8,{3,3,60}],{X,0,4 (o-1),4}],Table[gearTooth[{X,0},7/12,1,1/8,11,-φ0,1/8,{3,3,60}],{X,2,2+4 (o-1),4}]}],1]//Drop[#,-1]&;

mobius[s_,φ_,{R_,L_}]={{Cos[φ],Sin[φ],0},{-Sin[φ],Cos[φ],0},{0,0,1}}.{R+s/L Cos[φ/4],0,s Sin[φ/4]};

normal[s_,φ_,{R_,L_}]=Cross[D[mobius[s,φ,{R,L}],φ],D[mobius[s,φ,{R,L}],s]]//Simplify;

normalizedNormal[s_,φ_,{R_,L_}]:=#/Sqrt[#.#]&[normal[s,φ,{R,L}]]

toMobius[{x_,y_,z_},o_]:=mobius[y,4Pi x/(4o-2),{(o-1/2)/Pi,1}]+normalizedNormal[y,4Pi x/(4o-2),{(o-1/2)/Pi,1}] z

o=8;
δ=1/8;
frames=12;λ=o/Pi+1+δ;

movie=Table[Show[Graphics3D[{EdgeForm[],Thickness[0.002],MapIndexed[{SurfaceColor[Hue[#2[[1]]/(2o)],Hue[#2[[1]]/(2o)],2.6],#1}&,Map[toMobius[#,o]&,gc=gearChain[o,φ0],{-2}]]}],Axes->False,Boxed->False,PlotRange->{{-λ,λ},{-λ,λ},(1+δ) {-1,1}}],{φ0,0,2Pi/11 (1-1/frames),2Pi/11/frames}];

gifs="/Volumes/Data/Troves/MathOzTeX/newgifs/";

Export[gifs<>"moebgear.gif",movie]//Timing

Boundary

Mobius[s_,R_:4,t_]:={(R+s Cos[t/2])Cos[t],(R+s Cos[t/2])Sin[t],s Sin[t/2]}

MobiusStrip[n_:2,R_:4,w_:1,opts___]:=
  ParametricPlot3D[Evaluate[Mobius[s,R,t]],{s,-w,w},{t,0,2Pi},
  PlotPoints->{5,30},opts]

Show[{Graphics3D[{Thickness[.02],RGBColor[1,0,0],ParametricPlot3D[Evaluate[Mobius[1,4,t]],{t,0,2Pi},DisplayFunction->Identity][[1]]}],
MobiusStrip[2,4,1,DisplayFunction->Identity]}]

Arc Length

Integrate[(Sqrt[(R^2)+((3 (s^2))/4)+2 R s Cos[(t/2)]+(1/2) (s^2) Cos[t]]),{s,-w,w},{t,0,2Pi}]

FullSimplify[Sqrt[#.#]&[D[Mobius[w,t,n,R],t]^2]]

Integrate[%,{t,0,4Pi}]

strip=Block[{R=1,w=.2},ParametricPlot3D[{(R+s Cos[t/2])Cos[t],(R+s Cos[t/2])Sin[t],s Sin[t/2]},{s,-w,w},{t,0,2π},Axes->False,Boxed->False]]

reg=DiscretizeGraphics[strip]

Head[reg]

RegionBoundary[reg]

Curvatures

Curvatures[Moebius[a][u,v],{u,v},FullSimplify[#,a>0&&(u|v)∈Reals]&]

PrincipalCurvatures

FullSimplify[PrincipalCurvatures[Moebius[a][u,v],{u,v}],a>0&&(u|v)∈Reals]

GaussianCurvature

SortBy[FullSimplify[GaussianCurvature[eqn,{x,y,z}],a>0&&(x|y|z)∈Reals],ByteCount]

ByteCount/@%

Coloring

Show[Graphics[{
Line[{{0,0},{5,0},{5,1},{0,1},{0,0}}],
Line[{{2,0},{2,1}}],
Line[{{3,0},{3,1}}],
Text["2",{1,1/2}],
Text["2",{4,1/2}],
Text["1",{2.5,.5}]
},AspectRatio->Automatic]]

Metric Properties

Metric Tensor

MetricTensor[Moebius[a][u,v],{u,v}]//FullSimplify

Christoffel Symbol of the Second Kind

FullSimplify[ChristoffelSymbols[Moebius[a][u,v],{u,v}],a>0]

Vector Properties

eqn={(a+u Cos[v/2]) Cos[v],(a+u Cos[v/2]) Sin[v],u Sin[v/2]};
rules={Abs[x_]^(n_/;Mod[n,2]==0):>x^n};
assum=a>0&&b>0&&u∈Reals&&0<v<2;

Vector Length

Assuming[assum,FullSimplify[Norm[eqn]/.rules]]

Normal Vector

Assuming[assum,FullSimplify[NormalVector[eqn,{u,v}]/.rules]]