Drawing the Pursuit curves

Question

I was reading this post on Filling Space with Pursuit Polygons. I didn't really see where the filling was, but found it quite interesting.

Then I saw these pursuit curves.

They seem to have used a different logarithm. For example looking at the square, by tweaking the code from the previous code, I got this

With[{data = {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {0, 0}}},  Graphics[{Table[{Scale[       Rotate[Line[data], 90/11*x Degree], {x, x}]}, {x, 0, 11}]}]]

Both picture has 11 sets of squares. With a bit trial and error, I got as close as possible by changing the angles.

How can I get the identical pictures?

And these ones below, which looks more challenging.

Answer 1

In this answer of mine I wrote a simple function that will draw the curve you are after, given an arbitrary polygon:

g[x_] := Fold[Append[#1, BSplineFunction[#1[[#2]], SplineDegree -> 1][.1]] &, x, Partition[Range[200], 2, 1]]

For example, given the triangle

ListPlot[Prepend[{{0, 0}, {1, 0}, {1/2, Sqrt[3]/2}}, {1/2, Sqrt[3]/2}], AspectRatio -> 1, Joined -> True, PlotRange -> All]

we get

ListPlot[Prepend[g@{{0, 0}, {1, 0}, {1/2, Sqrt[3]/2}}, {1/2, Sqrt[3]/2}], AspectRatio -> 1, Joined -> True, PlotRange -> All]

With this, it is just a matter of combining triangles to generate all the figures in the OP.

For example, given the hexagon

ListPlot[{Prepend[{{0, 0}, {1, 0}, {1/2, Sqrt[3]/2}}, {1/2, Sqrt[3]/2}], Prepend[{{1, 0}, {2, 0}, {3/2, Sqrt[3]/2}}, {3/2, Sqrt[3]/2}], Prepend[{{0, 0}, {1, 0}, {1/2, -(Sqrt[3]/2)}}, {1/2, -(Sqrt[3]/2)}], Prepend[{{1, 0}, {2, 0}, {3/2, -(Sqrt[3]/2)}}, {3/2, -(Sqrt[3]/2)}], Prepend[{{1/2, Sqrt[3]/2}, {3/2, Sqrt[3]/2}, {1, 0}}, {1, 0}], Prepend[{{1/2, -(Sqrt[3]/2)}, {3/2, -(Sqrt[3]/2)}, {1, 0}}, {1, 0}]}, AspectRatio -> 1, Joined -> True, PlotRange -> All]

we get

ListPlot[{Prepend[g@{{0, 0}, {1, 0}, {1/2, Sqrt[3]/2}}, {1/2, Sqrt[3]/2}], Prepend[g@{{1, 0}, {2, 0}, {3/2, Sqrt[3]/2}}, {3/2, Sqrt[3]/2}], Prepend[g@{{0, 0}, {1, 0}, {1/2, -(Sqrt[3]/2)}}, {1/2, -(Sqrt[3]/2)}], Prepend[g@{{1, 0}, {2, 0}, {3/2, -(Sqrt[3]/2)}}, {3/2, -(Sqrt[3]/2)}], Prepend[g@{{1/2, Sqrt[3]/2}, {3/2, Sqrt[3]/2}, {1, 0}}, {1, 0}], Prepend[g@{{1/2, -(Sqrt[3]/2)}, {3/2, -(Sqrt[3]/2)}, {1, 0}}, {1, 0}]}, AspectRatio -> 1, Joined -> True, PlotRange -> All]

Tweaking the parameters and using black lines, we get

which is almost identical to the figure in the OP. Similarly,

while the rest of figures are left to the reader.

Answer 2

I have made a very detailed post about these patterns on my website

• A simple scheme for a line-pattern

I won't repeat everything I have written there, but I explained in detail how this can be done in Mathematica and gave the full source code.

Edit

If you are wondering how to recreate the figure that you think is beautiful, please look at it carefully and try to find the underlying triangles that divide the large triangle.

You will see that you have a hexagon made of triangles in the center and on each second side you have one triangle outwards. The hardest part is to create these 10 triangles and (as I say in my blogpost) make them have the right direction (the order of the 3 points of each triangle).

There is surely an easier way to do this, but this hack will do to create the initial triangle points. It uses the points for a hexagon and creates all necessary triangles at once, taking care of their rotation:

pts = Table[{Cos[phi], Sin[phi]}, {phi, 0, 2 Pi, 2/6 Pi}];
tris = Flatten@MapIndexed[
    With[{odd = OddQ[#2[[1]]]},
      {triangle @@ Prepend[
         If[odd, Reverse, Identity]@#, {0, 0}],
       If[Not[odd],
        triangle[
         Plus @@ #, #[[1]], #[[2]]
         ],
        {}
        ]
       }
      ] &, Partition[pts, 2, 1]];

The rest is copying the code. As you might note, I have wrapped all triangle points into a triangle head. Now, we simply create the inner lines by replacing them and using the function from the site:

calcPoints[pts : {pcurr_, pnext1_, pnext2_, rest___}, f_, result_] := 
  calcPoints[{pnext1 + f*(pnext2 - pnext1), pnext2, rest, pcurr}, 
    f, {result, pcurr}] /; isNotTooShort[pts];

calcPoints[pts_, _, result_] := Partition[Flatten[result], 2];

isNotTooShort[pts_] := 
  Total[SquaredEuclideanDistance @@@ Partition[pts, 2, 1]] > 0.05

Graphics[{Thickness[.003], Darker[Gray], 
  tris /. triangle[pts__] :> {Line[calcPoints[{pts}, .12, {}]], 
     Line[Append[{pts}, First[{pts}]]]}}]

Answer 3

I did a very crude trial and experiment by choosing an angle, then working out the scale factor so that the squares stay touch.

Graphics@With[{data = {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {0, 0}}},   Table[Scale[     Rotate[Line[data],  30*n Degree], {0.7320508075688773^n,      0.7320508075688773^n}], {n, 0, 11}]]

Result is pretty satisfying given where I started.

Updates

Again, very crude attempt:

mydraw[repeat_: 3, angle_: 30] := Module[
    {data, x, y, scale},
    data = {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {0, 0}};
    scale = Sqrt[x^2 + y^2] /. NSolve[{x + y == 1, Tan[angle Degree] == x/y}, {x, y}, Reals][[1]];
    Graphics@Table[Scale[Rotate[Line[data], angle*n Degree], {scale^n, scale^n}], {n, 0, repeat}]
];
mydraw[]

It works for the purpose: