Baker’s Map

Consider repeated doubling

Clear[dbl];dbl[x_]:=2x

Nest[dbl,x,10]

NestList[dbl,x,10]

Table[{Row[{"n = ",n}],Row[{(2^("n")) ," = ",(2^n)}]
,Nest[dbl,x,n]
},{n,Range[10]}]//TableForm

Manipulate[Module[{dbl},dbl=2#&;
Plot[Nest[dbl,x,n],{x,-1,1}
,PlotStyle->Red,PlotRange->{{-1,1},5{-1,1}},AspectRatio->1,Frame->True
,PlotLabel->((2^("n"))"x")
]],{{n,3,Style["n =",Large]},Range[10]}]

For x non-zero, clearly (2^n)x-> ±∞  as n->∞ , depending on whether x is positive or negative.
Can we see a better picture?

Yes.   
   … by bringing  ∞  closer, using a trigonometric function!

Manipulate[Module[{dbl},dbl=2#&;
Plot[ ArcTan[Nest[dbl,x,n]],{x,-1,1}
,PlotStyle->Red,PlotRange->{{-1,1},{-1,1}2},AspectRatio->1,Frame->True
,PlotLabel->(ArcTan[(2^("n"))"x"])
,GridLines->{Range[-2,2]/2,Range[-2,2]π/4}
,FrameTicks->{Automatic,{#,#}&/@(Range[-2,2,1]π/4)}
(*,Exclusions->{0}*)
]],{{n,1,Style["n =",Large]},Range[10]}]

Technicalities

?FrameTicks

yTicks={#,#}&/@(Range[-2,2,1]π/4)

?Exclusions

Limit the range in a different way — Dyadic Map

— also known as the Baker’s map

Think of a baker kneading dough — squeezing and stretching it to twice the length,

then cuts in half and puts the halves back together one atop the other.

Repeat this process many times.

Double[x_]:=2x-Floor[2x] /;x≥0&&x<1
Double[(1/2)]=Double[1]=1;

Manipulate[Plot[
Nest[Double,x,n],{x,0,1}
,PlotStyle->Red,PlotRange->{{0,1},{0,1}},AspectRatio->1,Frame->True
,PlotLabel->(Double[x])
,Exclusions->Range[1,(2^n)]/(2^n)
],{n,Range[10]}]

By identifying 0 with 1 (being equal modulo 1) then the interval [0,1] becomes a circle (S^1).
Then interpreting the map as  Double:(S^1)->(S^1) we get a continuous map. 
	The graph can be drawn on a torus. 
	Think of a rubber band around a cylinder — stretch it to twice its length, wrapping around the cylinder twice.
	Iterating Double stretches it further, to wrap around 4 times, 8 times, etc.

Manipulate[Module[{Double,zn,z0=N[z],z0n,znall},
Double[x_]:=2x-Floor[2x] /;x≥0&&x<1;
Double[(1/2)]=Double[1]=1;
znall=NestList[Double,z0,n];
z0n=Prepend[Drop[znall,-1],0];
zn=znall//Last;
Plot[Double[x],{x,0,1}
,PlotStyle->Red,PlotRange->{{0,1},{0,1}},AspectRatio->1,Frame->True
,PlotLabel->(Row[{"Doubling Map:  ",x," ↦ ", "Double"["x"]}])
,GridLines->{Range[1,(2^(Min[n,5]))]/(2^(Min[n,5])),Range[1,(2^(Min[n,5]))]/(2^(Min[n,5]))}
,FrameTicks->{Append[Range[0,(2^(Min[n,4]))]/(2^(Min[n,4])),1],Append[Range[0,(2^(Min[n,4]))]/(2^(Min[n,4])),1]}
,Exclusions->{1/2 }
,Epilog-> {{Black,Line[{{0,0},{1,1}}]}
,{Blue
,Line[Append[MapAt[Reverse,Flatten[
{{z0n,znall}//Transpose,{znall,znall}//Transpose}//Transpose
,1],1],{zn,0}]]
,Text[(Subscript["x", 0]),{z0,0},-1.3{1,1}],Text[(Subscript["x", n]),{zn,0},-1.3{1,1}]}}
,Background->White
]],{{n,2,Style["n =",Large]},Range[15]},{{z,.1,Style["(Subscript[x, 0])",Large]},0,1}]

Solve equations:  (Subscript[x, n])=(Subscript[x, 0]), for values n=1,2,3,…  where  (Subscript[x, j+1]):= Double((Subscript[x, j])) = 2(Subscript[x, j]) mod 1.

(Subscript[x, 1])=(Subscript[x, 0]) is easy to see:  (Subscript[x, 0])=0, or (Subscript[x, 0])=1.

Solve:  (Subscript[x, 2])=(Subscript[x, 0]) but (Subscript[x, 1])≠(Subscript[x, 0]).  
We need that  (2^2)(Subscript[x, 0])-(Subscript[x, 0]) is an integer.  
Hence 3(Subscript[x, 0])∈ℤ , so that (Subscript[x, 0])=(1/3) or (Subscript[x, 0])=(2/3). Verify (1/3)↦(2/3) and (2/3) ↦ (4/3)-1=(1/3).
We have found a 2-cycle for the Doubling Map.

Explore other fractions.

(1/5) ↦ (2/5) ↦ (4/5) ↦ (8/5)-1=(3/5) ↦ (6/5)-1=(1/5)  — this uncovers a 4-cycle for the Doubling Map:  (2^4)-1=15=3×5

(1/7) ↦ (2/7) ↦ (4/7) ↦ (8/7)-1=(1/7)  — this uncovers a 3-cycle for the Doubling Map:   (2^3)-1=7

(3/7) ↦ (6/7) ↦ (12/7)-1=(5/7)↦(10/7)-1=(3/7)  — this uncovers another 3-cycle for the Doubling Map.

(1/9) ↦ (2/9) ↦ (4/9) ↦ (8/9) ↦(16/9) -1=(7/9) ↦ (14/9)-1=(5/9) ↦(10/9)-1=(1/9) 
 — this uncovers a 6-cycle for the Doubling Map:     (2^6)-1=63=7×9.

(1/11) ↦ (2/11) ↦ (4/11) ↦ (8/11) ↦(16/11) -1=(5/11) ↦(10/11) ↦(20/11)-1=(9/11) ↦(18/11)-1=(7/11) ↦(14/11)-1= (3/11)↦(6/11)↦(12/11)-1=(1/11) 
 — this uncovers a 10-cycle for the Doubling Map:     (2^10)-1=1023=93×11.

(1/93) ↦ (2/93) ↦ (4/93) ↦ (8/93) ↦(16/93)↦(32/93) ↦(64/93)↦(128/93)-1=(35/93) ↦(70/93)↦(140/93)-1=(47/93)↦(94/93)-1=(1/93) 
 — this uncovers another 10-cycle for the Doubling Map.

Here are some more cycles

Table[NestList[(2#-Floor[2#])&,(1/((2^k)-1)),k],{k,2,10}]//ColumnForm

(1/((2^k)-1)) always generates a cycle of length k for any k∈ℕ — why?

Table[NestList[(2#-Floor[2#])&,(1/((2^k)+1)),2k],{k,2,10}]//ColumnForm

(1/((2^k)+1)) always generates a cycle of length 2k for any k∈ℕ — why?

Theoretical Question:

Is it true that every odd number occurs as a factor of ((2^k)-1) for some integer k ?

Format[primepower[{p_,a_}]]:=HoldForm[(p^a)]

Table[{Row[{"k=",k}],Row[{(2^("k")),-1,"=",(2^k)-1}]
,primepower/@(FactorInteger[(2^k)-1])},{k,1,19}]//ColumnForm

How high do we have to go?  That is, given an odd number K, can we 
place a bound on the size of k for having ((2^k)-1) being a multiple of K ?

Start with (1/K) and keep doubling modulo 1. 
We must get fractions with K (or an odd divisor of K) as denominator.

K=15;
Table[Mod[(2^k)/K,1],{k,0,K-1}]

It looks like always ((2^(K-1))/K)≡(1/K)mod 1, unless a number smaller than K-1 works.
This is equivalent to having that (2^(K-1))≡1 mod K.
But, at least when K is prime, this is a consequence of Fermat’s Little Theorem.
Recall the property of Euler’s ϕ-function:  (a^(ϕ(K)))≡1 for all integers a, such that  gcd(a,K)=1; 
that is, whenever a has no factors in common with K.
When K is prime, then ϕ(K) = K-1, and when K is odd it has no even factors, so Fermat’s theorem indeed applies.

When K is not prime, then  ϕ(K) < K-1;  e.g.  ϕ(p q)=(p-1)(q-1) < p q-1. 
So with K odd but not prime, then (2^M)≡1 holds with M=ϕ(K) < K-1.

Fermat’s little theorem

Given a non-zero modulus m∈ℕ, consider the set of residues (Subscript[G, m])={1≤a≤m-1|gcd(a,m)=1}.
Then

(a^(ϕ(m)))≡1 for all a∈(Subscript[G, m]) ; equivalently

(Subscript[G, m]) is a multiplicative group of size ϕ(m).

Theorem: any odd integer m is a factor of (2^k) for some k≤ϕ(m).

Proof:  
Since m is odd then we must have 2∈(Subscript[G, m]), the multiplicative group of residues modulo m relatively prime to m.
Since |(Subscript[G, m])|=ϕ(m)  then any element must have multiplicative order either ϕ(m) or a divisor of ϕ(m).
Hence, in particular, (2^k)≡1 for some k≤ϕ(m), and when k<ϕ(m) then it must be a divisor of ϕ(m).

Theoretical Question: rational vs irrational numbers

Start at a rational number x∈(0,1], then either:

(Double^((n)))(x)=1  for some n∈ℕ — denominator of x is (2^k) for some k∈ℕ  (numerator is odd)

(Double^((n)))(x)=x  for some n∈ℕ  
i.e., the orbit of x is periodic — denominator of x is odd

(Double^((n)))(x)=y=(Double^((m)))x  for some minimal m,n∈ℕ  
 i.e., the orbit of y is periodic and x is pre-periodic to it — denominator of x is (2^m)k, with k odd.

Start at an irrational number x∈[0,1], then 
	it is not possible to have  (Double^((n)))(x)=(Double^((m)))x for any distinct m,n∈ℕ 
	— otherwise, for  y=(Double^((m)))x and k=n-m, we would have ((2^k)-1)y is in ℕ , so that y∈ℚ and so is x .
Hence the orbit of irrational x can never repeat. Indeed it is dense in (0,1), coming arbitrarily close to any given number, infinitely many times.
This kind of behavior is typical of what is called chaos.

Binary decimal expansions

onetest=If[#≥1,1,0]&;
BinaryExpand[x_?NumberQ,k_Integer:20]:=Module[{intpart,list},
intpart=IntegerDigits[Floor[x],2];
list=onetest/@Drop[NestList[2(#-Floor[#])&,x,k],1];
StringJoin[ToString/@intpart,".",ToString/@list]
]
BinaryExpand::usage="BinaryExpand[x_,k_] gives the binary expansion of a real number x, with k binary digits after the decimal point. BinaryExpand[x] uses 20 digits.";

EvaluateBinary[s_]:=Module[{point,charlist,powers},
charlist=Characters[s];
point=(Position[charlist,"."]//Flatten//First);
powers=({If[point>1,Range[0,point-2],{}],{0}
,Range[-1,-(Length[charlist]-point),-1]}//Flatten);
(2^powers).ToExpression/@(MapAt[0&,charlist,point])
]
EvaluateBinary::usage="EvaluateBinary[s] evaluates a string s of binary digits, as a rational number.";

?BinaryExpand

?EvaluateBinary

Test it.

(Sqrt[10.])
BinaryExpand[%]
EvaluateBinary[%]//N

Row[{#," ≈ ",BinaryExpand[#]}]&/@{1/3,2/3,4/3,8/3}//ColumnForm

Row[{#," ≈ ",BinaryExpand[#]}]&/@{1/5,2/5,4/5,8/5,3/5,6/5}//ColumnForm

Row[{#," ≈ ",BinaryExpand[#]}]&/@{1/7,2/7,4/7,8/7}//ColumnForm

Row[{#," ≈ ",BinaryExpand[#]}]&/@{3/7,6/7,12/7,5/7,10/7}//ColumnForm

How does this relate to the Doubling map?

Definition of Chaos

Plain English:   a state of total confusion with no order

Physics:   the property of a complex system whose behavior is so unpredictable as to appear random, owing to great sensitivity to small changes in conditions.

Mathematics:

Edward Lorenz:   (deterministic chaos)  when the present determines the future, 
but the approximate present does not approximately determine the future.

Robert L. Devaney:  for a dynamical system to be classified as chaotic, it must have these properties:
	1.  it must be sensitive to initial conditions
	2.  it must be topologically mixing
	3.  it must have dense periodic orbits

Later we will give precise definitions of all of these properties.
We can see some of them already in the Dyadic Map example.

Doubling with variable Modulus

Manipulate[
Module[{datapoints,k,levels,modulus},
levels=n;
modulus=Floor[q];
datapoints=NestList[Mod[2#,modulus]&,Range[10],levels];
ListPlot[Table[{#,k}&/@datapoints[[k]],{k,1,levels}],Frame->True]
],{{q,2399,"modulus"},1000,5000}
,{{n,30,"iterations"},Range[10,100,10]}]

Week 2 — parametrized Baker’s Map

Add a multiplying parameter m to the Baker’s map, with 0<m<1.
We’ll study its iterates for the existence of k-cycles, with low values for k.

Baker[m_,x_]:=2m x /;x≥0&&x≤.5
Baker[m_,x_]:=2m (x-.5) /;x>.5&&x≤1

Manipulate[Plot[
Nest[Baker[m,#]&,x,n],{x,0,1}
,PlotStyle->Red,PlotRange->{{0,1},{0,1}},AspectRatio->1,Frame->True
,GridLines->{{1/2,m/(((2m))^n),1/2+m/(((2m))^n)},{m}}
,PlotLabel->("parametrised Baker's Map")
,Exclusions->(1/2)((1/(((2m))^n))Total/@Subsets[(((2m))^(Range[0,n]))])
,Epilog->{{Black,Line[{{0,0},{1,1}}]},Text[Style["m",Larger],{0,m},1.4{-1,-1}]}
],{{n,4,Style["n =",Large]},Range[10]},{{m,.69,Style["m",Large]},0,1}]

The widget above is set to show roughly the minimum value of m for which a 4-cycle exists. 
What is this value? — Click the `+` at right of the controller for m to see its value.
Later we obtain a more exact value for this minimum.
Exercise: change n to 5, and adjust m to get the minimum value for a 5-cycle to exist.  
Similarly for 6, 7, etc.  Write down your approximate values, to compare with the later calculations.

{{2,.809},{4,.690},{5,.662},{6,.6425},... }

Manipulate[Module[{Baker,zn,z0=N[z],z0n,znall},
Baker[m_,x_]:=2m x /;x≥0&&x≤.5;
Baker[m_,x_]:=2m (x-.5) /;x>.5&&x≤1;
znall=NestList[Baker[m,#]&,z0,n];
z0n=Prepend[Drop[znall,-1],0];
zn=znall//Last;
Plot[Baker[m,x],{x,0,1}
,PlotStyle->Red,PlotRange->{{0,1},{0,1}},AspectRatio->1,Frame->True
,PlotLabel->(Row[{"Baker's Map:  ",x," ↦ ", Baker["m","x"]}])
,GridLines->{Range[1,(2^(Min[n,3]))]/(2^(Min[n,3])),Range[1,(2^(Min[n,3]))]/(2^(Min[n,3]))}
,FrameTicks->{Append[Range[0,(2^(Min[n,3]))]/(2^(Min[n,3])),1],Append[Range[0,(2^(Min[n,3]))]/(2^(Min[n,3])),1]}
,Exclusions->{1/2}
,Epilog-> {{Black,Line[{{0,0},{1,1}}]}
,{Blue
,Line[Append[MapAt[Reverse,Flatten[
{{z0n,znall}//Transpose,{znall,znall}//Transpose}//Transpose
,1],1],{zn,0}]]
,Text[(Subscript["x", 0]),{z0,0},-1.3{1,1}],Text[(Subscript["x", n]),{zn,0},-1.3{1,1}]}}
,Background->White
]],{{n,1,Style["n =",Large]},Range[15]},{{m,.35,Style["m",Large]},0,1}
,{{z,0.42,Style["(Subscript[x, 0])",Large]},0,1}]

k-cycles occur only for a finite range of parameter values m.
What is the lowest value of m for which there can be 
a 2-cycle, 3-cycle, 4-cycle, etc. ?

Manipulate[Module[{Baker,zn,z0=.5,z0n,znall,mmin,min},
Baker[m_,x_]:=2m x /;x≥0&&x≤.5;
Baker[m_,x_]:=2m (x-.5) /;x>.5&&x≤1;
mmin=min/.(
Solve[(((2 min))^k)-(((2 min))^(k-1))==1&&min>0,min,Reals]//N//First);
If[m<mmin,m=mmin;z0=N[(mmin/((((2 mmin))^k)-1))]
,z0=N[(m/((((2 m))^k)-1))]];
znall=NestList[Baker[m,#]&,z0,n];
z0n=Prepend[Drop[znall,-1],0];
zn=znall//Last;
Plot[Baker[m,x],{x,0,1}
,PlotStyle->Red,PlotRange->{{0,1},{0,1}},AspectRatio->1,Frame->True
,PlotLabel->(Row[{"Baker's Map:  ",x," ↦ ", Baker["m","x"]}])
,GridLines->{Range[1,(2^(Min[n,3]))]/(2^(Min[n,3])),Range[1,(2^(Min[n,3]))]/(2^(Min[n,3]))}
,FrameTicks->{Append[Range[0,(2^(Min[n,3]))]/(2^(Min[n,3])),1],Append[Range[0,(2^(Min[n,3]))]/(2^(Min[n,3])),1]}
,Exclusions->{1/2}
,Epilog-> {{Black,Line[{{0,0},{1,1}}]
,{Magenta,Line[{{0,m},{m,m},{m,0}}],Text["m",{m,m},1.3{1,-1}]}},
,{Blue
,Line[Append[MapAt[Reverse,Flatten[
{{z0n,znall}//Transpose,{znall,znall}//Transpose}//Transpose
,1],1],{zn,0}]]
,Text[(Subscript["x", 0]),{z0,0},-1.3{1,1}],Text[(Subscript["x", n]),{zn,0},-1.3{1,1}]}}
,Background->White
]],{{n,10,Style["n =",Large]},Range[15]}
,{{m,.95,Style["m",Large]},1/2,1}
,{{k,2,Style["k",Large]},Range[2,15]}]

2-cycles: must have one value ≤(1/2) and one >(1/2). Why?
Then the lowest value maps as: (Subscript[x, 0]) ↦ (Subscript[x, 1])=2m (Subscript[x, 0]) ↦ 2m (2m (Subscript[x, 0])-(1/2))=(Subscript[x, 0]), 
so that  (Subscript[x, 0])=(m/(4(m^2)-1))≤(1/2).  Equality occurs for some value of m — find it!
Below this, (Subscript[x, 0]) would become larger than (1/2), so this is the minimum value of m for which 2-cycles can occur. (The maximum is m=1, for the dyadic map.)

Plot[{(m/(4(m^2)-1)),(m/(8(m^3)-1)),(m/(16(m^4)-1)),(m/(32(m^5)-1)),(m/(64(m^6)-1)),(m/(128(m^7)-1)),(m/(256(m^8)-1)),(m/(512(m^9)-1)),(m/(1024(m^10)-1))},{m,(1/2),1}
,AspectRatio->1,PlotRange->{{0.4,1},{0,.6}},PlotPoints->60,Frame->True
,FrameLabel->{Style["m > 0.5",Large,FontFamily->"CMMI10"]
,Style[(Subscript[x, 0])<0.5,Large,FontFamily->"CMMI10"]}
,GridLines->{Prepend[
(m/.minvalues)//Flatten//Reverse,.5],{.5}}
,Epilog->{Text["2-cycle",{1,(1/3)},1.3{1,-1}]
,Text["3-cycle",{1,(1/7)},1.4{1,-1.5}]
,Text["4-cycle",{1,(1/15)},1.4{1,-1.5}]
,Text["5-cycle",{1,(1/31)},{1.7,-1.1}],Text["6-cycle",{1,(1/63)},{3.7,-0.75}]
,White,Polygon[{{0.41,.502},{0.99,.502},{.99,0.595},{0.41,0.595}}]}]

k-cycles: can have all but one value ≤(1/2) and one >(1/2). Why?
Then the lowest value (Subscript[x, 0]) maps as follows: 
		(Subscript[x, 0]) ↦ (Subscript[x, 1])=2m (Subscript[x, 0]) ↦ (Subscript[x, 2])=(((2m))^2) (Subscript[x, 0])  
      ↦ …  ↦(Subscript[x, k-1])=(((2m))^(k-1)) (Subscript[x, 0])
      ↦ 2m ((((2m))^(k-1)) (Subscript[x, 0])-(1/2))=(Subscript[x, 0]) 
so that  (Subscript[x, 0])=(m/((((2m))^k)-1)), (Subscript[x, 1])=((2(m^2))/((((2m))^k)-1)), (Subscript[x, 2])=((m (((2m))^2))/((((2m))^k)-1)) …, (Subscript[x, k-1])=((m (((2m))^(k-1)))/((((2m))^k)-1))≤m.  
Equality occurs for some value of m — find an equation for it!
It corresponds to when (Subscript[x, k-2])=(1/2). Why?
Below this, (Subscript[x, k-2]) becomes larger than (1/2), so this is the minimum value of m 
for which k-cycles can occur. (The maximum is m=1, for the dyadic map.)

(minvalues=Table[Solve[(((2m))^k)-(((2m))^(k-1))==1&&m>0,m,Reals]
,{k,2,10}]//N)//ColumnForm

Calculate those values of (Subscript[x, 0]) for the various k-cycles, at those minimal m-values.

(x0values = Table[(m/((((2m))^k)-1))/.(minvalues[[k-1]]//First)
,{k,2,10}])//ColumnForm

Indeed, calculate all the (Subscript[x, j]) values, for these k-cycles.

Table[Row[{k,"-cycle: ",NestList[(Baker[m,#]/.(minvalues[[k-1]]//First))&,x0values[[k-1]],k]}]
,{k,2,9}]//ColumnForm

Pick one, and follow the k-cycle for many iterations.

NestList[(Baker[m,#]/.(minvalues[[5]]//First))&,x0values[[5]],100]

Partition[%,6]

Notice the eventual small deviation in the final digit.
With more iterations this deviation from the k-cycle  becomes more pronounced. Why?

Partition[NestList[(Baker[m,#]/.(minvalues[[5]]//First))&,x0values[[5]],200],6]

Ultimately there is no longer any discernible pattern, apart from:
	whenever the number is >(1/2) then 
	the next number is quite small (usually <0.15, say)
	followed by an increase for 5+ more steps to become >(1/2) again.

$MachinePrecision

(10^(-$MachinePrecision))

2m/.(minvalues[[5]]//First)

1.2851990332453493`

SetDirectory["~/Documents/FoS-Courses/MATH332/Notebooks/"]

<<GraphicalAnalysis-v10.m

?Bifurcation

Bifurcation[Baker[m,x],{x,0.11,.93},{m,.45,1},Transients->300,Iterations->750,Slices->300,PlotRange->{0,1},AspectRatio->Full,Frame->True,PlotLabel->"Bifurcation Diagram for Baker's Map"]