Kolakoski Sequence Visualizations
Kolakoski Sequence Visualizations
In[]:=
(*givenalistofkolakoskiterms,addtheblockthatisdefinedbythenthgiventerm*)nthkolakoski[list_,n_]:=With[ {nthdigit=list[[n]],newdigit=If[Last[list]===1,2,1]}, Join[list,Table[newdigit,nthdigit]]];
In[]:=
(*getniterationsofthekolakoskisequence*)kolakoski[n_,s_:1]:=Block[{start,res}, start=If[s==1,{1},{2}]; res=FoldList[nthkolakoski,start,Flatten[Range[n]]]; If[ListQ[n],Flatten[res[[n+1]]],res]];
In[]:=
kolakoskiTurn[line_,n_:1]:=Append[line, Last[line]+If[EvenQ[Length[line]], {RandomChoice[{-1,1}]*kolakoski[{blocks}][[n]],0},(*left/right*) {0,RandomChoice[{-1,1}]*kolakoski[{blocks}][[n]]}(*up/down*) ]];
random walk
random walk
In[]:=
(*seeasinglerandom`blocks`-longKolakoskiwalk*)start={0,0};blocks=100;Graphics[{Line[Fold[kolakoskiTurn,{start},Range[blocks]]]},ImageSize->Medium]
Out[]=
random walk animation -- (note: doesn't render well in the Cloud, so stills are provided here)
random walk animation -- (note: doesn't render well in the Cloud, so stills are provided here)
(*seeananimationof`walks`-manydifferent`blocks`-longKolakoskiwalks*)(*walks=10;routes=Table[Fold[kolakoskiTurn,{start},Range[blocks]],walks];bound=Max[Abs/@Flatten[List@@BoundingRegion[Flatten[routes,1]]]]+1;indexes=Flatten[Transpose[{Table[#,blocks],Range[blocks]}]&/@Range[walks],1];Animate[ Graphics[ Line[routes[[First[indexes[[i]]],;;Last[indexes[[i]]]]]], Opacity[0.2], If[i>blocks,Line[routes[[;;Floor[i/blocks]]]]] , PlotRange{{-bound,bound},{-bound,bound}}, ImageSizeMedium ], {i,1,Length[indexes],1}, AnimationRate20]*)
In[]:=
walks=10;routes=Table[Fold[kolakoskiTurn,{start},Range[blocks]],walks];bound=Max[Abs/@Flatten[List@@BoundingRegion[Flatten[routes,1]]]]+1;Grid[Partition[Part[Table[Graphics[{Line[routes[[i]]],Opacity[0.2],Line[routes[[;;i]]]},PlotRange{{-bound,bound},{-bound,bound}},ImageSizeMedium],{i,1,walks,1}],{2,4,7,10}],2]]
Out[]=
perfect square array plots
perfect square array plots
In[]:=
(*createa(pxp)ArrayPlotofthenthiterationoftheKolakoskisequence*)Options[kolakoskiArrayPlot]=Options[ArrayPlot];kolakoskiArrayPlot[n_,p:_Integer:Automatic,opts:OptionsPattern[]]:=With[ {seq=kolakoski[{n}]}, ArrayPlot[ Partition[seq,p/.Automatic->UpTo[Ceiling[Sqrt[Length[seq]]]]], opts ]];
In[]:=
(*plotiterationsoftheKolakoskisequencethatcontainaperfect-squarenumberofterms*)squareTerms=Flatten[Position[Length/@kolakoski[6600],n_/;IntegerQ[Sqrt[n]]]]-1;squareGrids=kolakoskiArrayPlot[#,ColorRules->{1->White,2->Black}]&/@squareTerms;GraphicsGrid[Partition[squareGrids,Floor[Sqrt[Length[squareGrids]]]], Spacings->0,ImageSize->500]
Out[]=
