# How can I plot a Farey diagram?

How can I plot the following diagram for a Farey series? • From the beautiful book A. Hatcher Topology of numbers – G. R. Apr 8 at 21:16
• Could you perhaps expand a bit on how the curves are calculated etc? – MarcoB Apr 8 at 21:40
• pi.math.cornell.edu/~hatcher/TN/TNch1.pdf – Moo Apr 8 at 23:17
• Technically this is not a Farey series/sequence $F_n$ of order $n$, which is defined to be all fractions (sometimes restricted to the interval between 0 and 1) with denominator at most $n$. For example 3/8 is present but not 1/8. It's a recursive mediant subdivision. It's related in that in any three successive terms of a Farey sequence, the middle one is the mediant of the other two. – Michael E2 Apr 9 at 17:44
• If it wasn't for the very good answers you got, I would have voted to close this question as it gives no details, no definitions no code and shows no personal effort. Please, next time try asking good questions. – rhermans Apr 11 at 9:18

## 4 Answers

The curvilinear triangles which are characteristic for this type of plot are called hypocycloid curves. We can use the parametric equations on Wikipedia to plot these, like so:

x[a_, b_, t_] := (b - a) Cos[t] + a Cos[(b - a)/a t]
y[a_, b_, t_] := (b - a) Sin[t] - a Sin[(b - a)/a t]
hypocycloid[n_] := ParametricPlot[
{x[1/n, 1, t], y[1/n, 1, t]},
{t, 0, 2 Pi},
PlotStyle -> {Thickness[0.002], Black}
]

Show[
Graphics[Circle[{0, 0}, 1]],
hypocycloid,
hypocycloid,
hypocycloid,
hypocycloid,
hypocycloid,
hypocycloid,
ImageSize -> 500
] I've previously written about an application of hypocycloids here, and I showed how to visualize epicycloids here.

How to generate the labels is described here (also linked to by moo in a comment). I will simply provide the code.

mediant[{a_, b_}, {c_, d_}] := {a + c, b + d}
recursive[v1_, v2_, depth_] := If[
depth > 2,
mediant[v1, v2], {
recursive[v1, mediant[v1, v2], depth + 1],
mediant[v1, v2],
recursive[mediant[v1, v2], v2, depth + 1]
}]

computeLabels[v1_, v2_] := Module[{numbers},
numbers =
Cases[recursive[v1, v2, 0], {_Integer, _Integer}, Infinity];
StringTemplate["/"] @@@ numbers
]
computeLabelsNegative[v1_, v2_] := Module[{numbers},
numbers =
Cases[recursive[v1, v2, 0], {_Integer, _Integer}, Infinity];
StringTemplate["-2/1"] @@@ numbers
]

labels = Reverse@Join[
{"1/0"},
computeLabels[{1, 0}, {1, 1}],
{"1/1"},
computeLabels[{1, 1}, {0, 1}],
{"0/1"},
computeLabelsNegative[{1, 0}, {1, 1}],
{"-1,1"},
computeLabelsNegative[{1, 1}, {0, 1}]
];

coords = CirclePoints[{1.1, 186 Degree}, 64];

Show[
Graphics[Circle[{0, 0}, 1]],
hypocycloid,
hypocycloid,
hypocycloid,
hypocycloid,
hypocycloid,
hypocycloid,
Graphics@MapThread[Text, {labels, coords}],
ImageSize -> 500
] Using Graph with a bit of coding:

addPoint[{p : h_[a_,b_], q : h_[c_,d_]}, i_] :=
With[{np = h[a + c, b + d]}, Sow[{p \[UndirectedEdge] np, np \[UndirectedEdge] q}]; Sow[{i, i}, "Depth"]; {p, np, q}]

addPoint[{p : h_[a_,b_], q : h_[-1][c_,d_]}, i_] :=
With[{np = h[-1][a + c, b + d]}, Sow[{p \[UndirectedEdge] np, np \[UndirectedEdge] q}]; Sow[{i, i}, "Depth"]; {p, np, q}]

addPoint[{p : h_[-1][a_,b_], q : h_[c_,d_]}, i_] :=
With[{np = h[-1][a + c, b + d]}, Sow[{p \[UndirectedEdge] np, np \[UndirectedEdge] q}]; Sow[{i, i}, "Depth"]; {p, np, q}]

addPoint[{p : h_[-1][a_,b_], q : h_[-1][c_,d_]}, i_] :=
With[{np = h[-1][a + c, b + d]}, Sow[{p \[UndirectedEdge] np, np \[UndirectedEdge] q}]; Sow[{i, i}, "Depth"]; {p, np, q}]

