How can I plot a Farey diagram?

11

3

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

enter image description here

G. R.

Posted 2019-04-08T21:12:47.890

Reputation: 129

From the beautiful book A. Hatcher Topology of numbers – G. R. – 2019-04-08T21:16:19.647

2Could you perhaps expand a bit on how the curves are calculated etc? – MarcoB – 2019-04-08T21:40:43.470

1http://pi.math.cornell.edu/~hatcher/TN/TNch1.pdf – Moo – 2019-04-08T23:17:59.977

1Technically 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 – 2019-04-09T17:44:54.723

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 – 2019-04-11T09:18:13.147

rhermans have reason. The question comes trying to construct the true diagram for the farey sequence since I got these points no symmetrically distributed around the circle Show[Graphics[{Gray, Circle[]}], {Map[ Graphics[{PointSize[Medium], Red, Point[{ReIm[Exp[Pi/2 I #]]}]}] &, FareySequence[7]]}, PlotRange -> All] – G. R. – 2019-04-15T19:41:26.307

Answers

15

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
 ]

Mathematica graphics

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
 ]

Mathematica graphics

C. E.

Posted 2019-04-08T21:12:47.890

Reputation: 67 448

9

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]

enter image description here

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

enter image description here

halmir

Posted 2019-04-08T21:12:47.890

Reputation: 12 169

4

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.

MarcoB

Posted 2019-04-08T21:12:47.890

Reputation: 53 573

Thanks to C.E., it is a concrete answer – G. R. – 2019-04-09T12:58:56.670

Built in too: FareySequence

– KennyColnago – 2020-01-10T20:24:39.650

@KennyColnago Oh man! How did I miss that?! Thank you :-) – MarcoB – 2020-01-10T22:08:46.167

3

While reading an excellent post on chord diagrams, I realized that this type of figure is a Poincaré hyperbolic disk. The lines are Poincaré arcs. There is MathWorld article with code here.

So, copying the definitions of PoincareArc and PoincareDisk from MathWorld, we can draw the figure like this:

PoincareArc[l0_List] := 
 Module[{l = Sort[l0], dt, t, t1, t2, r, R, c},
  dt = Abs[l[[1]] - l[[2]]];
  t = Plus @@ l/2;
  If[
   dt == Pi,
   Line[{
     {Cos[l[[1]]], Sin[l[[1]]]},
     {Cos[l[[2]]], Sin[l[[2]]]}
     }], c = {Cos[t], Sin[t]};
   r = Tan[dt/2];
   R = Sec[dt/2];
   t1 = ArcTan @@ ({Cos[l[[2]]], Sin[l[[2]]]} - R c);
   t2 = ArcTan @@ ({Cos[l[[1]]], Sin[l[[1]]]} - R c);
   If[t2 < t1, t2 += 2 Pi];
   Circle[R c, r, {t1, t2}]]]

PoincareDisk[l_List] := 
 Module[{i}, {{Thickness[.001], Circle[{0, 0}, 1]}, 
   Table[PoincareArc[l[[i]]], {i, Length[l]}]}]

angles[n_] := Partition[Table[th, {th, 0, 2 Pi, 2 Pi/n}], 2, 1]

Graphics[{
  PoincareDisk@angles[2],
  PoincareDisk@angles[4],
  PoincareDisk@angles[8],
  PoincareDisk@angles[16],
  PoincareDisk@angles[32],
  PoincareDisk@angles[64]
  }]

Mathematica graphics

C. E.

Posted 2019-04-08T21:12:47.890

Reputation: 67 448

3

An alternative way to use Graph: Using CycleGraphs with 2^k vertices and the internal edge shape function GraphComputation`GraphChartDump`pEdge:

Quiet[GraphComputation`GraphPropertyChart[]];
eSF = GraphComputation`GraphChartDump`pEdge[#2[[1]], blah, blah, ##] &;

Show[CycleGraph[2^#, VertexSize -> 0, EdgeShapeFunction -> eSF, 
   EdgeStyle -> Black] & /@ Range[5], Epilog -> Circle[]]

enter image description here

Alternatively, use a function to define the edge list to be used in a single Graph:

ClearAll[vPairs]
vPairs[k_Integer] := DeleteDuplicates[Join @@ 
  (Partition[Append[#, 1], 2, 1] & /@ Range[1, 2^k, 2^Range[0, k-1]])]

Graph[Range[2^k], vPairs[k], 
  EdgeStyle->Black,
  VertexShape -> Graphics[{}], 
  Epilog -> Circle[],
  EdgeShapeFunction -> eSF,
  GraphLayout -> "CircularEmbedding",
  ImageSize -> 300]

same picture

With colored edges:

Row[(colors = RotateRight @ ColorData[97, "ColorList"];
  Show[CycleGraph[2^#, VertexSize -> 0, EdgeShapeFunction -> eSF, 
         EdgeStyle -> Directive[Thick, First[colors = RotateLeft[colors]]]] & /@ Range[#], 
    Epilog -> Circle[], ImageSize -> 300]) & /@ Range[2, 5]]

enter image description here

kglr

Posted 2019-04-08T21:12:47.890

Reputation: 302 076

1

grupo[n_] := Show[{Graphics[{Thin, Red, 
Circle[{0, 0}, 1, {0, Pi/2}]}]}, {Graphics[{Thin, 
Map[{BSplineCurve[{#1[[1]], {0, 0}, #1[[2]]}, 
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}]]

enter image description here

G. R.

Posted 2019-04-08T21:12:47.890

Reputation: 129

the true farey diagram based on the answers given above – G. R. – 2019-04-16T23:52:23.843