Here I solve the classic double pendulum problem with only algebraic operations and rational numbers. No transcentental function or constant is used.
This is inspired by Norman Wildberger.
This is inspired by Norman Wildberger.
Cinematics
In[]:=
m[u_,v_,λ_,μ_]:=Accumulate[{#@λ.u,#@μ.v}]&
&,&
#1 | -#2 |
#2 | #1 |
1-
2
#
1+
2
#
2#
1+
2
#
In[]:=
doublePendulum[u_,v_,λ_,μ_]:=Graphics[{Line@Insert[#,{0,0},1],Rectangle[{-.1,-.1},{.1,.1}],Disk[#[[1]],.1],Disk[#[[2]],.1]}&@m[u,v,λ,μ],PlotRange{{-2,2},{-2,2}}]ManipulateWithf=,&,Module[{a=f@h1,b=f@h2},doublePendulum[a,b,λ,μ]],{{h1,0},-1,1},{{h2,0},-1,1},{{λ,0},-1,1},{{μ,0},-1,1},SaveDefinitionsTrue
1-
2
#
1+
2
#
2#
1+
2
#
Out[]=
Dynamics
In[]:=
ℒ[{a_,b_},{c_,d_}]:=Function@@SimplifyTotal&/@Dt[#]-Total[#.{0,1}]&@m[{a,b},{c,d},λ,μ]/.{λ->#1,μ->#2,Dt[λ]->#3,Dt[μ]->#4,HoldPattern@Dt[a|b|c|d]->0}
#.#
2
In[]:=
Clear[a,b,c,d,λ,μ]eulerLagrange=Apply[Function,{{a,b,c,d,λ,μ},With[{l=ℒ[{a,b},{c,d}]},Assuming[{+==1,+==1,{λ[t],μ[t]}∈Reals},Simplify[{Dt[Derivative[0,0,1,0][l][λ[t],μ[t],D[λ[t],t],D[μ[t],t]],t,Constants{a,b,c,d}]==Derivative[1,0,0,0][l][λ[t],μ[t],D[λ[t],t],D[μ[t],t]],Dt[Derivative[0,0,0,1][l][λ[t],μ[t],D[λ[t],t],D[μ[t],t]],t,Constants{a,b,c,d}]==Derivative[0,1,0,0][l][λ[t],μ[t],D[λ[t],t],D[μ[t],t]]}]]]/.h_[t]:>h}];
2
a
2
b
2
c
2
d
In[]:=
Modulea=0,b=-1,c=,d=-,tmax=20,With[{s=NDSolve[Join[eulerLagrange[a,b,c,d,λ,μ]/.{x:Derivative[_][λ|μ]:>x[t],y:λ|μ->y[t]},{λ[0]==μ[0]==λ'[0]==μ'[0]==0}],{λ,μ},{t,0,tmax}]},Animate[doublePendulum[{a,b},{c,d},λ[t],μ[t]]/.RandomChoice@s,{t,0,tmax},DefaultDurationtmax,SaveDefinitionsTrue]]
1
2
3
2
Out[]=
