Htydjtk

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