Moebius Net

Author

Eric W. Weisstein
October 4, 2002

This notebook downloaded from http://mathworld.wolfram.com/notebooks/PlaneGeometry/MoebiusNet.nb.

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

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

Initialization

<<Graphics`Colors`;
<<PlaneGeometry`

Code

Moebius[t_Triangle,p_Point,num_]:=Module[{o,x0,y0,x,y,z},
{o,x0,y0}=Vertices[t];
z=Coordinates@Intersections[Line[{o,Coordinates@p}],Line[{x0,y0}]];
x[0]:=o;
y[0]:=o;
x[1]:=Coordinates@Intersections[Line[{y0,Coordinates@p}],Line[{o,x0}]];
y[1]:=
Coordinates@Intersections[Line[{x0,Coordinates@p}],Line[{o,y0}]];
x[n_]:=x[n]=Coordinates@Intersections[Line[{Coordinates@Intersections[Line[{x0,y[1]}],Line[{z,x[n-1]}]],y0}],Line[{o,x0}]];
y[n_]:=y[n]=Coordinates@Intersections[Line[{Coordinates@Intersections[Line[{y0,x[1]}],Line[{z,y[n-1]}]],x0}],Line[{o,y0}]];
{Table[x[n],{n,0,num}],Table[y[n],{n,0,num}]}
]

MoebiusLines[t_Triangle,_Point,num_]:=Module[
{
pts=Rest/@Moebius[t,pt,num],
o,x0,y0,
i,j,p
},
{o,x0,y0}=Vertices[t];
{Line/@({y0,#}&/@pts[[1]]),Line/@({x0,#}&/@pts[[2]])}
]

MoebiusPoint[t_Triangle,pt_Point,{m_,n_}]:=Module[
{
pts=Moebius[t,pt,Max[m,n]+1],
o,x0,y0,
},
{o,x0,y0}=Vertices[t];
Coordinates@Intersections[Line[{y0,pts[[1,m+1]]}],Line[{x0,pts[[2,n+1]]}]]
]

MoebiusGrid[t_Triangle,pt_Point,num_,parity_:0]:=Module[
{
pts=Moebius[t,pt,num+1],
o,x0,y0,
i,j,p
},
{o,x0,y0}=Vertices[t];
p[m_,n_]:=Coordinates@Intersections[Line[{y0,pts[[1,m+1]]}],Line[{x0,pts[[2,n+1]]}]];
Table[Polygon[{
p[i+Mod[j+parity,2],j],
p[i+1+Mod[j+parity,2],j],
p[i+1+Mod[j+parity,2],j+1],
p[i+Mod[j+parity,2],j+1]
}],{i,0,num-1,2},{j,0,num-1}]
]

Figures

t=Triangle[{{0,0},{1,0},{.3,.5}}];
pt=Point[{.2,.1}];

labels={{O,{-.05,-.05}},{X,{1.05,-.05}},{Y,{.3,.55}}};
labels1={{(Subscript[Y, 1]),{.02,.13}},{(Subscript[X, 1]),{.18,-.05}},{(Subscript[P, 1,1]),{.3,.14}}};

pts=MoebiusNetPoints[t,pt,2];
Show[GraphicsArray[Graphics[#,AspectRatio->Automatic,PlotRange->All]&/@{
{t,Text[#1//TraditionalForm,#2]&@@@labels},
{
Text[#1//TraditionalForm,#2]&@@@labels,
Text[#1//TraditionalForm,#2]&@@@labels1,
{Yellow,MoebiusGrid[t,pt,1]},
{Dashing[{1,1}.02],MoebiusLines[t,pt,1]},
t
}
}]]

labels1={{(Subscript[Y, 1]),{.02,.13}},{(Subscript[X, 1]),{.18,-.05}},
{(Subscript[X, 2]),{.3,-.05}},{(Subscript[P, 1,1]),{.15,.16}},{(Subscript[P, 2,1]),{.35,.14}}};

pts=Moebius[t,pt,2];
v=Vertices[t];
Show[GraphicsArray[Graphics[#,AspectRatio->Automatic,PlotRange->All]&/@{
{
Text[#1//TraditionalForm,#2]&@@@labels,
Text[#1//TraditionalForm,#2]&@@@labels1,
{Yellow,MoebiusGrid[t,pt,2,1][[1,1]]},
{Dashing[{1,1}.02],Delete[MoebiusLines[t,pt,2],{{2,2}}]},
t,
Line[{v[[1]],z=Coordinates@Intersections[
Line[{v[[1]],Coordinates@pt}],
Line[v[[{2,3}]]]
]}],
Line[{z,pts[[1,3]]}]
},
{
Text[#1//TraditionalForm,#2]&@@@labels,
Text[#1//TraditionalForm,#2]&@@@labels1,
{Yellow,MoebiusGrid[t,pt,2][[1,2]]},
{Dashing[{1,1}.02],MoebiusLines[t,pt,2]},
t,
Line[{v[[1]],z=Coordinates@Intersections[
Line[{v[[1]],Coordinates@pt}],
Line[v[[{2,3}]]]
]}],
Line[{z,pts[[1,2]]}]
}
}]]

Show[Graphics[{t,MoebiusLines[t,pt,200]}],PlotRange->All]//Timing

Show[Graphics[{t,MoebiusNetGrid[t,pt,150]}],PlotRange->All]//Timing

{x,y}=Moebius[t,pt,3];

Show[GraphicsArray[Graphics[#,AspectRatio->Automatic]&/@{{
t,
Text[#1//TraditionalForm,#2]&@@@labels,
{{Dashing[{1,1}.025],Last[#]},{Thickness[.01],Line[v[[{1,3}]]],First[#]}}&@MoebiusLines[t,pt,3],
Line[{z,#}]&/@Moebius[t,pt,3][[1]],
{Thickness[.01],
Transpose[{{Blue,Red,Green},Line/@Partition[x,2,1]}],
Transpose[{{Blue,Red,Green},Line/@Partition[Table[MoebiusPoint[t,pt,{i,1}],{i,0,3}],2,1]}]}
},
{
t,
Text[#1//TraditionalForm,#2]&@@@labels,
{Dashing[{1,1}.025],Last[#],Line[v[[{1,3}]]],First[#]}&@MoebiusLines[t,pt,3],
{Thickness[.01],Line[{z,#}]&/@Moebius[t,pt,3][[1]]},
{Thickness[.01],
Transpose[{{Blue,Red,Green},Line/@Partition[x,2,1]}],
Transpose[{{Blue,Red,Green},Line/@Partition[Table[MoebiusPoint[t,pt,{i,1}],{i,1,4}],2,1]}]}
}}]]