How to visualize the Cremona method for cardioid generation

Question

I saw this on Twitter and found the cardioid drawing quite satisfying. I don't know much mathematical background, and was wondering if I can draw this using Mathematica.

And this one apparently take $60$ points $\pmod {60}$.

With some extension:

My best attempt only goes as far as this:

Graphics[Circle[]]

I can't even produce a template (circle with 60 equal ticks on arc).

Answer 1

Using CirclePoints, Mod, Throughand Range

More than enough lines

Multicolumn@With[
  {
   n = 500,
   m = 17
   },
  Table[
   Graphics[
    {Opacity[0.1],
     Through@{Point, Line}[
         Part[CirclePoints[n], Mod[{1, k } #, n] + 1]] & /@ Range[n]
     }
    ]
   , {k, 2, m}]
  ]

Simpler

Multicolumn@With[
  {
   n = 100,
   m = 7
   },
  Table[
   Graphics[
    Through@{Point, Line}[
        Part[CirclePoints[n], Mod[{1, k } #, n] + 1]] & /@ Range[n]
    ]
   , {k, 2, m}]
  ]

Original answer

Using NestList

Module[
 {
  n = 161,
  coord, sequence, lines
  },
 coord = N@CirclePoints[n];
 sequence = 
  NestList[{Mod[#[[1]], n] + 1, Mod[#[[2]], n] + 2} &, {1, 1}, n - 2];
 lines = Map[Part[coord, #] &, sequence];
 Graphics[
  {
   Red,
   PointSize[Medium],
   Point[coord],
   Black, Opacity[0.2],
   Map[Line, lines, 1]
   }
  ]
 ]

Answer 2

For this I like to use GraphicsComplex to be able to think about the points using their index instead of dealing with the coordinates.

Graphics[GraphicsComplex[
    CirclePoints[{1, Pi/2 + 2 Pi/60}, 60], (* careful placement of points *)
    {
       {Circle[], Point[Range[60]]}, (* background elements *)
       {Red, Line[Table[{n, Mod[2 n, 60, 1]}, {n, 60}]]} (* main lines *)
    }
]]

Answer 3

Using complex-number geometry and a sort of "converse" use of GraphicsComplex to @Brett's:

With[{n = 60, k = 2},
 With[{a = Exp[-2 Pi*I*Range[1., n]/n]},
  Graphics@GraphicsComplex[
    ReIm[I*Join[a, a^k]],
    {Circle[], Point@Range@n,
     RGBColor[0.94, 0.28, 0.68], 
     Line@Transpose@Partition[Range[2 n], n]}
    ]]
 ]

I suggest the other two images in the OP have a different number of points than 60. The Epicycloid of Cremona seems to have 150:

With[{n = 150, k = 4},
 With[{a = Exp[2 Pi*I*Range[1., n]/n]},
  Graphics@GraphicsComplex[
    ReIm[-Join[a, a^k]],
    {{Texture@ImageApply[0.7 # &, ExampleData[{"ColorTexture", "BurlOak"}]], 
      Polygon[1.1 {{-1, -1}, {1, -1}, {1, 1}, {-1, 1}}, 
       VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]},
     Circle[],
     RGBColor[0.8562395526496464, 0.8409852478244543, 0.6735037273243409],
     Point@Range@n, Line@Transpose@Partition[Range[2 n], n]}
    ]]
 ]

This approach uses twice the minimum memory needed, but the dependence on the multiplier k in the map $n \mapsto k\,n$ is reduced to the amazingly brief a^k. For instance, in Manipulate, this means the update from the kernel that is needed when k is changed can be isolated to updating the points of the GraphicsComplex (i.e., ReIm[I*Join[a, a^k]]):

SetSystemOptions["CheckMachineUnderflow" -> False]; (* For V11.3+ *)
Manipulate[
 With[{a = Exp[2 Pi*I*Range@n/n]},
  Graphics@GraphicsComplex[
    Dynamic@ReIm[I*Join[a, a^k]],
    {Thin, Circle[],
     Opacity[1/20 + 30/n], Line@Transpose@Partition[Range[2 n], n]}
    ]],
 {k, 2, 10, 1},
 {n, 60, 6000, 1}
 ]

I turn off checking machine underflow, because a change in V11.3 means a warning message is emitted that makes Manipulate red faced with anger. This happens sometimes when the real or imaginary part (nearly) vanishes. It doesn't even take very large or very small inputs for this to happen. For example:

SetSystemOptions["CheckMachineUnderflow" -> True]; (* default setting *)
Exp[2 Pi*I/10.]^5

Update: Labelling points

Use Text. Its syntax (specifically the offset parameter) does not play well with GraphicsComplex, and the easiest way to get the offsets is to recompute the real and imaginary parts of a:

With[{n = 60, k = 2},
 With[{a = Exp[-2 Pi*I*Range[1., n]/n]},
  Graphics@GraphicsComplex[
    ReIm[I*Join[a, a^k]],
    {Circle[], Point@Range@n, 
     MapThread[Text[#, #, #2] &, {Range@n, ReIm[-1.5 I*a]}],
     RGBColor[0.94, 0.28, 0.68], 
     Line@Transpose@Partition[Range[2 n], n]}
    ]]
 ]

Answer 4

I may even add this to How do I draw a pair of buttocks?:

Graphics[Line /@ Table[{AngleVector[Pi n/60], AngleVector[Pi 3 n/60]}, {n, 0, 59}]]

Answer 5

I experimented with epicycloid envelopes a really long time ago; checking the file I got the basis of my code from shows that this was first done around version 4.

Since we are now in modern times, I have slightly modernized and compacted the code a bit, and then added it into a nice little Manipulate[] (which wasn't around during the time of version 4):

Manipulate[Graphics[{ColorData["Legacy", "Eggshell"], 
                     Table[Line[ReIm[Exp[I u {1, n + 1}]]],
                           {u, 0, 2 π Denominator[n], 2 π Denominator[n]/(m - 1)}]}, 
                    Background -> ColorData["Legacy", "VanDykeBrown"], 
                    Epilog -> {ColorData["Legacy", "Eggshell"], Circle[]}, 
                    PlotLabel -> Row[{"n = ", n}]],
           {{n, 1}, 1/12, 6, 1/12}, {{m, 61, "# of lines"}, 11, 501}]

Another striking example:

Answer 6

Manipulate[
 With[{f = ReIm[-I (-1.)^(2/n #)] &}, 
  Graphics[{Circle[], 
    Table[{Circle[#, .015], Text[Style[If[Mod[i, 10] == 0, i, ""], 14], 1.1 #]} & @ f@i, 
      {i, 0, n - 1}], Magenta, Arrow@Table[f@{i, k i}, {i, x - 1}]}]],
 {n, 60, 200, 10}, {x, 1, n, 1}, {k, 2, 9, 1}]

The following picture generated with Mathematica and POV-Ray