Deterministisches Chaos an der Parabel *
Le chaos déterministe
 à la parabole

Entwicklung * Développement

Remove["Global`*"];

q[x_] := a x (1 - x)

q[x] // Expand

?NestList

a = 2.9;  ?q

q[x]

NestList[q, 0.4, 30]

a = 3.1; q[x]

a = 2.9;
Plot[q[x], {x, 0, 1}];

?AspectRatio

Plot[q[x], {x, 0, 1}, AspectRatio -> Automatic];

?Epilog

Plot[q[x], {x, 0, 1}, 
        Epilog ->  {
Line[{{0.2, 0}, {0.2, 
                  q[0.2]}}], 
 
            Line[{{0.2, q[0.2]}, {0, q[0.2]}}]
}, 
        AspectRatio -> Automatic];

Plot[q[x], {x, 0, 1}, 
        Epilog ->  {
Line[{{0, 0}, {1, 
                  1}}], 
Line[{{0.2, 0}, {0.2, 
                  q[0.2]}}], 
 
            Line[{{0.2, q[0.2]}, {0, q[0.2]}}]
}, 
        AspectRatio -> Automatic];

Plot[q[x], {x, 0, 1}, 
        Epilog ->  {
Line[{{0, 0}, {1, 
                  1}}], 
Line[{{0.2, 0}, {0.2, 
                  q[0.2]}}], 
 
            Line[{{0.2, q[0.2]}, {q[0.2], q[0.2]}}]
}, 
        AspectRatio -> Automatic];

Plot[q[x], {x, 0, 1}, 
        Epilog ->  {
Line[{{0, 0}, {1, 
                  1}}], 
Line[{{0.2, 0}, {0.2, 
                  q[0.2]}}], 
 
            Line[{{0.2, q[0.2]}, {q[0.2], q[0.2]}}], 
 
            Line[{{q[0.2], q[0.2]}, {q[0.2], 
                  q[q[0.2]]}}], 
 
            Line[{{q[0.2], q[q[0.2]]}, {q[q[0.2]], 
                  q[q[0.2]]}}]
}, 
        AspectRatio -> Automatic];

scale[
        x_] := 
{
Line[{{x, x}, {x, 
              q[x]}}], 
Line[{{x, q[x]}, {q[x], 
              q[x]}}]
}

Map[scale, {a1, a2, a3}]

NestList[q, 0.2, 5]

Map[scale, NestList[q, 0.2, 5]]

Plot[q[x], {x, 0, 1}, 
        Epilog ->  {
Line[{{0, 0}, {1, 
                  1}}], 
Map[scale, 
              NestList[q, 0.2, 5]]
}, 
        AspectRatio -> Automatic];

Plot[q[x], {x, 0, 1}, 
        Epilog ->  {
Line[{{0, 0}, {1, 
                  1}}], 
Map[scale, 
              NestList[q, 0.2, 30]]
}, 
        AspectRatio -> Automatic];

Programmierung * Programmation

Remove["Global`*"]

?Block

?Module

tryout[a_, x1_, x2_,  xs_, n_] := 
      Module[{q, x, scale}, 
q[x_] := 
          a x (1 - x) ; 
scale[
            x_] := 
{
Line[{{x, x}, {x, 
                  q[x]}}], 
Line[{{x, q[x]}, {q[x], 
                  q[x]}}]
}; 
Plot[
          q[x], {x, 0, 1}, 
          Epilog ->  {
Line[{{0, 0}, {1, 
                    1}}], 
Map[scale, 
                NestList[q, xs, n]]
}, 
          AspectRatio -> Automatic];
 ]

tryout[2.9, 0, 1,  0.2, 40]

tryout[2.9, 0, 1,  0.3, 30]

tryout[2.7, 0, 1,  0.3, 30]

tryout[3, 0, 1,  0.3, 30]

tryout[3.1, 0, 1,  0.3, 30]

tryout[4, 0, 1,  0.3, 30]

tryout[4.1, 0, 1,  0.3, 30]

Table[tryout[k, 0, 1,  0.3, 40], {k, 1, 4, 0.05}];

Iteration-Itération

Iteration an Fixpunkt = Schnittpunkt Gerade mit Parabel 
- Itération quant au point fixe, point d'intersection de la droite avec la parabole

