# The Chaos Game - part II

Posted 2 years ago
3279 Views
|
6 Replies
|
18 Total Likes
| A couple of weeks ago I posted my first The Chaos Game post. This will be a continuation on that, exploring some new ideas. Please make sure to read the previous one first. And once you're finished with this post, read the continuation part III.

## Colors

The first thing I wanted to try after my previous post was coloring. Let's color each of the points based on the point it jumps towards to:

ClearAll[sequence]
sequence[n_,m_]:=RandomChoice[Range[n],m]
Table[
circlepoints=N@CirclePoints[n];
seq=sequence[n,50000];
pts=Rest[FoldList[(#1+circlepoints[[#2]])/2&,RandomChoice[circlepoints],seq]];
plotdata=Transpose[{pts,seq}];
plotdata=SortBy[GatherBy[plotdata,Last],#[[1,2]]&];
plotdata=plotdata[[All,All,1]];
colors=ColorData/@Range[n];
Rasterize[Graphics[{PointSize[0.001],Riffle[colors,Point/@plotdata],FaceForm[],EdgeForm[Black],RegularPolygon[n],PointSize[0.01],Riffle[colors,Point/@circlepoints]},ImageSize->{400,400},PlotRange->1.1],"Image",ImageSize->{400,400},RasterSize->{400,400}]
,
{n,3,8}
] // Partition[#,3]& // ImageAssemble This explains why the regular triangle and the square have such an unique behavior; it does not 'blend'. To be more precise: the triangle only excludes spaces, and the square exactly covers the plane again. For higher order regular polygons you see that there is overlap and that creates high and low density regions creating a bunch of patterns.

For the case of restricted jumping, like we did last time, we can also do the coloring, here the modified code:

ClearAll[CreateSequence,CreateSequenceImage]
CreateSequence[n_,steps_,choices_]:=Mod[Accumulate[RandomChoice[choices,steps-1]~Prepend~1],n,1]
CreateSequenceImage[n_,m_,choices_]:=Module[{seq,circlepoints,pts,plotdata,colors},
seq=CreateSequence[n,m,choices];
circlepoints=N@CirclePoints[n];
pts=Rest@FoldList[(#1+circlepoints[[#2]])/2&,First[circlepoints],seq];
plotdata=Transpose[{pts,seq}];
plotdata=SortBy[GatherBy[plotdata,Last],#[[1,2]]&];
plotdata=plotdata[[All,All,1]];
colors=ColorData/@Range[n];
Rasterize[Graphics[{FaceForm[],EdgeForm[Black],RegularPolygon[n],PointSize[0.001],Riffle[colors,Point/@plotdata],PointSize[0.03],Riffle[colors,Point/@circlepoints]},ImageSize->300,PlotRange->1.1],"Image",RasterSize->{300,300}]
]


Let's have a look at all the possible jumping-subsets for hexagons:

Grid[Join @@@
Partition[{#, CreateSequenceImage[6, 10^4, #]} & /@
Subsets[Range, {1, \[Infinity]}], UpTo], Frame -> All] Some really nice patterns are now created!

## Fractional jumping

Up to now we have always jumped half-way, let's change that, and see what happens. I will introduce alpha the factor that we jump. Historically we always have set that to 0.5 (half-way). In my definition 0 means not moving, and 1 going all the way to the next point. The code can be easily modified:

ClearAll[sequence]
sequence[n_,m_]:=RandomChoice[Range[n],m]
FactorJump[n_,m_,\[Alpha]_]:=Module[{circlepoints,seq,pts,counts,img,bg},
circlepoints=N@CirclePoints[n];
seq=sequence[n,m];
pts=FoldList[(1-\[Alpha])#1+\[Alpha] circlepoints[[#2]]&,First[circlepoints],seq];
counts=Transpose@BinCounts[pts,{-1.1,1.1,0.005},{-1.1,1.1,0.005}];
counts=Reverse[counts];
img=Image[1-counts/Max[counts]];
bg=Graphics[Graphics[{FaceForm[],EdgeForm[Black],RegularPolygon[n],Text[NumberForm[\[Alpha],{\[Infinity],2}],{0,1.05}]},ImageSize->500,PlotRange->1.1]];
bg=Rasterize[bg,"Image",RasterSize->ImageDimensions[img],ImageSize->ImageDimensions[img]];
ImageMultiply[img,bg]
]


Note that I also included the plotting of the density of the points using BinCounts, which gives smooth images. Let's try it out with some new alpha:

FactorJump[3, 10^7, 0.3] pretty nifty! Let's make a movie changing alpha gradually from 0 to 1:

n = 3;
imgs = Table[FactorJump[n, 3 10^5, \[Alpha]], {\[Alpha], 0, 1, 0.01}];
Export[ToString[n] <> "factor.gif", imgs, "DisplayDurations" -> 1/25.0] Now for squares: pentagons: Of course we are not limited by our range 0 to 1, we can go beyond. (negative alpha means you run away, quickly going outside the screen, so that is not a good idea). Here for pentagons, and for alpha up to 1.8: ## Distance jumping

Rather than jumping a certain fraction, let's jump a specific distance in the direction of our point. Again we modify the code quite easily:

ClearAll[sequence,DistanceJump]
sequence[n_,m_]:=RandomChoice[Range[n],m]
DistanceJump[n_,m_,d_]:=Module[{circlepoints,seq,pts,counts,img,bg,reg,size},
circlepoints=N@CirclePoints[n];
seq=sequence[n,m];
pts=FoldList[#1+d Normalize[circlepoints[[#2]]-#1]&,First[circlepoints],seq];
size=3;
counts=Transpose@BinCounts[pts,{-size,size,size/250.0},{-size,size,size/250.0}];
counts=Reverse[counts];
reg=Quantile[Join@@counts,0.999];
img=Image[1- counts/reg];
bg=Graphics[Graphics[{FaceForm[],EdgeForm[Black],RegularPolygon[n],Text[NumberForm[d,{\[Infinity],2}],{0,-1.05}]},ImageSize->500,PlotRange->size]];
bg=Rasterize[bg,"Image",RasterSize->ImageDimensions[img],ImageSize->ImageDimensions[img]];
ImageMultiply[img,bg]
]


Let's try it out:

DistanceJump[5, 10^6, 0.5] again we see patterns emerge; let's again make a movie varying the distance d:

j=0;
Dynamic[j]
n=3;
CloseKernels[];
LaunchKernels;
DistributeDefinitions[DistanceJump,n]
SetSharedVariable[j];
imgs=ParallelTable[j++;DistanceJump[n,10^6,d],{d,0.1,3,0.01}];
Export[ToString[n]<>"distance.gif",imgs,"DisplayDurations"->1/25.0] and for a pentagon: Really nice visualization with very complicated patterns emerging from the very simple equations! Hope you enjoyed this little exploration. Answer
6 Replies
Sort By:
Posted 4 months ago
 Thanks Vitaliy! I even further expanded the function, as compared to what I show here in the posts. It can also accept a ExclusionRegionFunction now which prohibits jumping in that area. Creating all kinds of new patterns and possibilities. Answer
Posted 4 months ago
 This is awesome, Sander, thanks for the update and the function! Answer
Posted 4 months ago
 The functionality of this post has been summarized in the function GeneralizedChaosGame, available on the Wolfram Function Repository:https://resources.wolframcloud.com/FunctionRepository/resources/GeneralizedChaosGameSo you can now try this out using simply: ResourceFunction["GeneralizedChaosGame"][3, 3 10^4] Enjoy! Answer
Posted 2 years ago - Congratulations! This post is now a Staff Pick! Thank you for your wonderful contributions. Please, keep them coming! Answer
Posted 2 years ago
 Here another visualisation for a pentagon 12 billion(!) jumps. Click here to open the image in a new tab and see all the details: 36 megapixels. Answer
Posted 2 years ago
 Here is high-resolution visualisation for a hexagon: and see here the animation: https://www.youtube.com/watch?v=leVGf5TiNnE Answer