fLabel[fr_, angle_] :=
With[{tangle=ArcTan@@angle}, Placed[fLabel[fr], AngleVector[{1/2, 1/2}, {.7, #}] & /@{tangle, tangle+Pi}]]

fLabel[h_[a_, b_]] := ToString[a] ~~ "/" ~~ ToString[b]
fLabel[h_[-1][a_, b_]] := "-" ~~ ToString[a] ~~ "/" ~~ ToString[b]

FareyDiagram[n_Integer, d_Integer: 1, opts___?OptionQ] :=
Block[{fr, top, bottom, stedges, toppart, bottompart, vert, edges, coords, labels, labpos, cfunc, i, edgestyle, dstyle, nopts},
cfunc = ColorFunction /. Flatten[{opts}] /. ColorFunction -> Automatic;
nopts = FilterRules[Flatten[{opts}], Options[Graph]];
top = {fr[0,1], fr[1,1], fr[1,0]};
bottom = {fr[1,0], fr[-1][1,1], fr[0,1]};
stedges = UndirectedEdge@@@Join[Partition[top, 2, 1], Partition[bottom, 2, 1], {{fr[0, 1],fr[1, 0]}}];
i = 0;toppart = Reap[Nest[(i++; Split[Flatten[addPoint[#, i] & /@ Partition[#, 2, 1],1]][[All,1]])&, top, n]];
i = 0;bottompart = Reap[Nest[(i++; Split[Flatten[addPoint[#, i] & /@ Partition[#,2,1],1]][[All,1]])&,bottom, n]];
vert = Join[toppart[], bottompart[[1,  2;;-2]]];
edges = Flatten[{stedges, toppart[[2, 1]], bottompart[[2, 1]]}];
coords = CirclePoints[{1,0},Length[vert]];
labpos = Range[1, Length[vert], 2 ^ (d - 1)];
labels = Thread[vert[[labpos]]->fLabel@@@Transpose[{vert,coords}][[labpos]]];
edgestyle = Black;
dstyle = Black;
If[cfunc =!= Automatic,
edgestyle = Flatten[{Table[0, Length[stedges]], toppart[[2, 2]], bottompart[[2, 2]]}];
edgestyle = edgestyle / Max[edgestyle];
edgestyle = Thread[edges -> Flatten[cfunc[1 - #] & /@ edgestyle]];
dstyle = cfunc
];
Graph[vert, edges, nopts, VertexCoordinates->CirclePoints[{1,0},Length[vert]], VertexLabels->labels,
EdgeShapeFunction->(BSplineCurve[{#1[],{0,0},#1[]}, SplineWeights->{2,EuclideanDistance@@#,2}]&),
PerformanceGoal->"Speed", Epilog->{dstyle, Circle[]}, VertexShapeFunction -> "Point", EdgeStyle -> edgestyle, VertexStyle -> dstyle]
]


Example:

FareyDiagram FareyDiagram[6, 4, ColorFunction -> Hue,
VertexLabelStyle -> Darker[Red]] I looked up the Farey sequence on Wikipedia, out of curiosity, because I had not heard of it before. The Farey sequence of order $$n$$ is "the sequence of completely reduced fractions between 0 and 1 which, when in lowest terms, have denominators less than or equal to $$n$$, arranged in order of increasing size".

On that basis, you can generate the sequence as follows, for instance:

ClearAll[farey]
farey[n_Integer] := (Divide @@@ Subsets[Range[n], {2}]) ~ Join ~ {0, 1} //DeleteDuplicates //Sort


So for instance:

farey


{0, 1/5, 1/4, 1/3, 2/5, 1/2, 3/5, 2/3, 3/4, 4/5, 1}

I am not sure how these sequences are connected with the figure you showed though.

• Thanks to C.E., it is a concrete answer – G. R. Apr 9 at 12:58
grupo[n_] := Show[{Graphics[{Thin, Red,
Circle[{0, 0}, 1, {0, Pi/2}]}]}, {Graphics[{Thin,
Map[{BSplineCurve[{#1[], {0, 0}, #1[]},
SplineWeights -> {2, EuclideanDistance @@
#,2}]}&,
Partition[ReIm[Exp[Pi/2 I #]] & /@
FareySequence[n], 2, 1]]}]}, {Map[Graphics[{Blue,
Point[{ReIm[Exp[Pi/2 I #]]}]}] &,
FareySequence[n]]}, PlotRange -> All]

Show[Table[grupo[n], {n, 2, 7}]] • the true farey diagram based on the answers given above – G. R. Apr 16 at 23:52