Rolling an Ellipse Along a Curve

Section 1.1 - The Setup

xc =2; yc=4;

a=4;b=2;

EllipseF[t_] = {xc+a Cos[t], yc+b Sin[t]};

EllipsePlot = ParametricPlot[EllipseF[t],{t,0,2π},PlotStyle->{Thickness[0.007], Red}];

LinePlot = Graphics[{Thickness[0.005], Pink, Line[{{-10,2}, {20,2}}]}];

CenterPlot = Graphics[{PointSize[0.015], Black, Point[{{xc,yc}}]}];

Show[EllipsePlot, CenterPlot, LinePlot, AxesOrigin->{0,0}, PlotRange-> {{-10,20},{0,10}}]

Section 1.2 - The First Step

NIntegrate[Norm[D[EllipseF[t],t]],{t,0,2π}]

FindRoot[NIntegrate[Norm[D[EllipseF[t],t]],{t,((3π)/2),t1}]==2,{t1,1.1 ((3π)/2), ((3π)/2), 2π}]

Plot[2-NIntegrate[Norm[D[EllipseF[t],t]],{t,((3π)/2),t1}],{t1,0,2π}]

EllipseF[5.229238280827457]

TouchPlots = Graphics[{PointSize[0.025], Green, Point[{EllipseF[((3π)/2)],EllipseF[5.229238280827457]}]}];

NextTouch = Graphics[{PointSize[0.025], Black, Point[{{4,2}}]}];

Show[EllipsePlot, TouchPlots, CenterPlot, LinePlot, NextTouch, AxesOrigin->{0,0}, PlotRange->{{-3,8},{0,7}}]

Show[EllipsePlot, TouchPlots, CenterPlot, LinePlot, NextTouch, AxesOrigin->{1,1}, PlotRange->{{1,5},{1,3}}]

M = D[EllipseF[t],t][[2]]/D[EllipseF[t],t][[1]]

m = M/.t->5.229238280827457

Solve[(y-EllipseF[5.229238280827457][[2]] == m (x- EllipseF[5.229238280827457][[1]]))/.y->2]

AnglePoint = Graphics[{PointSize[0.025], Blue, Point[{{3.0573416546670975, 2}}]}];

ArrowPlots = Graphics[{Arrowheads[.10], Thickness[.010], Black, Arrow[{{3.0573416546670975,2},{3.976573754490907,2.2612392205181213}}], Black, Arrow[{{3.0573416546670975,2},{4,2}}]}];

Show[EllipsePlot, CenterPlot, LinePlot, NextTouch, ArrowPlots, TouchPlots, AnglePoint, PlotRange->{{2.9, 4.2},{1.8, 2.4}}, AxesOrigin->{2.9, 1.8}]

CenCirc = {3.0573416546670975,2}

TopCirc = EllipseF[5.229238280827457]

BotCirc = {4,2}

U = TopCirc-CenCirc

V = BotCirc-CenCirc

θval = VectorAngle[U,V]

θval (180/π)

EllipseShift = EllipseF[t]-{2,4}

RotMatrix[θ_] = {{Cos[θ], -Sin[θ]},{Sin[θ], Cos[θ]}};

(NewEllipse[t_] = RotMatrix[-θval].EllipseShift)//MatrixForm

NewEllipsePlot = ParametricPlot[Flatten[NewEllipse[t]+{2,4}],{t,0,2π}, PlotStyle->{Thickness[0.007], Blue}];

Show[NewEllipsePlot, EllipsePlot, TouchPlots, CenterPlot, LinePlot,NextTouch, AxesOrigin->{0,0},PlotRange->{{-3,8},{0,7}}]

LowestPoint = NewEllipse[5.229238280827457]

ShifT = BotCirc-LowestPoint

(NewNewEllipse[t_] = NewEllipse[t]+ShifT)//MatrixForm

NewNewEllipsePlot = ParametricPlot[Flatten[NewNewEllipse[t]],{t,0,2π}, PlotStyle->{Thickness[0.007], Blue}];

NewCenterPlot = Graphics[{PointSize[0.015], Black, Point[{ShifT}]}];

Show[NewNewEllipsePlot, EllipsePlot, TouchPlots, CenterPlot, LinePlot, NextTouch, NewCenterPlot, AxesOrigin->{0,0}, PlotRange->{{-3,8},{0,7}}]

Section 1.3 - Automating the Process

xc=2; yc=4;

a=4;b=2;

EllipseF[t_] = {xc + a Cos[t], yc + b Sin[t]};

r = 0.5;

yline = yc-b

TotalPerimeter = NIntegrate[Norm[D[EllipseF[t],t]],{t,0,2π}]

NumRSteps = 40;

S = (TotalPerimeter/r)/NumRSteps

A[θ_] = {{Cos[θ], -Sin[θ]},{Sin[θ], Cos[θ]}};

t0 = N[((3π)/2)];

xval = xc;

PlotEllipse[0] = ParametricPlot[EllipseF[t],{t,0,2π}, PlotStyle->{Thickness[0.007], Blue}];

PlotCenter[0] = Graphics[{PointSize[0.015], Black, Point[{{xc,yc}}]}];

LinePlot = Graphics[{Thickness[0.005], Pink, Line[{{-10,2},{30,2}}]}];

For[k=1, k≤ NumRSteps, k++,
ts=t1/.FindRoot[NIntegrate[Norm[D[EllipseF[t],t]],{t,t0,t1}]==r,{t1,t0,t0,t0+3 S}];
M = D[EllipseF[t][[2]],t]/D[EllipseF[t][[1]],t];
m = M/.{t->ts};
xint = (x/.Solve[(y-EllipseF[ts][[2]]==m(x-EllipseF[ts][[1]]))/.y->yline, x])[[1]];
Cpt = {xint, yline};
Tpt = EllipseF[ts];
Bpt = {xval+k*r, yline};
u = Tpt-Cpt;
v=Bpt-Cpt;
θval = VectorAngle[u,v];
EllipseCol[t_] = EllipseF[t]-{xc,yc};
NewEllipse[t_] = Simplify[A[-θval].EllipseCol[t]];
Lpt = NewEllipse[ts];
ShifT = Bpt-Lpt;
EllipseF[t_] = NewEllipse[t]+ShifT;
xc = ShifT[[1]];
yc = ShifT[[2]];
PlotEllipse[k] = ParametricPlot[EllipseF[t],{t,0,2π},PlotStyle->{Thickness[0.007],Blue}];
PlotCenter[k] = Graphics[{PointSize[0.015], Black, Point[{{xc,yc}}]}];
Print[{k,t0,ts, m, xint, -θval}];
t0=ts;
]

Manipulate[Show[PlotEllipse[h], PlotCenter[h], LinePlot, PlotRange->{{-5,30},{0,10}}, AxesOrigin->{0,0}, ImageSize->{400,200}],{{h,0,"Step"},0,40,1}]

Show[Table[PlotCenter[k],{k,0,40}], PlotRange->{{-5,30},{0,10}}, Axes->True, AxesOrigin->{0,0}]