Billiards

Author

Eric W. Weisstein
September 11, 2007

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

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

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

Additional Authors

Original BilliardPolygon code by
Robert Dickau

EllipticalBilliards by
Stan Wagon

Comments

This code was written a long time ago. Eric should really rewrite it to be more efficient and elegant.

Integer Billiard Table (2-D)

<<Graphics`Arrow`

addn[n_,k_,m_]:=Mod[n+k-1,m]+1

BilliardPath[m_,n_]:=Module[
{
dir=1,
p={{0,0}},
v={{1,1},{-1,1},{-1,-1},{1,-1}},side={{{m,0},{m,1}},{{1,n},{0,n}},{{0,0},{0,1}},{{0,0},{1,0}}},
i,l,d,intersect
},
While[Length[p]==1||!MemberQ[{{0,0},{m,0},{m,n},{0,n}},p[[-1]]],l=Coordinates/@Table[Intersections[Line[{p[[-1]],p[[-1]]+v[[dir]]}],Line[side[[addn[dir,i,4]]]]],{i,0,1}];
d=Table[(p[[-1]]-l[[i]]).(p[[-1]]-l[[i]]),{i,2}];
intersect=Position[d,Min[d]][[1,1]];
AppendTo[p,l[[intersect]]];
dir=addn[dir,3-2intersect,4];
];
Table[Arrow[p[[i]],p[[i+1]],HeadScaling->Absolute],{i,Length[p]-1}]
]

BilliardTable[m_,n_]:=Module[{eps=.1Min[m,n]},{{GrayLevel[.5],Disk[{0,0},eps,{0,Pi/2}],Disk[{0,n},eps,{3Pi/2,2Pi}],Disk[{m,n},eps,{Pi,3Pi/2}],Disk[{m,0},eps,{Pi/2,Pi}]},Circle[{0,0},eps,{0,Pi/2}],Circle[{0,n},eps,{3Pi/2,2Pi}],Circle[{m,n},eps,{Pi,3Pi/2}],Circle[{m,0},eps,{Pi/2,Pi}],Line[{{0,0},{0,n},{m,n},{m,0},{0,0}}],Line[{{-eps,-eps},{-eps,n+eps},{m+eps,n+eps},{m+eps,-eps},{-eps,-eps}}]}
]

BilliardDiagram[m_Integer?Positive,n_Integer?Positive]:=
{BilliardTable[m,n],BilliardPath[m,n]}/;GCD[m,n]==1