Iteration an Fixpunkt=Schnittpunkt Gerade mit Parabel/Itération quant au point fixe,point d'intersection de la droite avec la parabole (==> Programm!!)

Remove["Global`*"];

f[x_,ym_]:=-4 ym (x^2-x)

Plot[{f[x,2],f[x,1],f[x,0.5],f[x,0.25],f[x,0.35],0.5,1,2,0.25,0.35,x},{x,0,1},AspectRatio->Automatic];

ym=1   ; fym[x_]:=-4 ym (x^2-x)

?Nest

fym[0.7]

fym[fym[0.7]]

fym[fym[x]]

nest[n_,x_]:= Nest[fym,x,n]; nest[3,a]

nest[1,x]

nest[0,x]

nest[0.5,x]

tab=Table[{n,nest[n,0.7]},{n,0,300}]

Table[{n,nest[n,0.7]},{n,0,300}]//MatrixForm

ym=1;
k=500 ;
fym[x_]:=-4 ym (x^2-x);
nest[n_,x_]:=Nest[fym,x,n];
tab=Table[{n,nest[n,0.7]},{n,0,k}];
Table[{n,nest[n,0.7]},{n,0,k}]//MatrixForm

tab=Table[{n,nest[n,0.7]},{n,0,k}]

tab1=Table[{1,tab[[n]][[2]]},{n,1,Length[tab]}]

ListPlot[tab1];

?Block

?Module

Remove[f,v,t]

f[v_]:=Module[{t},t=(1+v)^2;t=Expand[t]];
f[v]

g[k_]:=Module[{ym},
ym=1;
fym[x_]:=-4 ym (x^2-x);
nest[n_,x_]:=Nest[fym,x,n];
tab=Table[{n,nest[n,0.7]},{n,0,k}];
ListPlot[tab,PlotStyle->{PointSize[0.02]}];];

g[50]

Table[g[10 k],{k,1,100}]

ListPlot[tab1,PlotStyle->{PointSize[0.02]}];

tab2=Table[tab[[n]][[2]],{n,1,Length[tab]}]

?*Chart*

<< Graphics`Graphics`;

?Range

Range[0,1,0.1]

Histogram[tab2, 
        HistogramCategories -> Range[0,1,0.1]];

Histogram[tab2, 
        HistogramCategories -> Range[0,1,0.01]];

Histogram[tab2, 
        HistogramCategories -> Range[0,1,0.0025]];

Bifukationsdiagramme / Diagrammes de bifucation

Einfaches Programm / Programme simple

Remove["Global`*"];
trModule[aIn_, nIn_, mIn_] := 
        Module[{a, q, x, n, c, t, }, 
a = 
            aIn; 
n = nIn; 
m = 
            mIn; 
q[x_] := 
            a x (1 - x); 
c = 
            Complement[NestList[q, 0.5, n], 
              NestList[q, 0.5, m]]; 
t = 
            Table[a, {n, 1, Length[c]}]; 
tr = 
            Transpose[{t, 
                c}]
];
ListPlot[
        Flatten[Table[trModule[k, 80, 5], {k, 0.5, 4, 0.01}], 
          1]];

Verbessertes Programm / Programme amélioré

Remove["Global`*"];

trNewModule[x1In_, x2In_, nIn_, dIn_, psIn_, nestIn_] := 
        Module[{a, q, trN, n, m, d, ps}, 
x1 = 
            x1In; 
x2 = x2In; 
n = 
            nIn; 
d = dIn; 
ps = 
            psIn; 
nNeVar = 
            nestIn; 
q[x_] := 
            a x (1 - x); 
trN[m_, d_] := 
            Transpose[{Table[a, {m + 1}], 
                NestList[q, Nest[q, 0.5, nNeVar], 
                  m]}]; 
ListPlot[
            Flatten[Table[trN[n, d], {a, x1, x2, d}], 1], 
            PlotStyle -> PointSize[ps]];];
trNewModule[0, 4, 130, 0.01, 0.001, 500]

trNewModule[3, 4, 260, 0.0025, 0.001, 1000]

trNewModule[3.81, 3.87, 1000, 0.0001, 0.001, 1000]

Work

Remove["Global`*"];

a=2;
q[x_]:=a x (1-x) ;

q[x]

?NestList

NestList[q,1,20]

FixedPoint[q,1]

a=3;
q[x_]:=a x (1-x) ;

