Math Physics Showcase
A peek into dynamical systems

Robbie Robinson, GWU
April 28, 2014

Introduction

Simple systems can result in complex behavior

A basic 1-dimensiona dynamical system is be a function y = f(x).

The input x and the output y both be real numbers in the unit interval [0,1], the “phase space”. Iterate, to get sequence x, f(x), (f^2)(x)=f(f(x)), (f^3)(x), (f^4)(x),... called the orbit of x.

Some questions:

Is the orbit of x finite or infinite? 
Does it “fill out” the phase space [0,1]? 
How are nearby orbits related? 
What happens if we change x a little? 
How does the orbit of x change if we change f a little?

My function: the simple quadratic family f(x) = 4hx(1-x). h is a parameter between 0 and 1.

In Mathematica (avaiable to all GW students!)

Simple plot and fancier one

q[h_][x_]:=4 h x (1-x)

Plot[{x, q[1][x]}, {x, 0, 1}, PlotRange -> {{0, 1}, {0, 1}}, AspectRatio -> Automatic, Frame -> True]

Manipulate[Plot[{x,q[h][x]}, {x, 0, 1},PlotRange->{{0,1},{0,1}},AspectRatio->Automatic,Frame->True],{h,0,1}]

More functions

A few more functions: (Tent, Beta, Rotation, Adding Machine). you can try these later yourself!

q[h_][x_]:=4 h x (1-x)
t[h_][x_] := Piecewise[{{2h x,x<.5},{-2h(x-1),x≥.5}}]
b[h_][x_]:=Mod[(1+ h) x,1] 
r[h_][x_]:=Mod[x+h,1]
c[h_][x_]:=Mod[(1+h)/x,1]

Manipulate[Plot[{x, F[h][x]}, {x, 0, 1}, PlotRange -> {{0, 1}, {0, 1}}, AspectRatio -> Automatic, Frame -> True], {h, 0, 1}, {F, {q, t, b,r,c}}]

Web Diagrams

This requires some programming (which I have done below), but the idea is simple.

Code:

Rep[f_,d_,x0_,n_]:=Map[d,NestList[f,x0,n]]
Web[f_,x_,n_]:=Module[{L,M},
L=NestList[f,x,n];
M={};
For[i=1,i<Length[L],i++,
M=Join[M,{{L[[i]],L[[i]]},{L[[i]],L[[i+1]]}}];
];M]
WebPlot[f_,x0_,n_]:=
Show[
Plot[{f[x],x},{x,0,1},AspectRatio->Automatic,Frame->True,PlotRange->{{0,1},{0,1}}],
Plot[x,{x,0,1}], 
Graphics[Line[Web[f,x0,n]]]]

Plots

h=1;f=q[h];x0=.365765;n0=1;
WebPlot[f,x0,n0]

Some animation...

F=q
Manipulate[WebPlot[F[h],x0,n0], {x0,0,1},{n0,1,200,1},{h, 1, 0}]

Ed Lorenz’s observation (1963)

Meterologist at MIT, 1963: “Butterfly Effect”: Now called “Sensitive dependence on initial conditions”. 

“Two states differing by imperceptible amounts may eventually evolve into two considerably different states ... If, then, there is any error whatever in observing the present state — and in any real system such errors seem inevitable — an acceptable prediction of an instantaneous state in the distant future may well be impossible....In view of the inevitable inaccuracy and incompleteness of weather observations, precise very-long-range forecasting would seem to be nonexistent.”

Bob Devaney's definition of "Chaos" (1989)

Topological transitivity, sensitive dependence and dense periodic points.

Sensitive Dependence in web plot

Code:

WebPlot2[f_,x0_,ϵ_,n_]:=
Show[
Plot[{f[x],x},{x,0,1},AspectRatio->Automatic,Frame->True,PlotRange->{{0,1},{0,1}}],
Plot[x,{x,0,1}], 
Graphics[{RGBColor[0,1,0],Line[Web[f,x0+ϵ,n]]}],
Graphics[{RGBColor[1,0,0],Line[Web[f,x0-ϵ,n]]}]
]

Graphics:

F=q;
Manipulate[WebPlot2[F[h], x0, ϵ,n0], {x0, 0, 1}, {ϵ,.000001,.01},{n0, 1, 50, 1}, {h, 1, 0}]

Famous picture (bifurcation diagram)

Tail[F_,h_,n0_,n1_]:=Transpose[
{Drop[NestList[F[h],.323490809,n1], n0+1],ConstantArray[h,n1-n0]}]

ListPlot[Flatten[Table[Tail[q,h,100,400],{h,.7,1,.001}],1],AspectRatio->1,PlotStyle->RGBColor[1,0,1]]

To learn more...

Take Math 4981-80 in the Fall: MW 3:45-5, Duques 152.

Penrose tilings (as promised on the poster)

The code (mostly borrowed from Stan Wagon’s book Mathematica in Action.)

phi=N[GoldenRatio];
rad=First[x/.N[Solve[Tan[72 °] x==1-2 x,x]]];
toppoint=N[{(1/2),Sin[72 °] phi}];
starttriangle={toppoint,{1,0.},{0.,0.},1};
dissect[{p_,q_,r_,1}]:=(newpoint=(phi q+p) (2-phi);{{r,newpoint,q,1},{r,newpoint,p,-1}})
dissect[{p_,q_,r_,-1}]:=(newpoint=(phi r+p) (2-phi);{{r,newpoint,q,-1},{p,q,newpoint,1}})
dissect[list_]:=(type*=-1;Join[Select[list,Last[#1]≠type&],Flatten[dissect/@Select[list,Last[#1]==type&],1]]/;TensorRank[list]≠1)
Rhombs[n_]:=(type=1;tiles=Nest[dissect,starttriangle,2 n+1]/.
{{p_,q_,r_,1}->Line[{r,p,q}],{p_,q_,r_,-1}->Line[{p,q,r}]};
Show[Graphics[{Thickness[.001],RGBColor[0,0,1],tiles}],AspectRatio->1,PlotRange->{{rad,1-rad},{0,1-2 rad}}])
Attributes[Rhombs]=Listable;
TRhombs[R_,G_,B_,T_][n_]:=(type=1;tiles=Nest[dissect,starttriangle,2 n+1]/.
{{p_,q_,r_,1}->Line[{r,p,q}],{p_,q_,r_,-1}->Line[{p,q,r}]};
Show[Graphics[{Thickness[T],RGBColor[R,G,B],tiles}],AspectRatio->1,PlotRange->{{rad,1-rad},{0,1-2 rad}}])
Attributes[Rhombs]=Listable;

Pictures

Manipulate[Rhombs[n],{n,1,8,1}]

Show[{TRhombs[0, 1, 0, .009][5], TRhombs[0, 0, 1, .003][6], TRhombs[1, 0, 0, .001][7]}]