4
$\begingroup$

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.

enter image description here

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}]}]]

enter image description here

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. enter image description here enter image description here

$\endgroup$
  • $\begingroup$ related: Is it possible to draw this figure using Mathematica?. $\endgroup$ – AccidentalFourierTransform Jul 12 '18 at 21:42
  • $\begingroup$ @AccidentalFourierTransform Aha, so satifying to look at and what a temptation to try this! I don't think pursuit curve is the only thing I will be pursuing now! Thanks. $\endgroup$ – Chen Stats Yu Jul 12 '18 at 21:51
  • $\begingroup$ I don't quite get the difference between this and the Q&A you linked. The figures in both seem similar and have a similar variety. Is it just that you want to reproduce these specific images? $\endgroup$ – Michael E2 Jul 12 '18 at 22:40
  • $\begingroup$ @MichaelE2 Yes and no. Sorry about the confusion. I was looking at the Pursuit curves and then I found the images above. Now I realised from the answers posted, the images are not exactly pursuit curves if I understood it correctly. Being able to produce any images of such type is quite satisfying. $\endgroup$ – Chen Stats Yu Jul 12 '18 at 22:44
4
$\begingroup$

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]

enter image description here

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]

enter image description here

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]

enter image description here

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]

enter image description here

Tweaking the parameters and using black lines, we get

enter image description here

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

enter image description here

while the rest of figures are left to the reader.

$\endgroup$
  • $\begingroup$ I don't think it's quite the same as the square I was looking at. It was just a simple rotation with a corresponding scale factor. In your graph, one of the vertices stays. Am I right? $\endgroup$ – Chen Stats Yu Jul 12 '18 at 22:07
  • $\begingroup$ But both are very beautiful shapes! $\endgroup$ – Chen Stats Yu Jul 12 '18 at 22:07
  • $\begingroup$ I think my title was misleading now. The square I was looking at is NOT a pursuit curve... $\endgroup$ – Chen Stats Yu Jul 12 '18 at 22:09
7
$\begingroup$

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

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.

enter image description here

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}]]]}}]

Mathematica graphics

$\endgroup$
  • $\begingroup$ Never came cross my mind the search for “line pattern”. Thanks. I will take a look! $\endgroup$ – Chen Stats Yu Jul 12 '18 at 20:38
  • $\begingroup$ That's completely my fault. I guess I didn't want a difficult title and decided to simply call it line patterns. $\endgroup$ – halirutan Jul 12 '18 at 20:56
  • $\begingroup$ Hahahah maybe just “add” the proper fancy name to it too $\endgroup$ – Chen Stats Yu Jul 12 '18 at 21:04
2
$\begingroup$

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.

enter image description here

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:

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.