NestList[q,0.5,50]

(* FixedPoint[q,0.5]   !!!!!*)

c=Complement[NestList[q,0.5,50],NestList[q,0.5,10]]

Length[c]

t=Table[a,{n,1,Length[c]}]

tr=Transpose[{t,c}]

Transpose[{t,c}]//MatrixForm

ListPlot[tr];

trModule[aIn_, nIn_, mIn_] := 
        Module[{a, q, x, n, c, t, }, 
a = 
            aIn; 
n = nIn; 
m = 
            mIn; 
q[x_] := 
            a x (1 - x); 
c = 
            Complement[NestList[q, 0.5, n], 
              NestList[q, 0.5, m]]; 
t = 
            Table[a, {n, 1, Length[c]}]; 
tr = 
            Transpose[{t, c}]
];

trModule[3, 50]

Flatten[Table[trModule[k, 50], {k, 0.5, 3, 0.1}], 1]

Remove["Global`*"];

a=2;
q[x_]:=a x (1-x) ;

q[x]

?NestList

NestList[q,1,20]

FixedPoint[q,1]

a=3;
q[x_]:=a x (1-x) ;

NestList[q,0.5,50]

(* FixedPoint[q,0.5]   !!!!!!!!*)

c=Complement[NestList[q,0.5,50],NestList[q,0.5,10]]

Length[c]

t=Table[a,{n,1,Length[c]}]

tr=Transpose[{t,c}]

Transpose[{t,c}]//MatrixForm

ListPlot[tr];

trModule[aIn_, nIn_, mIn_] := 
        Module[{a, q, x, n, c, t, }, 
a = 
            aIn; 
n = nIn; 
m = 
            mIn; 
q[x_] := 
            a x (1 - x); 
c = 
            Complement[NestList[q, 0.5, n], 
              NestList[q, 0.5, m]]; 
t = 
            Table[a, {n, 1, Length[c]}]; 
tr = 
            Transpose[{t, c}]
];

trModule[3, 50]

Flatten[Table[trModule[k, 50], {k, 0.5, 3, 0.1}], 1]

Remove["Global`*"];

a = 3.5

q[x_] := a x (1 - x);

Table[a, {129}]

Nest[q, 0.5, 500]

NestList[q, Nest[q, 0.5, 500], 128]

NestList[q, Nest[q, 0.5, 500], 2]

NestList[q, Nest[q, 0.5, 500], 1]

Transpose[{Table[a, {129}], 
        NestList[q, Nest[q, 0.5, 500], 128]}]

Transpose[{Table[a, {3}], 
        NestList[q, Nest[q, 0.5, 500], 2]}]

trN[n_] := 
        Transpose[{Table[a, {n + 1}], 
            NestList[q, Nest[q, 0.5, 500], n]}];
trN[129]

Segmentdiagramme / Diagrammes de segments

Einfaches Programm / Programme simple

Remove["Global`*"];

aSegPlot[aIn_, xStartIn_, startCyclenIn_, zeigeCyclenIn_] := 
        Module[{a, q, x, xStart, startCyclen}, 
a = 
            aIn; 
xStart = 
            xStartIn; 
zeigeCyclen = 
            zeigeCyclenIn; 
startCyclen = 
            startCyclenIn; 
q[x_] := 
            a x (1 - x); 
Plot[
            q[x], {x, 0, 1}, 
PlotLabel -> 
              SequenceForm["a = ", 
                a], 
PlotRange -> {0, 
                1}, 
AspectRatio -> 
              Automatic, 
Epilog -> {Line[
                  Partition[
                    NestList[q, Nest[q, xStart, startCyclen], zeigeCyclen], 
                    2, 1]]}];
];
aSegPlot[3.1, 0.4, 400, 100]

Animate!!

Do[aSegPlot[a, 0.4, 400, 100], {a, 3, 4, 0.1}]

Neues Programm / Programme nouveau

Remove["Global`*"];

