Falling Cat Problem

More information→ Eman phisics

(Reference→ paper)

ClearAll["Global`*"];

1. Animation 

(Subscript[r, 0])=0.23m,(Subscript[r, 1])=(Subscript[r, 2])=0.36m, (Subscript[m, 0])=56kg, (Subscript[m, 1])=(Subscript[m, 2])=4kg  
(Modeled on a guy on a barstool. )

g1[m0_,m1_,m2_,r0_,r1_,r2_]:=-((1+4/3 m1 (((r1))^2))/(1/3 m0 (((r0))^2)+m1((((r0))^2)+(((r1))^2)+2r0 r1 (Subscript[cosθ, 1]))+m2((((r0))^2)+(((r2))^2)+2r0 r2 (Subscript[cosθ, 2])) ))//Simplify
g1[56,4,4,0.23,0.36,0.36]

r0=0.2;
r1=0.3;
r2=0.3;
vx[x_,y_]=10/(15+4*(Cos[x]+Cos[y]));(*changed the sign*)
vy[x_,y_]=-10/(15+4*(Cos[x]+Cos[y]));
g1[x_,y_]=-7/(13+6*(Cos[x]+Cos[y]));(*Matthias's example*)
g2[x_,y_]=-7/(13+6*(Cos[x]+Cos[y]));
v[{x_,y_}]={vx[x,y],vy[x,y]};

curl=Curl[v[{x,y}],{x,y}]//Simplify;
myticks=Table[Table[Pi k,{k,-2,2}],{2}];
dwPlot=ContourPlot[curl,{x,-7,7},{y,-7,7},FrameTicks->myticks];
vfPlot=VectorPlot[v[{x,y}],{x,-7,7},{y,-7,7},VectorScale->Small,FrameTicks->myticks];

lineint[A_,B_]:=NIntegrate[v[A+t( B-A)].(B-A),{t,0,1},AccuracyGoal->6];(*line integral*)

txtA=Style["a",13];
txtC=Style["c",13];
txtAW=Style["a+w",13];
o={0,0};

Using line integral

Manipulate[
c=a+w;
b=a+{w[[1]],0};
d=a+{0,w[[2]]};
																		p:=Which[t≤1, t a, t<2,(2-t)a+(t-1)b, t<3,(3-t)b+(t-2)c, t<4,(4-t)c+(t-3)d, t<5,(5-t)d+(t-4)a,t≤6,(6-t) a];
θ1:=p[[1]];
θ2:=p[[2]];

α0=lineint[o,a];
α1=lineint[a,b];
α2=lineint[b,c];
α3=lineint[c,d];
α4=lineint[d,a];
α:=Which[t≤1,lineint[o,p],t≤2,α0+lineint[a,p],t≤3,α0+α1+lineint[b,p],t≤4,α0+α1+α2+lineint[c,p],
t≤5,α0+α1+α2+α3+lineint[d,p],t≤6,α0+α1+α2+α3+α4+lineint[a,p]];


g=r0 {Cos[α],Sin[α]};
f=-r0 {Cos[α],Sin[α]};
h=g+r2{Cos[α+θ2],Sin[α+θ2]};
e=f+r1{Cos[Pi-θ1+α],Sin[Pi-θ1+α]};
nose=0.03{Cos[α+Pi/2],Sin[α+Pi/2]};


leftGraphics=Graphics[{Point[o],Point[a],Point[b],Point[c],Point[d],PointSize[Large],Point[p],Blue,Line[{o,a,b,c,d,a}],Black,Text[txtA,a,{0,0.8}],Text[txtAW,c,{0,-0.8}],
Text[Style["a="<>ToString[a],12],{-7,7},{-1,0}],Text[Style["w="<>ToString[w],12],{-7,6.3},{-1,0}]}];
leftGraphics0=Graphics[{Point[o],Point[a],Point[b],Point[c],Point[d],PointSize[Large],Point[p],Blue,Line[{o,a,b,c,d,a}],Black,Text[txtA,a,{0,0.8}],Text[txtAW,c,{0,-0.8}]}];
leftcontent=Which[option=="vector",{vfPlot,leftGraphics0},
option=="curl",{dwPlot,leftGraphics0},
option=="none",leftGraphics];


GraphicsRow[{
Show[leftcontent,PlotRange->7,Axes->True,Ticks->myticks,AxesLabel->{"(Subscript[θ, 1])","(Subscript[θ, 2])"},ImageSize->270],(*以上は左半分.以下は右半分*)
Graphics[{Green,Thickness[0.03],Line[{e,f}],Magenta,Line[{g,h}],Red,Thickness[0.05],Line[{f,g}],Blue,PointSize [0.03],Point[nose],Gray,PointSize [0.05],Point[f],Point[g],Black,Point[o],Text[Style["(Subscript[θ, 1])="<>ToString[Round[θ1*180/3.14]]<>"°",12],{-0.53,0.57},{-1,0}],Text[Style["(Subscript[θ, 2])="<>ToString[Round[θ2*180/3.14]]<>"°",12],{-0.53,0.52},{-1,0}],
Text[Style["α="<>ToString[Round[α*180/3.14]]<>"°",12],{-0.53,0.47},{-1,0}]}
,PlotRange->0.53,Axes->True,Ticks->None,AxesLabel->{"x","y"},ImageSize->270]
}],
{{a,{1,1}},{-6,-6},{6,6}},{{w,{2,2}},{0.1,0.1},{3,3}},{t,(10^(-4)),6},{{option,"none"},{"none","vector","curl"}},
ControlPlacement->{Left,Left,Top,Top}]

Using curl

NIntegrate[curl,{x,1,3},{y,1,3},AccuracyGoal->6]*180/Pi//Round;
Print[Style["α=(∫_C)v·\[DifferentialD]s=∫curl(v)\[DifferentialD](Subscript[θ, 1])\[DifferentialD](Subscript[θ, 2])="<>ToString[%]<>"°",Italic,15]]

2.   serching for a closed curve using rotation

V=((10/(15+4*(Cos[x]+Cos[y]))),-(10/(15+4*(Cos[x]+Cos[y])))) ←((Subscript[r, 0])=0.23m,(Subscript[r, 1])=(Subscript[r, 2])=0.36m, (Subscript[m, 0])=56kg, (Subscript[m, 1])=(Subscript[m, 2])=4kg )

vx[x_,y_]=10/(15+4*(Cos[x]+Cos[y]));(*changed the sign*)
vy[x_,y_]=-10/(15+4*(Cos[x]+Cos[y]));
dw[x_,y_]=Curl[{vx[x,y],vy[x,y]},{x,y}]//FullSimplify
Plot3D[dw[x,y],{x,-2Pi,2Pi},{y,-2Pi,2Pi},Ticks->Append[myticks,Automatic],Mesh->20,PlotRange->Full,PlotLabel->Style["Curl(v) plot",15,Bold]]
Show[{ContourPlot[dw[x,y],{x,-7,7},{y,-7,7},FrameTicks->myticks,PlotLegends->Automatic],ContourPlot[x y==0,{x,-7,7},{y,-7,7}]}]

FindMaximum[dw[x,y],{x,Pi},{y,Pi}]
FindMinimum[dw[x,y],{x,Pi},{y,Pi}]

【comparison with Kawsky’s】  V=(-(7/(13+6*(Cos[x]+Cos[y]))),-(7/(13+6*(Cos[x]+Cos[y]))))  
((Subscript[m, 1])((Subscript[r, 0])^2)=1) ∧ ((Subscript[m, 1])=(Subscript[m, 2])=(Subscript[m, 0])) ∧( (Subscript[r, 0]) =(Subscript[r, 1]) =(Subscript[r, 2]))

g1[x_,y_]=-7/(13+6*(Cos[x]+Cos[y]));
g2[x_,y_]=-7/(13+6*(Cos[x]+Cos[y]));
dw0[x_,y_]=Curl[{g1[x,y],g2[x,y]},{x,y}]//Simplify


Plot3D[dw0[x,y],{x,-2Pi,2Pi},{y,-2Pi,2Pi},PlotRange->Full,Ticks->Append[myticks,Automatic],PlotLabel->Style["Curl(v) plot",15,Bold]]
Show[{ContourPlot[dw0[x,y],{x,-7,7},{y,-7,7},FrameTicks->myticks,PlotLegends->Automatic],ContourPlot[x y==0,{x,-7,7},{y,-7,7}]}]

FindMaximum[dw0[x,y],{{x,Pi},{y,Pi}}]
FindMinimum[dw0[x,y],{{x,Pi},{y,Pi}}]

3. Appendix.  Animation(when the path is a circle)

Manipulate[
r:=Norm[a-c];
b:=c+RotationMatrix[Pi/2].(a-c);
p=Which[t≤1, t a, t<1+2Pi,c+Cos[t-1](a-c)+Sin[t-1](b-c),t<=2+2Pi,(2+2Pi-t) a];
θ1:=p[[1]];
θ2:=p[[2]];


α0=lineint[o,a];α1=NIntegrate[v[c+Cos[u-1](a-c)+Sin[u-1](b-c)].(RotationMatrix[Pi/2].(Cos[u-1](a-c)+Sin[u-1](b-c))),{u,1,2Pi+1}];
α:=Which[t≤1,lineint[o,p],
t<1+2Pi,α0+NIntegrate[v[c+Cos[u-1](a-c)+Sin[u-1](b-c)].(RotationMatrix[Pi/2].(Cos[u-1](a-c)+Sin[u-1](b-c))),{u,1,t}],t≤2+2Pi,α0+α1+lineint[a,p]];


g=r0 {Cos[α],Sin[α]};
f=-r0 {Cos[α],Sin[α]};
h=g+r2{Cos[α+θ2],Sin[α+θ2]};
e=f+r1{Cos[Pi-θ1+α],Sin[Pi-θ1+α]};
nose=0.03{Cos[α+Pi/2],Sin[α+Pi/2]};

leftGraphics=Graphics[{Point[o],Point[a],Point[c],PointSize[Large],Point[p],Blue,Circle[c,r],Line[{o,a}],Black,Text[txtA,a,{0,0.8}],Text[txtC,c,{0,0.8}]}];
leftcontent=Which[option=="vector",{vfPlot,leftGraphics},
option=="curl",{dwPlot,leftGraphics},
option=="none",leftGraphics];

GraphicsRow[{
Show[leftcontent,PlotRange->7,Axes->True,Ticks->myticks,AxesLabel->{"(Subscript[θ, 1])","(Subscript[θ, 2])"},ImageSize->270],(*以上は左半分.以下は右半分*)
Graphics[{Green,Thickness[0.03],Line[{e,f}],Magenta,Line[{g,h}],Red,Thickness[0.05],Line[{f,g}],Blue,PointSize [0.03],Point[nose],Gray,PointSize [0.05],Point[f],Point[g],Black,Point[o],Text[Style["(Subscript[θ, 1])="<>ToString[Round[θ1*180/3.14]]<>"°",12],{-0.53,0.57},{-1,0}],Text[Style["(Subscript[θ, 2])="<>ToString[Round[θ2*180/3.14]]<>"°",12],{-0.53,0.52},{-1,0}],
Text[Style["α="<>ToString[Round[α*180/3.14]]<>"°",12],{-0.53,0.47},{-1,0}]}
,PlotRange->0.53,Axes->True,Ticks->None,AxesLabel->{"x","y"},ImageSize->270]
}],
{{a,{2,2}},{-6,-6},{6,6}},{{c,{3,3}},{-6,-6},{6,6}},{t,(10^(-4)),2Pi+2},{{option,"none"},{"none","vector","curl"}},
ControlPlacement->{Left,Left,Top,Top}]