How to visualize the Cremona method for cardioid generation

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).

• I'll suggest looking at CirclePoints and GraphicsComplex which lead to a very simple implementation to get the main shape. It's a bit more work to get the labels if you want them. Jul 10, 2018 at 18:51
• I'll just leave this here. Here is the link to the code on reddit. Jul 10, 2018 at 19:49
• Related: Plotting an epicycloid. The cardioid is the special case of an epicycloid where the radius of both the circles is the same. Also related: Animation with Cardano circles. A Cardano circle is the corresponding special case of a hypocycloid where both the circles have the same radius. Jul 10, 2018 at 20:38

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


• Thanks for another great answer. How can I actually label the points on the circle , like 1,2,3,...60 in the OP? I don't think Tick or FrameTick is the option. Jul 10, 2018 at 22:59
• @ChenStatsYu See the updated answer. Jul 10, 2018 at 23:11
• Thanks. I have also just spotted the mistake in the picture too. n can not be 60 (mod 60). It must have been some larger values like you suggested! Jul 10, 2018 at 23:32

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


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


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


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


• To get the same figure as in the OP, change the number of points from 59 to 119. The second figure is obtained by changing 3n to 4n, and changing the number of points to 239. Etc. Jul 10, 2018 at 18:54
• This isn't quite the same graphic. Jul 10, 2018 at 19:08
• @BrettChampion This is half the Nephroid. As I mentioned in the comment above, to get the full figure one has to change 59 to 119. To get the first image in the OP, one has to change 3n to 2n. Using other values such as 5n or 7n, one gets other similar figures. Jul 10, 2018 at 19:10
• AngleVector ? - Ah, new since 10.1 - Nice. Jul 15, 2018 at 7:13

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:

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