長さを変えた15個の振り子を一斉に揺らす実験（動画）をMathematicaでシミュレートする。
2次元
3次元
手順は以下のとおり。
- 運動方程式の確認（g=1、m=1、糸はたるまないことを仮定）
- 1分間の振動数が整数になるような振り子の長さを求める
- 運動方程式を解いて結果をアニメーションにする
ラグランジの運動方程式は次のように確認できる。
lagrangian = (r \[Theta]'[t] )^2/2 - r Cos[\[Theta][t]]; D[D[lagrangian, \[Theta]'[t]], t] + D[lagrangian, \[Theta][t]] r Sin[theta[t]] + r^2 theta''[t]
これを使って、シミュレーションを作る。
(* 1分間の振動数が整数になる長さを求める *)
tMax = 60; (* maximum time *)
n = 15; (* number of objects *)
theta = Table[Unique[], {n}];
initialAngle = Pi/6;
r = Table[
First[x /. Solve[
tMax/(4 Sqrt[x] EllipticK[Sin[initialAngle/2]^2]) == (20 + i), x]
], {i, 1, n}];
(* 運動方程式を解く *)
equations = Flatten[Table[{
(* ラグランジの運動方程式 *)
r[[i]] Sin[theta[[i]][t]] + r[[i]]^2 theta[[i]]''[t] == 0,
theta[[i]][0] == Pi/6,
theta[[i]]'[0] == 0},
{i, 1, n}]];
solution = NDSolve[equations, theta, {t, 0, 1.1 tMax}];
(* 2次元アニメーション *)
Animate[
points = Table[First[
{r[[i]] Sin[theta[[i]][t]], -r[[i]] Cos[theta[[i]][t]]}
/. solution /. t -> T], {i, 1, n}];
Graphics[{
Black, Disk[#, 0.005],
Gray, Line[{{0, 0}, #}]} &
/@ points,
PlotRange -> {{-0.8 Max[r], 0.8 Max[r]}, {0, -1.1 Max[r]}}],
{T, 0, 1.1 tMax}, DefaultDuration -> 1.1 tMax,
SaveDefinitions -> True]
実行結果は冒頭の動画の通り。
最後の部分を次のようにすれば3次元になる。
(* 3次元アニメーション *)
Animate[
points = Table[First[
{i Max@r/n, r[[i]] Sin[theta[[i]][t]], -r[[i]] Cos[theta[[i]][t]]}
/. solution /. t -> T], {i, 1, n}];
Graphics3D[{
Black, Sphere[#, 0.005],
Gray, Line[{{#[[1]], 0, 0}, #}]} &
/@ points,
PlotRange -> {{0, 1.1 Max@r}, {-0.7 Max@r,
0.7 Max@r}, {0, -1.1 Max@r}}],
{T, 0, 1.1 tMax}, DefaultDuration -> 1.1 tMax,
SaveDefinitions -> True]
参考