Message Boards Message Boards

The Chaos Game - part II

enter image description here

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[97]/@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

enter image description here

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[97]/@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[6], {1, \[Infinity]}], UpTo[4]], Frame -> All]

enter image description here

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]

enter image description here

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]

enter image description here

Now for squares:

enter image description here

pentagons:

enter image description here

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:

enter image description here

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]

enter image description here

again we see patterns emerge; let's again make a movie varying the distance d:

j=0;
Dynamic[j]
n=3;
CloseKernels[];
LaunchKernels[4];
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]

enter image description here

and for a pentagon:

enter image description here

Really nice visualization with very complicated patterns emerging from the very simple equations! Hope you enjoyed this little exploration.

POSTED BY: Sander Huisman
6 Replies

The functionality of this post has been summarized in the function GeneralizedChaosGame, available on the Wolfram Function Repository:

https://resources.wolframcloud.com/FunctionRepository/resources/GeneralizedChaosGame

So you can now try this out using simply:

ResourceFunction["GeneralizedChaosGame"][3, 3 10^4]

Enjoy!

POSTED BY: Sander Huisman

This is awesome, Sander, thanks for the update and the function!

POSTED BY: Vitaliy Kaurov

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.

POSTED BY: Sander Huisman

enter image description here - Congratulations! This post is now a Staff Pick! Thank you for your wonderful contributions. Please, keep them coming!

POSTED BY: Moderation Team

Here another visualisation for a pentagon 12 billion(!) jumps. enter image description here

Click here to open the image in a new tab and see all the details: 36 megapixels.

POSTED BY: Sander Huisman

Here is high-resolution visualisation for a hexagon:

enter image description here

and see here the animation: https://www.youtube.com/watch?v=leVGf5TiNnE

POSTED BY: Sander Huisman
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract