Zajęcia II : Rodzina kwadratowa

Zad. 1

(Subscript[x, n+1])=((Subscript[y, n+1])/M)=λ ((Subscript[y, n])/M)(1-((Subscript[y, n])/M))=λ ((Subscript[y, n])/M)-λ(((((Subscript[y, n])/M)))^2)
(Subscript[y, n+1])=λ (Subscript[y, n])-(Subscript[λy, n])(((Subscript[y, n])/M))
Opisuje populację o licznosci (Subscript[y, n]) w n-tym kroku, której przyrost w kazdym kroku jest liniowy ze stala wzrostu λ oraz uwzględniona jest pojemność środowiska przez co (((Subscript[y, n])/M)) z powstałych bakterii w każdym kroku wymiera(jest to wspołczynnik zależny od aktualnego obciażenia środowiska przez bakterie tzn. im liczniejsza jest populacja bakterii tym bliższy on jest 1 i tym samym więcej bakterii wymiera w danym kroku)

Zad. II

f[λ_,x_]:=N[λ*x*(1-x)]

orbita[λ_,x_,n_]:=NestList[f[λ,#]&,x,n-1]

orbita[3.12,0.23,30]

Zad. III

ListPlot[orbita[3.12,0.23,30]]

Zauważamy, że trzeba poprawić bo startujemy z (1,(Subscript[x, 0])) a powinniśmy z (0,(Subscript[x, 0]))

pom=orbita[3.12,0.23,30];
Table[{i-1,pom[[i]]},{i,1,Length[pom]}]

Aby pokazać, że można definiować różne funkcje definiujemy funkcję tworzącą odpowiedniego ListPlota
[[1]] - jest potrzebne aby uzyskać rozwiązanie bez { }. Proszę spróbować wywołąć bez tego.

wykresorbity[λ_,x_,n_]:=
{pom=orbita[λ,x,n];
pom1=Table[{i-1,pom[[i]]},{i,1,Length[pom]}];
ListPlot[pom1]
}[[1]]

wywołujemy testowo

wykresorbity[3.12,0.23,30]

"Upiększmy" nasz wynik

ladnywykresorbity[λ_,x_,n_]:=
{pom=orbita[λ,x,n];
pom1=Table[{i-1,pom[[i]]},{i,1,Length[pom]}];
ListPlot[pom1,
PlotRange->{{0,All},{0,1}},
Joined->True,
Mesh->Full,
PlotStyle->{Red,PointSize[Medium]},
LabelStyle->Directive[15,Black],
Frame->True,
RotateLabel->False,
FrameLabel->{"n",ToString[Subsuperscript["f",λ,"(n)"],StandardForm]<>"("<>ToString[x]<>")"},
PlotLabel->"orbita odwzorowania kwadratowego",
GridLines->Automatic,
ImageSize->600
]
}[[1]]

ladnywykresorbity[3.12,0.24,30]

Zad. IV

Manipulate[ladnywykresorbity[λ,x,Min[n,k]],
{{λ,2,"wartość λ"},1,4},
{{x,0.23,"wartość początkowa (Subscript[x, 0])"},0,1},
{{n,20,"max. długość orbity"},{20,40,80,160}},
{{k,20,"ilość widocznych iteracji"},1,n,1}
]

Zad. V

Definiujemy funkcję zwracającą n - ta iteracja odwzorowania logistycznego

ntaiteracja[λ_,x_,n_]:=Nest[f[λ,#]&,x,n]

Wywołujemy wynik :

Plot[ntaiteracja[3.5,x,2],{x,0,1}]

Manipulate[Plot[ntaiteracja[λ,x,n],{x,0,1}],
{{λ,2,"wartość λ"},1,4},
{{n,1,"numer iteracji"},1,10,1}
]

Należy "upiększyć" ten wynik aby nadać mu sens

Manipulate[Plot[{ntaiteracja[λ,x,n],x},{x,0,1},
PlotStyle->{Blue,{Red,Dashed}},
PlotRange->{{0,1},{0,1}},
AxesLabel->{"n",ToString[Subsuperscript["f",λ,"("<>ToString[n]<>")"],StandardForm]<>"(x)"},
LabelStyle->Directive[15,Black],
PlotLabel->"Wykres funkcji "<>ToString[Subsuperscript["f",λ,"("<>ToString[n]<>")"],StandardForm]<>"(x)"
],
{{λ,2,"wartość λ"},1,4},
{{n,1,"numer iteracji"},1,10,1}
]

Jako ciekawostkę dodajmy jeszcze jeden bajer

Manipulate[points1=NSolve[Nest[λ*(#*(1-#))&,z,n]==z,z,Reals];points2=Partition[Riffle[z/.points1,z/.points1],2];Show[Plot[{ntaiteracja[λ,x,n],x},{x,0,1},
PlotStyle->{Blue,{Red,Dashed}},
PlotRange->{{0,1},{0,1}},
AxesLabel->{"n",ToString[Subsuperscript["f",λ,"("<>ToString[n]<>")"],StandardForm]<>"(x)"},
LabelStyle->Directive[15,Black],
PlotLabel->"Wykres funkcji "<>ToString[Subsuperscript["f",λ,"("<>ToString[n]<>")"],StandardForm]<>"(x)"
],
ListPlot[points2,PlotStyle->{Black,PointSize[Large]}]
],
{{λ,2,"wartość λ"},1,4},
{{n,1,"numer iteracji"},1,5,1}
]

Zad. VI

Warto pokazać jaka jest idea:

Wybieramy sobie punkt startowy

x0=RandomReal[];

Jak generować orbitę :

asymptot1[λ_,n_]:=NestList[f[λ,#]&,x0,n-1]

asymptot1[1,10]

Wybieramy tylko końcowe punkty orbity :

asymptot2[λ_,n_,n0_]:=Take[NestList[f[λ,#]&,x0,n-1],-(n-n0)]

asymptot2[1,10,8]

Zamieniamy listę na taką któa pasuje do ListPlota[]

asymptot3[λ_,n_,n0_]:=Riffle[
ConstantArray[λ,n-n0],
Take[NestList[f[λ,#]&,x0,n-1],-(n-n0)]
]

asymptot3[1,10,8]

Jak będzie wyglądał argument ListPlot[]?

Table[asymptot3[λ,10,8],{λ,1,4,1}]

Nie tak to powinno wyglądać!! Stąd

Partition[Flatten[Table[asymptot3[λ,10,8],{λ,1,4,1}]],2]

Piszemy funkcję właściwą :

diagrambif[xo_,n_,n0_,krok_]:=ListPlot[Partition[Flatten[Table[asymptot3[λ,n,n0],{λ,1,4,krok}]],2]]

diagrambif[x0,400,390,1/100]

ladnydiagrambif[xo_,n_,n0_,krok_]:=ListPlot[Partition[Flatten[Table[asymptot3[λ,n,n0],{λ,1,4,krok}]],2],PlotRange->{0,1},
PlotStyle->Directive[PointSize[Tiny],Purple],
GridLines->Automatic,
Frame->True,
FrameLabel->{"λ","x"},
RotateLabel->False,
PlotLabel->"Diagram bifurkacyjny",
LabelStyle->Directive[15,Black],
FrameStyle->Directive[FontWeight->Bold,FontSize->18],
ImageSize->600]

ladnydiagrambif[x0,700,660,1/300]

Zad. VII

Losujemy wektor m liczb pseudolosowych z [0, 1]. Tu dla przykładu m=4.

RandomReal[1,4]

Działamy na każdej współrzędnej tego wektora n razy nasza funkcją

mielenie[λ_,m_,n_]:=Nest[Table[f[λ,#[[i]]],{i,1,m}]&,RandomReal[1,m],n]

Sprawdzamy czy dobrze działa :

mielenie[3.3,5,20]

Tworzymy histogram :

lista[lista_,bin_]:=HistogramList[lista,bin,"PDF"]

np :

lista[mielenie[3.3,5,20],8]

Rysowanie otrzymanej listy za pomocą ListPlot[]

zp=mielenie[4,10000,500];

miara[lis_,bin_]:={zpx=lista[lis,bin];ListPlot[Partition[Riffle[zpx[[1]],zpx[[2]]],2],Joined->True,Mesh->All]}[[1]]

miara[zp,30]

Gęstość niezmiennicza dla rodziny logistycznej: (1/(π(Sqrt[x(1-x)])))

miara2[lis_,bin_]:={zpx=lista[lis,bin];Show[
Plot[1/(Pi*Sqrt[x*(1-x)]),{x,0,1},PlotStyle->Red,AxesOrigin->{0,0}],
ListPlot[Partition[Riffle[zpx[[1]],zpx[[2]]],2],Joined->True,Mesh->All]
]
}[[1]]

miara2[zp,60]