Przykładowe rozwiązania laboratoriów 3 z Modelowania Matematycznego

Zbiór Cantora

Zapisujemy wartości N oraz l odpowiadające kolejnym metodom pokryca zioru Cantora odcinkami:

lista={{1,1},{1/3,2},{1/9,4},{1/27,8}}

Zgadujemy ogólny przepis postaci

lista=Table[{(3^(-n)),(2^n)},{n,0,10}];

llp=ListLogLogPlot[lista,Frame->True,FrameStyle->Directive[Thick,15],GridLines->Automatic,FrameLabel->{"l","N"},PlotMarkers->{Automatic,Medium}]

Dopasowujemy relację potęgową

fit=FindFit[lista,a (x^b),{a,b},x]

Sprawdzamy czy przewidywanie jest dobre

Show[llp,LogLogPlot[Evaluate[a (x^b)/.fit],{x,(10^(-6)),1},PlotStyle->Directive[Black,Thick]]]

Sprawdźmy wymiar fraktalny z teoretycznym

Log[2]/Log[3]//N

Narysujmy zbiór Cantora: najpierw podejście naiwne, w którym ręczni wpisujemy kolejne etapy

Graphics[{Thick,Line[{{0,1/2},{1,1/2}}],Line[{{0,2/2},{1/3,2/2}}],Line[{{2/3,2/2},{3/3,2/2}}],Line[{{0,3/2},{1/9,3/2}}],Line[{{2/9,3/2},{3/9,3/2}}],Line[{{6/9,3/2},{7/9,3/2}}],Line[{{8/9,3/2},{9/9,3/2}}]}]

Metoda bardziej zautomatyzowana (zachęcam do jej przeanalizowania, dla czytelności pozostawiam etapy posrednie, ale ze średnikiem na końcu, żeby się dało czytać)

RandomReal[{0,1},{40}];
RealDigits[#,3,3,-1]&/@RandomReal[{0,1},{40}];
RealDigits[#,3,1,-1][[1]]&/@RandomReal[{0,1},{40}];
Select[RandomReal[{0,1},{100}],FreeQ[RealDigits[#,3,1,-1][[1]],1]&]
Graphics[{LightGray,Rectangle[{-0.1,-0.1},{1.1,0.1}],Black,Point[{#,0}&/@Select[RandomReal[{0,1},{100}],FreeQ[RealDigits[#,3,1,-1][[1]],1]&]]}]

Zmieniamy teraz trzeci z parametrów funkcji RealDigits i obserwujemy kolejne “pokolenia”

Table[Graphics[{LightGray,Rectangle[{-0.1,-0.1},{1.1,0.1}],Black,PointSize[0.01],Point[{#,0}&/@Select[RandomReal[{0,1},{1000}],FreeQ[RealDigits[#,3,n,-1][[1]],1]&]]}],{n,6}]

Graphics[{LightGray,Rectangle[{-0.01,-0.01},{1.01,0.01}],Black,PointSize[0.001],Point[{#,0}&/@Select[RandomReal[{0,1},{1000}],FreeQ[RealDigits[#,3,6,-1][[1]],1]&]]}]

Wymiar pudełkowy dla rzeczywistej grafiki

Wczytujemy ulubioną grafikę

pl=CountryData["Poland","Shape"]

Sprawdzamy rozmiar obrazka

dimpl=ImageDimensions[pl]

Przyjmujemy za parametr δ rozmiar “plasterka” na jakie kroimy grafikę

δ=10;
Table[ImageTrim[pl,{{i,j},{i+δ,j+δ}}],{j,dimpl[[2]]-δ,-δ,-δ},{i,0,dimpl[[1]],δ}]

Wyszukujemy plasterki, które mają w sobie tylko kolor szary

szary=Mean@Flatten[Map[Total,ImageData[],{2}]]
δ=10;
Count[Mean@Flatten[Map[Total,ImageData[#],{2}]]&/@(Flatten@Table[ImageTrim[pl,{{i,j},{i+δ,j+δ}}],{j,dimpl[[2]]-δ,-δ,-δ},{i,0,dimpl[[1]],δ}]),szary]

2.6430000000000002`

Zauważmy, że możemy wszystkie obliczenia przyspieszyć od razu analizując macierz, a nie obrazek 
Drobne różnice wynikają z różnic w uśrednianiu wartości pikseli, nie powinny nas one niepokoić.

δ=10;pltab=Map[Total,ImageData[pl],{2}];
RepeatedTiming@Count[Mean/@(Flatten[#]&/@Flatten[Partition[pltab,{δ,δ},δ,1,10.],1]),u_/;u==szary]
RepeatedTiming@Count[Mean@Flatten[Map[Total,ImageData[#],{2}]]&/@(Flatten@Table[ImageTrim[pl,{{i,j},{i+δ,j+δ}}],{j,dimpl[[2]]-δ,-δ,-δ},{i,0,dimpl[[1]],δ}]),szary]

Sprawdźmy o ile przyspieszyło (dla δ = 10)

2.38/0.001840526119402985`2.

Skupmy się zatem na metodzie szybszej: policzymy N dla różnych rozmiarów l=δ

tab=Table[{δ,Count[Mean/@(Flatten[#]&/@Flatten[Partition[pltab,{δ,δ},δ,1,10.],1]),u_/;u==szary]},{δ,2,30,2}]

llp=ListLogLogPlot[tab,Frame->True,FrameStyle->Directive[Thick,15],GridLines->Automatic,FrameLabel->{"δ","N"},PlotMarkers->{Automatic,Medium}]

Dopasowujemy relację potęgową

fit=FindFit[tab,a (x^b),{a,b},x]

Sprawdzamy czy przewidywanie jest dobre

Show[llp,LogLogPlot[Evaluate[a (x^b)/.fit],{x,1,30},PlotStyle->Directive[Black,Thick]]]

Wymiar ok. 2.118 :)

Zbiór Julii i Mandelbrota

z=Table[x+I y,{x,-2,2,0.025},{y,-2,2,0.025}];
c=0.2-0.5I;
ArrayPlot[Map[If[Abs[#]>2,Min[Log@Abs[#],10],Abs[#]]&,Nest[((#)^2)+c&,z,6],{2}],ColorFunction->"SunsetColors"]

z=ParallelTable[If[Abs[#]>2,Min[Log@Abs[#],10],Abs[#]]&@Nest[(x+I y)+((#)^2)&,0,7],{x,-2.5,1,0.025},{y,-1.5,1.5,0.025}];
ArrayPlot[Transpose@z,ColorFunction->"AvocadoColors"]