Ygtjki

How can I plot the following diagram for a Farey series?

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[2],
 hypocycloid[4],
 hypocycloid[8],
 hypocycloid[16],
 hypocycloid[32],
 hypocycloid[64],
 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[2],
 hypocycloid[4],
 hypocycloid[8],
 hypocycloid[16],
 hypocycloid[32],
 hypocycloid[64],
 Graphics@MapThread[Text, labels, coords],
 ImageSize -> 500
 ]

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[5]

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.

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[[1]], 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[1]
 ];
 Graph[vert, edges, nopts, VertexCoordinates->CirclePoints[1,0,Length[vert]], VertexLabels->labels, 
 EdgeShapeFunction->(BSplineCurve[#1[[1]],0,0,#1[[2]], SplineWeights->2,EuclideanDistance@@#,2]&), 
 PerformanceGoal->"Speed", Epilog->dstyle, Circle[], VertexShapeFunction -> "Point", EdgeStyle -> edgestyle, VertexStyle -> dstyle]
 ]

Example:

FareyDiagram[4]

FareyDiagram[6, 4, ColorFunction -> Hue, 
 VertexLabelStyle -> Darker[Red]]