aSegPlotNeu[aIn_, xStartIn_, startCyclenIn_, zeigeCyclenIn_] := 
        Module[{a, q, x, xStart, startCyclen}, 
a = 
            aIn; 
xStart = 
            xStartIn; 
zeigeCyclen = 
            zeigeCyclenIn; 
startCyclen = 
            startCyclenIn; 
q[x_] := 
            a x (1 - x); 
Show[
            Graphics[{
Text[SequenceForm["a = ", a], 
                  Scaled[{1, 1}], {1, 1}], 
Line[
                  Partition[
                    NestList[q, Nest[q, xStart, startCyclen], zeigeCyclen], 
                    2, 1]]
}], 
            AspectRatio -> 
              Automatic]
];
aSegPlotNeu[3.1, 0.4, 500, 100];

Animate!!

Do[aSegPlotNeu[a, 0.4, 500, 100], {a, 3.4, 3.6, 0.01}]

Work

Remove["Global`*"];

li = {a1, a2, a3, a4, a5, a6, a7, a8, a9}

Partition[li, 3]

Partition[li, 2]

Partition[li, 2, 1]

Partition[li, 3, 2]

a=3.1;
q[x_]:=a x (1-x) ;
q[x]

NestList[q, 0.1, 30]

Partition[NestList[q, 0.1, 30], 2, 1]

Plot[
        q[x], {x, 0, 
          1}, 
Epilog -> {Line[
              Partition[NestList[q, 0.1, 30], 2, 1]]}];

Plot[
        q[x], {x, 0, 
          1}, 
Epilog -> {Line[
              Partition[NestList[q, Nest[q, 0.4, 400], 100], 2, 
                1]]}];

Fixpunktzykeln / Cycles de point fixe

Tryout

Remove["Global`*"];

?FixedPoint

FixedPoint[Cos, 0.4]

FixedPoint[Sin, 
      0.4]

NestList[Sin, 0.4, 25]

NestList[Sin, Nest[Sin, 0.4, 1000], 25]

NestList[Sin, Nest[Sin, 0.4, 10000], 25]

Plot[{x, Sin[x]}, {x, 0, 2}];

Plot[{x, Sin[x]}, {x, 0, 0.3}];

a = 3.1;
q[x_] := a x (1 - x);
NestList[q, 0.4, 50]

Einfaches Programm/ Programme simple

Remove["Global`*"];

\(\(mehrWertZyklusFixPunkte[f_, xStart_] := 
        Block[{n, nZwei, zaehler, resultat, \ 
            wert}, 

n = 
            f\ [xStart]; 
nZwei = 
            f[f[xStart]]; 
zaehler = 
            1; 

While[
            n =!= nZwei, 
n = 
              f[n]; 
nZwei = 
              f[f[nZwei]]; 
\(++zaehler\)]; 

resultat = {n}; 
wert = f[n]; 

While[
            n =!= wert, 
AppendTo[resultat, wert]; 
            wert = f[wert]]; 
Print["Zyklenlaenge = ", 
            Length[resultat]]; 
resultat];\)\)

a = 3.1;
q[x_] := a x (1 - x);
mehrWertZyklusFixPunkte[q, 0.3]

a = 3.5;
q[x_] := a x (1 - x);
mehrWertZyklusFixPunkte[q, 0.3]

a = 3.84;
q[x_] := a x (1 - x);
mehrWertZyklusFixPunkte[q, 0.3]

a = 3.846;
q[x_] := a x (1 - x);
mehrWertZyklusFixPunkte[q, 0.3]

a = 3.847;
q[x_] := a x (1 - x);
mehrWertZyklusFixPunkte[q, 0.3]

Mit Abbruchbedingung/ Avec condition d'arrêt    ===> Korr!!!!!

?SameQ

?TrueQ

Remove["Global`*"];

Options[mehrWertZyklusFixPunkteAbbr] = {SameTest -> SameQ, 
          CycleTest -> SameQ, 
IterationCount -> 
            False};

mehrWertZyklusFixPunkteAbbr[aIn_, xStart_, options___] := 
        mehrWertZyklusFixPunkteAbbr[aIn, xStart, 
          Infinity];
FuzzySame10Q[x_, 
          y_] := (Abs[x - y] < 
            10^(-10));
FuzzySame11Q[x_, 
          y_] := (Abs[x - y] < 
            10^(-11));
FuzzySame12Q[x_, 
          y_] := (Abs[x - y] < 
            10^(-12));
FuzzySame13Q[x_, 
          y_] := (Abs[x - y] < 
            10^(-13));
FuzzySame22Q[x_, 
          y_] := (Abs[x - y] < 10^(-22));