Show[GraphicsArray[Graphics[BilliardDiagram[Sequence@@#],AspectRatio->Automatic]&/@{{1,2},{2,3},{3,5}}]]

Polygons

Modified from original code by Robert Dickau

lineFromCorners[{p1:{x1_,y1_},p2:{x2_,y2_}}]:=
With[{aslope=Divide@@Reverse[p1-p2]},y==y1+aslope(x-x1)];

BilliardPolygon[sides_,start_,angle_,n_]:=
Module[{impderiv,corners,cushions,slopes,pos,dir,traj,slope,path,solns,solnrules,hit,eps=10^(-10)},
impderiv[{x1_,y1_}]:=
slopes[[Position[(First[#]-Last[#])&/@cushions/.Thread[{x,y}->{x1,y1}],_?(Abs[#]<eps&)][[1,1]]]];
corners=Partition[{Cos[#],Sin[#]}&/@Range[0.1,2π+0.1,2π/sides],2,1];
slopes=(Divide@@Reverse[#[[1]]-#[[2]]])&/@corners;
cushions=lineFromCorners/@corners;
traj={pos=start};
slope=Tan[dir=angle];
path=(y-pos[[2]]==slope*(x-pos[[1]]));
solnrules=Solve[{path,Or@@cushions},{x,y}];
solns=Select[{x,y}/.solnrules,Plus@@(#^2)<=1.0&];
hit=Select[solns,And@@Thread[#>pos]&];
AppendTo[traj,hit[[1]]];
Do[
slope=Tan[2π-(Apply[ArcTan,hit[[1]]-pos]-ArcTan[impderiv[hit[[1]]]]) +ArcTan[impderiv[hit[[1]]]]];
pos=hit[[1]];
path=(y-pos[[2]]==slope*(x-pos[[1]]));
solnrules=Solve[{path,Or@@cushions},{x,y}];
solns=Select[{x,y}/.solnrules,Plus@@(#^2)<=1.0&];
hit=Select[solns,(#-pos).(#-pos)>eps&];
AppendTo[traj,hit[[1]]],
{n}
];
Graphics[{{Thickness[0.02],RGBColor[0,0.75,0.15],Line[{Cos[#],Sin[#]}&/@Range[0.1,2π+0.1,2π/sides]]},Line[traj]},AspectRatio->Automatic,Frame->False,Axes->False]
]

Show[GraphicsArray[Table[BilliardPolygon[n,{.01,.1},π/12,15],{n,3,5}]]]

Cube

BilliardMovie[s_,p0_List,c_,opts___]:=Module[{p=Append[p0,p0[[1]]],l=0,i=1,j,ll,lu,v=p0[[1]],frame},
	ll=Table[Sqrt[(p[[j+1]]-p[[j]]).(p[[j+1]]-p[[j]])],{j,Length[p]-1}];
	ltot=Plus@@ll;
	lu=Table[(p[[j+1]]-p[[j]])/ll[[j]],{j,Length[p]-1}];
	frame={Show[Graphics3D[{c,PointSize[.05],Point[v]}],Boxed->False,opts]};
	While[l<ltot,
		If[l<Sum[ll[[j]],{j,i}],
				v+=s lu[[i]],
				i++;v=p[[i]]+lu[[i]](s-Sqrt[(p[[i]]-v).(p[[i]]-v)]);
		];
		l+=s;
		AppendTo[frame,Show[Graphics3D[{c,PointSize[.05],Point[v]}],Boxed->False,opts]];
	];
frame
]

CubePathVerts={{0,2,2},{1,3,1},{2,2,0},{3,1,1},{2,0,2},{1,1,3}}/3;

CubePath:=Module[{p=CubePathVerts},Line[Append[p,p[[1]]]]]

CubeEdges:={
Table[Line[{{x,0,0},{x,0,1},{x,1,1},{x,1,0},{x,0,0}}],{x,0,1,1/3}],
Table[Line[{{0,y,0},{0,y,1},{1,y,1},{1,y,0},{0,y,0}}],{y,0,1,1/3}],
Table[Line[{{0,0,z},{0,1,z},{1,1,z},{1,0,z},{0,0,z}}],{z,0,1,1/3}]
};

CubeEdges:={
Table[Line[{{x,y,0},{x,y,1}}],{x,0,1},{y,0,1}],Table[Line[{{0,0,z},{1,0,z},{1,1,z},{0,1,z},{0,0,z}}],{z,0,1}],Table[Line[{{x,1/3,1/3},{x,1/3,2/3},{x,2/3,2/3},{x,2/3,1/3},{x,1/3,1/3}}],{x,0,1}],Table[Line[{{1/3,y,1/3},{1/3,y,2/3},{2/3,y,2/3},{2/3,y,1/3},{1/3,y,1/3}}],{y,0,1}],Table[Line[{{1/3,1/3,z},{1/3,2/3,z},{2/3,2/3,z},{2/3,1/3,z},{1/3,1/3,z}}],{z,0,1}]
};

cCube={CubeEdges,
{Thickness[.015],CubePath},
{PointSize[.03],Point/@CubePathVerts}
};

l=CubePath[[1]];
Table[Sqrt[(l[[i+1]]-l[[i]]).(l[[i+1]]-l[[i]])],{i,Length[l]-1}]

movie=BilliardMovie[.1,CubePathVerts,cCube,
ViewPoint->{0.9885487176845102, 0.9604786476742089, 3.0903482328252645},
ViewVertical->{-0.06305530606989318, 0.9585800408650043, -0.2777558885634633},
PlotRange->{{-.1,1.1},{-.1,1.1},{-.1,1.1}}];

LiveGraphics3D

<<LiveGraphics3D`

WriteLiveAnimationForm["billcube.m",movie]

Tetrahedron

tri[v_List]:=Module[{s=Plus@@v/3,i},
	line[Table[s+(v[[i]]-s)/10,{i,3}]]
]

line[v_List]:=Line[Append[v,v[[1]]]]

tris=FullSimplify[tri/@({
			{{0,0,0},{0,1,1},{1,1,0}},
			{{1,1,0},{0,1,1},{1,0,1}},
			{{0,0,0},{1,0,1},{1,1,0}},
			{{0,0,0},{1,0,1},{0,1,1}}}/Sqrt[2])];

v={{3/10,7/10,2/5},{3/10,3/10,3/5},{7/10,3/10,2/5},{7/10,7/10,3/5}}/Sqrt[2];
l=Append[v,v[[1]]]

Simplify[Table[Sqrt[(l[[i+1]]-l[[i]]).(l[[i+1]]-l[[i]])],{i,Length[l]-1}]]

TetPathVerts={{3/10,7/10,2/5},{3/10,3/10,3/5},{7/10,3/10,2/5},{7/10,7/10,3/5}}/Sqrt[2];

TetPath:=Module[{p=TetPathVerts},Line[Append[p,p[[1]]]]]

TetEdges:={
Line[{{0,0,0},{0,1,1},{1,1,0},{0,0,0},{1,0,1},{1,1,0},{0,1,1},{1,0,1}}/Sqrt[2]]
}

cTet={TetEdges,tris,
{Thickness[.015],TetPath},
{PointSize[.03],Point/@TetPathVerts}
};

movie=BilliardMovie[.05,TetPathVerts,cTet,
ViewPoint->{3.2926311571550424, -0.74959621487797, -0.21606845575531192},
ViewVertical->{0.15807128589082617, 0.8426877718911794, -0.5146754197374307}]

LiveGraphics3D

<<LiveGraphics3D`;

WriteLiveAnimationForm["billtet.m",movie]

Elliptical Billiard Table

EllipticalBilliards based on routines by S. Wagon appearing in Mathematica in Action.

EllipticalBilliards::usage="EllipticalBilliards[{t1,t2},n,{a,b}] gives n bounces of the path of a ball on an elliptical billiard table with axes a and b, where t1 is the starting position and t2 is the position of the first bounce."

ellipse[{a_,b_}]:=Module[{t,n=30},Line[Table[{a Cos[t],b Sin[t]},{t,0,2 Pi,2Pi/n}]]]
Ellipse[{a_,b_},t_]:={a Cos[t],b Sin[t]}
foci[a_,b_]:={{Sqrt[a^2-b^2],0},{-Sqrt[a^2-b^2],0}}
slope1[{a_,b_},t0_,t1_]:=Divide@@Reverse[Ellipse[{a,b},t1]-Ellipse[{a,b},t0]]/;t0+t1≠2Pi;
slope2[{a_,b_},t1_]:=-b Cot[t1]/a/;t1≠0&&t1≠Pi;
slope3[{a_,b_},t0_,t1_]:=Tan[2 ArcTan[slope2[{a,b},t1]]-ArcTan[slope1[{a,b},t0,t1]]]/;t1≠0&&t1≠Pi&&t0+t1≠2 Pi;
slope3[{a_,b_},t0_,t1_]:=-slope1[{a,b},t0,t1]/;t1==0||t1==Pi;
slope3[{a_,b_},t0_,t1_]:=Tan[2 ArcTan[slope2[{a,b},t1]]-Pi/2]/;t0+t1==2 Pi;

newpoint[{t0_,t1_},{a_,b_}]:=Module[{x,y,eps=1.*^-10,t2},t2=Mod[ArcTan[b x,a y]/.N[Solve[{(x/a)^2+(y/b)^2==1,y-Ellipse[{a,b},t1][[2]]==(x-Ellipse[{a,b},t1][[1]]) slope3[{a,b},t0,t1]},{x,y}]],2Pi];
Select[t2,Abs[#-t1]>eps&][[1]]]

EllipticalBilliards[start_List,n_Integer?Positive,{a_,b_},opts___]:=Module[{l=start,i},Do[AppendTo[l,newpoint[l[[{-2,-1}]],{a,b}]],{i,n-1}];
Show[Graphics[{
{Hue[0.67,0.6,0.6],Thickness[.004],Circle[{0,0},{a,b}]},
{PointSize[.03],Red,Point/@foci[a,b]},
Line[Table[Ellipse[{a,b},l[[i]]],{i,Length[l]}]]/.Line[x_]:>{PointSize[.02],Point[x[[{1,-1}]]],MapIndexed[{Hue[#2[[1]]/5.],Line[#1]}&,Partition[x,2,1]]},
MapIndexed[Text[Subscript[Style["F",FontSlant->"Italic"],3-#2[[1]]],#1+{.2(-1)^#2[[1]],-.15},Background->White]&,foci[a,b]]
}],opts,Ticks->None]]

EllipticalBilliards@@{{Pi+.6,Pi/2-.6},20,{2,1}}

GraphicsGrid[Partition[EllipticalBilliards@@@{
{{Pi-.05,Pi/2},30,{2,1}},
{{Pi+.6,Pi/2-.6},20,{2,1}},
{{Pi,0},2,{2,1}},{{Pi,.51},3,{2,1}},
{{Pi/2,Pi},4,{2,1}},{{Pi/2,.1785},5,{2,1}}
},2,2,{1,1},{}],ImageSize->500]

GraphicsGrid[Partition[EllipticalBilliards@@@{
{{Pi-.05,Pi/2},30,{2,1}},
{{Pi+.6,Pi/2-.6},20,{2,1}},
{{Pi+ArcCos[Sqrt[3]/2],ArcCos[-Sqrt[3]/2]},4,{2,1}},
{{Pi,0},2,{2,1}},
{{Pi,.51},3,{2,1}},
{{Pi/2,Pi},4,{2,1}},
{{Pi/2,.1785},5,{2,1}},
{{Pi/2,.339},6,{2,1}}
},3,3,{1,1},{}]]