How can I plot a Farey diagram? Planned maintenance scheduled April 17/18, 2019 at 00:00UTC (8:00pm US/Eastern) Announcing the arrival of Valued Associate #679: Cesar Manara Unicorn Meta Zoo #1: Why another podcast?How to make this beautiful animationPlotting an epicycloidGenerating a topological space diagram for an n-element setMathematica code for Bifurcation DiagramHow to draw a contour diagram in Mathematica?How to draw timing diagram from a list of values?Expressing a series formulaBifurcation diagram for Piecewise functionHow to draw a clock-diagram?How can I plot a space time diagram in mathematica?Plotting classical polymer modelA problem in bifurcation diagram
If Jon Snow became King of the Seven Kingdoms what would his regnal number be?
Why does Python start at index 1 when iterating an array backwards?
If a contract sometimes uses the wrong name, is it still valid?
Why don't the Weasley twins use magic outside of school if the Trace can only find the location of spells cast?
Withdrew £2800, but only £2000 shows as withdrawn on online banking; what are my obligations?
Should gear shift center itself while in neutral?
List *all* the tuples!
Do I really need recursive chmod to restrict access to a folder?
Letter Boxed validator
What's the purpose of writing one's academic bio in 3rd person?
Gastric acid as a weapon
Doubts about chords
Stars Make Stars
Single word antonym of "flightless"
How discoverable are IPv6 addresses and AAAA names by potential attackers?
How does cp -a work
Are my PIs rude or am I just being too sensitive?
Java 8 stream max() function argument type Comparator vs Comparable
Why are there no cargo aircraft with "flying wing" design?
I am not a queen, who am I?
Does surprise arrest existing movement?
The logistics of corpse disposal
Why was the term "discrete" used in discrete logarithm?
Should I call the interviewer directly, if HR aren't responding?
How can I plot a Farey diagram?
Planned maintenance scheduled April 17/18, 2019 at 00:00UTC (8:00pm US/Eastern)
Announcing the arrival of Valued Associate #679: Cesar Manara
Unicorn Meta Zoo #1: Why another podcast?How to make this beautiful animationPlotting an epicycloidGenerating a topological space diagram for an n-element setMathematica code for Bifurcation DiagramHow to draw a contour diagram in Mathematica?How to draw timing diagram from a list of values?Expressing a series formulaBifurcation diagram for Piecewise functionHow to draw a clock-diagram?How can I plot a space time diagram in mathematica?Plotting classical polymer modelA problem in bifurcation diagram
$begingroup$
How can I plot the following diagram for a Farey series?
graphics number-theory
$endgroup$
|
show 1 more comment
$begingroup$
How can I plot the following diagram for a Farey series?
graphics number-theory
$endgroup$
$begingroup$
From the beautiful book A. Hatcher Topology of numbers
$endgroup$
– G. R.
Apr 8 at 21:16
2
$begingroup$
Could you perhaps expand a bit on how the curves are calculated etc?
$endgroup$
– MarcoB
Apr 8 at 21:40
1
$begingroup$
pi.math.cornell.edu/~hatcher/TN/TNch1.pdf
$endgroup$
– Moo
Apr 8 at 23:17
1
$begingroup$
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.
$endgroup$
– Michael E2
Apr 9 at 17:44
$begingroup$
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.
$endgroup$
– rhermans
Apr 11 at 9:18
|
show 1 more comment
$begingroup$
How can I plot the following diagram for a Farey series?
graphics number-theory
$endgroup$
How can I plot the following diagram for a Farey series?
graphics number-theory
graphics number-theory
edited Apr 9 at 3:01
Michael E2
151k12203482
151k12203482
asked Apr 8 at 21:12
G. R.G. R.
293
293
$begingroup$
From the beautiful book A. Hatcher Topology of numbers
$endgroup$
– G. R.
Apr 8 at 21:16
2
$begingroup$
Could you perhaps expand a bit on how the curves are calculated etc?
$endgroup$
– MarcoB
Apr 8 at 21:40
1
$begingroup$
pi.math.cornell.edu/~hatcher/TN/TNch1.pdf
$endgroup$
– Moo
Apr 8 at 23:17
1
$begingroup$
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.
$endgroup$
– Michael E2
Apr 9 at 17:44
$begingroup$
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.
$endgroup$
– rhermans
Apr 11 at 9:18
|
show 1 more comment
$begingroup$
From the beautiful book A. Hatcher Topology of numbers
$endgroup$
– G. R.
Apr 8 at 21:16
2
$begingroup$
Could you perhaps expand a bit on how the curves are calculated etc?
$endgroup$
– MarcoB
Apr 8 at 21:40
1
$begingroup$
pi.math.cornell.edu/~hatcher/TN/TNch1.pdf
$endgroup$
– Moo
Apr 8 at 23:17
1
$begingroup$
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.
$endgroup$
– Michael E2
Apr 9 at 17:44
$begingroup$
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.
$endgroup$
– rhermans
Apr 11 at 9:18
$begingroup$
From the beautiful book A. Hatcher Topology of numbers
$endgroup$
– G. R.
Apr 8 at 21:16
$begingroup$
From the beautiful book A. Hatcher Topology of numbers
$endgroup$
– G. R.
Apr 8 at 21:16
2
2
$begingroup$
Could you perhaps expand a bit on how the curves are calculated etc?
$endgroup$
– MarcoB
Apr 8 at 21:40
$begingroup$
Could you perhaps expand a bit on how the curves are calculated etc?
$endgroup$
– MarcoB
Apr 8 at 21:40
1
1
$begingroup$
pi.math.cornell.edu/~hatcher/TN/TNch1.pdf
$endgroup$
– Moo
Apr 8 at 23:17
$begingroup$
pi.math.cornell.edu/~hatcher/TN/TNch1.pdf
$endgroup$
– Moo
Apr 8 at 23:17
1
1
$begingroup$
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.
$endgroup$
– Michael E2
Apr 9 at 17:44
$begingroup$
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.
$endgroup$
– Michael E2
Apr 9 at 17:44
$begingroup$
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.
$endgroup$
– rhermans
Apr 11 at 9:18
$begingroup$
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.
$endgroup$
– rhermans
Apr 11 at 9:18
|
show 1 more comment
3 Answers
3
active
oldest
votes
$begingroup$
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
]
$endgroup$
add a comment |
$begingroup$
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]]
$endgroup$
add a comment |
$begingroup$
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.
$endgroup$
$begingroup$
Thanks to C.E., it is a concrete answer
$endgroup$
– G. R.
Apr 9 at 12:58
add a comment |
Your Answer
StackExchange.ready(function()
var channelOptions =
tags: "".split(" "),
id: "387"
;
initTagRenderer("".split(" "), "".split(" "), channelOptions);
StackExchange.using("externalEditor", function()
// Have to fire editor after snippets, if snippets enabled
if (StackExchange.settings.snippets.snippetsEnabled)
StackExchange.using("snippets", function()
createEditor();
);
else
createEditor();
);
function createEditor()
StackExchange.prepareEditor(
heartbeatType: 'answer',
autoActivateHeartbeat: false,
convertImagesToLinks: false,
noModals: true,
showLowRepImageUploadWarning: true,
reputationToPostImages: null,
bindNavPrevention: true,
postfix: "",
imageUploader:
brandingHtml: "Powered by u003ca class="icon-imgur-white" href="https://imgur.com/"u003eu003c/au003e",
contentPolicyHtml: "User contributions licensed under u003ca href="https://creativecommons.org/licenses/by-sa/3.0/"u003ecc by-sa 3.0 with attribution requiredu003c/au003e u003ca href="https://stackoverflow.com/legal/content-policy"u003e(content policy)u003c/au003e",
allowUrls: true
,
onDemand: true,
discardSelector: ".discard-answer"
,immediatelyShowMarkdownHelp:true
);
);
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function ()
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fmathematica.stackexchange.com%2fquestions%2f194838%2fhow-can-i-plot-a-farey-diagram%23new-answer', 'question_page');
);
Post as a guest
Required, but never shown
3 Answers
3
active
oldest
votes
3 Answers
3
active
oldest
votes
active
oldest
votes
active
oldest
votes
$begingroup$
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
]
$endgroup$
add a comment |
$begingroup$
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
]
$endgroup$
add a comment |
$begingroup$
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
]
$endgroup$
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
]
edited Apr 9 at 6:50
answered Apr 9 at 3:27
C. E.C. E.
51.2k3101207
51.2k3101207
add a comment |
add a comment |
$begingroup$
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]]
$endgroup$
add a comment |
$begingroup$
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]]
$endgroup$
add a comment |
$begingroup$
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]]
$endgroup$
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]]
edited Apr 9 at 16:08
answered Apr 9 at 15:53
halmirhalmir
10.7k2544
10.7k2544
add a comment |
add a comment |
$begingroup$
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.
$endgroup$
$begingroup$
Thanks to C.E., it is a concrete answer
$endgroup$
– G. R.
Apr 9 at 12:58
add a comment |
$begingroup$
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.
$endgroup$
$begingroup$
Thanks to C.E., it is a concrete answer
$endgroup$
– G. R.
Apr 9 at 12:58
add a comment |
$begingroup$
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.
$endgroup$
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.
answered Apr 8 at 21:59
MarcoBMarcoB
38.8k557116
38.8k557116
$begingroup$
Thanks to C.E., it is a concrete answer
$endgroup$
– G. R.
Apr 9 at 12:58
add a comment |
$begingroup$
Thanks to C.E., it is a concrete answer
$endgroup$
– G. R.
Apr 9 at 12:58
$begingroup$
Thanks to C.E., it is a concrete answer
$endgroup$
– G. R.
Apr 9 at 12:58
$begingroup$
Thanks to C.E., it is a concrete answer
$endgroup$
– G. R.
Apr 9 at 12:58
add a comment |
Thanks for contributing an answer to Mathematica Stack Exchange!
- Please be sure to answer the question. Provide details and share your research!
But avoid …
- Asking for help, clarification, or responding to other answers.
- Making statements based on opinion; back them up with references or personal experience.
Use MathJax to format equations. MathJax reference.
To learn more, see our tips on writing great answers.
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function ()
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fmathematica.stackexchange.com%2fquestions%2f194838%2fhow-can-i-plot-a-farey-diagram%23new-answer', 'question_page');
);
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
$begingroup$
From the beautiful book A. Hatcher Topology of numbers
$endgroup$
– G. R.
Apr 8 at 21:16
2
$begingroup$
Could you perhaps expand a bit on how the curves are calculated etc?
$endgroup$
– MarcoB
Apr 8 at 21:40
1
$begingroup$
pi.math.cornell.edu/~hatcher/TN/TNch1.pdf
$endgroup$
– Moo
Apr 8 at 23:17
1
$begingroup$
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.
$endgroup$
– Michael E2
Apr 9 at 17:44
$begingroup$
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.
$endgroup$
– rhermans
Apr 11 at 9:18