3
$\begingroup$

I recently watched the Numberphile video "Chaos Game" and I am trying to recreate the phenomenon discussed therein. The video depicts the following process:

  • First, draw 3 points somewhere within the unit square to form the vertices A, B, and C of a triangle.
  • Also draw one additional starting-point P somewhere in the unit square.
  • Now iterate the following process many times:
    • Choose one of the 3 vertices A, B, or C at random.
    • Draw the point Q that is halfway between P and the chosen vertex.
    • Let Q be the new P.

To perform this process using Mathematica, I begin by defining a function to generate a random point on the unit square:

randomPoint[] := {RandomReal[], RandomReal[]}

Using this function I randomly choose 3 vertices for my triangle:

vertices = Table[randomPoint[], {3}];

Now I just need to generate a list of points to mark. The first point is chosen at random; then each successive point is the average of the previous point and a randomly chosen vertex. So I thought a RecurrenceTable might do the trick:

points = RecurrenceTable[
    {p[0] == randomPoint[], p[n+1] == Mean[{p[n], RandomChoice@vertices}]},
    p, {n, 10}];

I expected a result that looks like

ListPlot[{points, vertices},
    PlotRange -> {{0, 1}, {0, 1}}, PlotStyle -> {Black, Red}, AspectRatio -> 1, Frame -> True, FrameTicks -> None, Joined -> True, Mesh -> Full]

enter image description here

but instead I got

enter image description here

At my best guess, rather than make a new RandomChoice of vertex for each iteration of the recurrence, this seems to be making a single RandomChoice at definition-time, so I wind up always approaching halfway to the same vertex in every step. So how can I rewrite this to make an independent random choice of vertex in each step?

$\endgroup$
1
$\begingroup$

If you do not have to use RecurrenceTable you can use NestList to get the desired result:

pts = NestList[Mean[{#, RandomChoice[vertices]}] &, randomPoint[], 20];

ListPlot[{pts, vertices}, PlotRange -> {{0, 1}, {0, 1}}, 
 PlotStyle -> {Black, Red}, AspectRatio -> 1, Frame -> True, 
 FrameTicks -> None, Joined -> True, Mesh -> Full]

Mathematica graphics

$\endgroup$
2
$\begingroup$
sq[n_, m_] := Module[{pts = RandomReal[1, {m + 1, 2}], p, ic, f},
  {p, ic} = {pts[[1 ;; m]], pts[[-1]]};
  f = FoldList[(#2 + #1)/2 &, ic, RandomChoice[p, n]];
  Graphics[{Green, PointSize[0.02], Point[p], Red, PointSize[0.01], 
    Point[f]}]
  ]

e.g.

Partition[Table[sq[10000, 3], 9], 3] // Grid

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.