\(mehrWertZyklusFixPunkteAbbr[aIn_, xStart_, maxIterations_?NumberQ, 
        options___] := 
Block[{a, q, f, n, nZwei, zaehler, 
          resultat, \ wert, sameTest, cycleTest, 
          iterationCount}, 

{sameTest, 
            cycleTest, 
            iterationCount} = \({SameTest, CycleTest, 
                IterationCount} /. {options}\) /. 
            Options[mehrWertZyklusFixPunkteAbbr]; 
 (*\ \(Print[cycleTest];\)\ *) 
a = 
          aIn; 
q[a_, x_] := 
          a\ x\ \((1 - x)\); 
f[x_] := 
          q[aIn, x]; 
n = 
          f\ [xStart]; 
nZwei = 
          f[f[xStart]]; 
zaehler = 
          1; 

If[
          maxIterations =!= 
            Infinity, 
While[\((\(! sameTest[n, 
                    nZwei]\))\)\  && \ \((zaehler < 
                  maxIterations)\), 
n = 
              f[n]; 
nZwei = 
              f[f[nZwei]]; 
\ \ \ \ \ \(++zaehler\);\ ], 
While[\(! sameTest[n, 
                nZwei]\), 
\ \ \ \ \ \ \ \ \ \ \ \ n = 
              f[n]; 
\ \ \ \ \ \ \ \ \ \ \ \ nZwei = 
              f[f[nZwei]]; 
\ \ \ \ \ \ \ \ \ \ \ \(++zaehler\);\ ]\ ]; 

If[
          zaehler == maxIterations, 
\ \ \ resultat = 
            n\ , 
\ \ \ resultat = {nZwei}; 
\ \ \ wert = f[nZwei]; 
\ 
          While[\(! cycleTest[wert, nZwei]\), 
AppendTo[
              resultat, wert]; 
wert = 
              f[wert]]
]; 
If[
          TrueQ[iterationCount], {"Resultat = ", 
            resultat, \ " Zähler = ", \ 
            zaehler, \ " {n, nZwei, wert} = ", \ {\ n, \ nZwei, \ 
              wert}}, \ resultat]
]\)

a = 2.5;
mehrWertZyklusFixPunkteAbbr[a, 0.3, 500]

a = 2.6;   
mehrWertZyklusFixPunkteAbbr[a, 0.3, 100]

a = 3.1;
mehrWertZyklusFixPunkteAbbr[a, 0.3, 500]

a = 3.75;
mehrWertZyklusFixPunkteAbbr[a, 0.3, 500]

a = 3.75;
mehrWertZyklusFixPunkteAbbr[a, 0.3, 1000]

a = 3.75;
Table[mehrWertZyklusFixPunkteAbbr[a, 0.3, k], {k, 900, 1000}] // 
      MatrixForm

Plot[
        Length[mehrWertZyklusFixPunkteAbbr[a, 0.3, 500]], {a, 3.3, 
          3.5}];

Plot[
        Length[mehrWertZyklusFixPunkteAbbr[a, 0.5, 2000]], {a, 3.3, 
          3.5}];

Plot[
        Length[mehrWertZyklusFixPunkteAbbr[a, 0.5, 2000]], {a, 3.3, 3.5}, 
        PlotPoints -> 50];

Plot[
        Length[mehrWertZyklusFixPunkteAbbr[a, 0.5, 2000]], {a, 3.37, 3.39}, 
        PlotPoints -> 50];

a = 3.43;
mehrWertZyklusFixPunkteAbbr[a, 0.3, 1000]

a = 3.43;
mehrWertZyklusFixPunkteAbbr[a, 0.3, 5000]

a = 3.46;
mehrWertZyklusFixPunkteAbbr[a, 0.3, 5000]

a = 3.46;
mehrWertZyklusFixPunkteAbbr[a, 0.3, 500]

a = 3.46;
mehrWertZyklusFixPunkteAbbr[a, 0.3, 500, 
      CycleTest -> FuzzySame10Q]

a = 3.466;
mehrWertZyklusFixPunkteAbbr[a, 0.3, 500]

a = 3.466;
Table[
      mehrWertZyklusFixPunkteAbbr[a, 0.3, k, CycleTest -> FuzzySame10Q, 
        IterationCount -> True], {k, 280, 290}]

a = 3.466;
mehrWertZyklusFixPunkteAbbr[a, 0.3, 500]