Chaotic Pendulum

Single orbit, where (∂_t)x = 0 and (∂_t)y = 0

Manipulate[
Module[{xMag,yMag,system},
xMag = Table[A Cos[i*((2π)/NMag)],{i,1,NMag}];
yMag = Table[A Sin[i*((2π)/NMag)],{i,1,NMag}]; system={x''[t]+ R x'[t]-Sum[(( xMag[[i]]-x[t])/((((Sqrt[(((xMag[[i]]-x[t]))^2)+(((yMag[[i]]-y[t]))^2)+(d^2)])))^3)),{i, 1, NMag}]+C1 x[t]==0, y''[t]+ R y'[t]-Sum[((yMag[[i]]-y[t])/((((Sqrt[(((xMag[[i]]-x[t]))^2)+(((yMag[[i]]-y[t]))^2)+(d^2)])))^3)),{i, 1, NMag}]+C1 y[t] ==0} ;Show[Graphics[Table[{Hue[i/π,1,0.5],Disk[{xMag[[i]],yMag[[i]]},0.1]},{i,1,NMag}],PlotRange->2,Axes->True,Frame->True,FrameLabel->{x[t],y[t]},ImageSize->660,LabelStyle->20],
ParametricPlot[Evaluate[{x[t],y[t]}/.Nsolutions[pt,system],{t,0,T}],PlotStyle->RGBColor[0,0.7,0]]]],
{{T,1,"Time"},0.001,25,0.05,Appearance->"Labeled"},
{{R,0.05,"Friction"},0.01,0.75,0.01,Appearance->"Labeled"},
{{NMag,3,"Number of magnets"},2,6,1,Appearance->"Labeled"},
{{A,0.90,"Radius"},0.01,2.00,0.1,Appearance->"Labeled"},
{{pt,{{1.11,1}}},{-2,-2},{2,2},Locator},
Initialization:>(d = 0.25;C1=0.15;
solvesystem[{xinit_,yinit_},localsystem_]:=NDSolve[Join[localsystem,{x[0] == xinit,y[0] ==yinit,y'[0]==0,x'[0]==0}],{x,y},{t,0,25}];
Nsolutions[initialpositions_,localsystem_]:=Map[solvesystem[#,localsystem]&,initialpositions]),TrackedSymbols:>{T,R,NMag,A,pt}]

Two orbits, where (∂_t)x = 0 and (∂_t)y = 0

Manipulate[
Module[{xMag,yMag,system},
xMag = Table[A Cos[i*((2π)/NMag)],{i,1,NMag}];
yMag = Table[A Sin[i*((2π)/NMag)],{i,1,NMag}]; system={x''[t]+ R x'[t]-Sum[(( xMag[[i]]-x[t])/((((Sqrt[(((xMag[[i]]-x[t]))^2)+(((yMag[[i]]-y[t]))^2)+(d^2)])))^3)),{i, 1, NMag}]+C1 x[t]==0, y''[t]+ R y'[t]-Sum[((yMag[[i]]-y[t])/((((Sqrt[(((xMag[[i]]-x[t]))^2)+(((yMag[[i]]-y[t]))^2)+(d^2)])))^3)),{i, 1, NMag}]+C1 y[t] ==0} ;Show[Graphics[Table[{Hue[i/π,1,0.5],Disk[{xMag[[i]],yMag[[i]]},0.1]},{i,1,NMag}],PlotRange->2,Axes->True,Frame->True,FrameLabel->{x[t],y[t]},ImageSize->660,LabelStyle->20],
ParametricPlot[Evaluate[{x[t],y[t]}/.Nsolutions[pt,system],{t,0,T}],PlotStyle->{RGBColor[0,0.7,0], RGBColor[0,0,1]}]]],
{{T,1,"Time"},0.001,25,0.05,Appearance->"Labeled"},
{{R,0.05,"Friction"},0.01,0.75,0.01,Appearance->"Labeled"},
{{NMag,3,"Number of magnets"},2,6,1,Appearance->"Labeled"},
{{A,0.90,"Radius"},0.01,2.00,0.1,Appearance->"Labeled"},
{{pt,{{1.11,1},{1.1,0.95}}},{-2,-2},{2,2},Locator},
Initialization:>(d = 0.25;C1=0.15;
solvesystem[{xinit_,yinit_},localsystem_]:=NDSolve[Join[localsystem,{x[0] == xinit,y[0] ==yinit,y'[0]==0,x'[0]==0}],{x,y},{t,0,25}];
Nsolutions[initialpositions_,localsystem_]:=Map[solvesystem[#,localsystem]&,initialpositions]),TrackedSymbols:>{T,R,NMag,A,pt}]

Three orbits, where (∂_t)x = 0 and (∂_t)y = 0

Manipulate[
Module[{xMag,yMag,system},
xMag = Table[A Cos[i*((2π)/NMag)],{i,1,NMag}];
yMag = Table[A Sin[i*((2π)/NMag)],{i,1,NMag}]; system={x''[t]+ R x'[t]-Sum[(( xMag[[i]]-x[t])/((((Sqrt[(((xMag[[i]]-x[t]))^2)+(((yMag[[i]]-y[t]))^2)+(d^2)])))^3)),{i, 1, NMag}]+C1 x[t]==0, y''[t]+ R y'[t]-Sum[((yMag[[i]]-y[t])/((((Sqrt[(((xMag[[i]]-x[t]))^2)+(((yMag[[i]]-y[t]))^2)+(d^2)])))^3)),{i, 1, NMag}]+C1 y[t] ==0} ;Show[Graphics[Table[{Hue[i/π,1,0.5],Disk[{xMag[[i]],yMag[[i]]},0.1]},{i,1,NMag}],PlotRange->2,Axes->True,Frame->True,FrameLabel->{x[t],y[t]},ImageSize->660,LabelStyle->20],
ParametricPlot[Evaluate[{x[t],y[t]}/.Nsolutions[pt,system],{t,0,T}],PlotStyle->{RGBColor[1,0,0],RGBColor[0,0.7,0], RGBColor[0,0,1]}]]],{{T,1,"Time"},0.001,25,0.05,Appearance->"Labeled"},
{{R,0.05,"Friction"},0.01,0.75,0.01,Appearance->"Labeled"},
{{NMag,3,"Number of magnets"},2,6,1,Appearance->"Labeled"},
{{A,0.90,"Radius"},0.01,2.00,0.1,Appearance->"Labeled"},
{{pt,{{1.11,1},{1.1,0.95},{1.09,0.90}}},{-2,-2},{2,2},Locator},
Initialization:>(d = 0.25;C1=0.15;
solvesystem[{xinit_,yinit_},localsystem_]:=NDSolve[Join[localsystem,{x[0] == xinit,y[0] ==yinit,y'[0]==0,x'[0]==0}],{x,y},{t,0,25}];
Nsolutions[initialpositions_,localsystem_]:=Map[solvesystem[#,localsystem]&,initialpositions]),TrackedSymbols:>{T,R,NMag,A,pt}]

If you are interested in the derivation of the above equations of motion see:
H. Peitgen, H. Jürgens, and D. Saupe, Chaos and Fractals: New Frontiers of Science, New York: Springer-Verlag, 2004, pp 707–714

Credit: Based on the code written by Galen Craven

Creation of this notebook was supported by IT Academy program of Information Technology Foundation for Education (HITSA).