Can someone tell me how to produce the series defined by the number of unique elements a/b, where abs(a)<=n and abs(b)<=n. So
n=1 -> 3 (-1, 0 and 1)
n=2 -> 7 (-2, -1, -1/2, 0, 1/2, 1, 2)
n=3 -> 15
n=4 -> 23
etc..Thanks a lot!
Without any reasoning it’s just
In[6]:= Clear[sparK]
sparK[n_Integer?Positive] := Union[Flatten[Table[o/oo, {o, -n, n}, {oo, 1, n}]]]
In[11]:= sparK[3]
Out[11]= {-3, -2, -(3/2), -1, -(2/3), -(1/2), -(1/3), 0, 1/3, 1/2, 2/3, 1, 3/2, 2, 3}
In[12]:= sparK[3] // Length
Out[12]= 15
In[13]:= sparK[4]
Out[13]= {-4, -3, -2, -(3/2), -(4/3), -1, -(3/4), -(2/3), -(1/2), -(1/3), -(1/4), 0, 1/4, 1/3, 1/2, 2/3, 3/4, 1, 4/3, 3/2, 2, 3, 4}
In[14]:= sparK[4] // Length
Out[14]= 23
Thank you so much! Exactly what I was looking for.
A bit more efficient
In[6]:= Clear[sparK2]
sparK2[n_Integer?Positive] := Join[-Reverse[#], {0}, #]&[Union[Flatten[Table[o/oo, {o, 1, n}, {oo, 1, n}]]]]
In[12]:= sparK[10] == sparK2[10]
Out[12]= True
In[14]:= sparK2[10] // Length
Out[14]= 127
it sorts less and has from the beginning only one zero.
get rid of the Sort
Clear[sparK3]
sparK3[n_Integer?Positive] := Join[-Reverse[#], {0}, #]&[Union[Flatten[Table[o/oo, {o, 1, n}, {oo, n, 1, -1}]]]]
Union sorts by itself if it gets excatly one list, so this is essentially sparK2 revisited because it still contains duplicates - that’s why Union must applied.
P.S.: I removed the Sort over an Union in the previous posts too.
Observe the following for the interesting part bigger than 0
In[182]:= sparK3[17][[193 ;; 383]]
Out[182]= {1/17, 1/16, 1/15, 1/14, 1/13, 1/12, 1/11, 1/10, 1/9, 2/17, \
1/8, 2/15, 1/7, 2/13, 1/6, 3/17, 2/11, 3/16, 1/5, 3/14, 2/9, 3/13, \
4/17, 1/4, 4/15, 3/11, 2/7, 5/17, 3/10, 4/13, 5/16, 1/3, 6/17, 5/14, \
4/11, 3/8, 5/13, 2/5, 7/17, 5/12, 3/7, 7/16, 4/9, 5/11, 6/13, 7/15, \
8/17, 1/2, 9/17, 8/15, 7/13, 6/11, 5/9, 9/16, 4/7, 7/12, 10/17, 3/5, \
8/13, 5/8, 7/11, 9/14, 11/17, 2/3, 11/16, 9/13, 7/10, 12/17, 5/7, \
8/11, 11/15, 3/4, 13/17, 10/13, 7/9, 11/14, 4/5, 13/16, 9/11, 14/17, \
5/6, 11/13, 6/7, 13/15, 7/8, 15/17, 8/9, 9/10, 10/11, 11/12, 12/13, \
13/14, 14/15, 15/16, 16/17, 1, 17/16, 16/15, 15/14, 14/13, 13/12, \
12/11, 11/10, 10/9, 9/8, 17/15, 8/7, 15/13, 7/6, 13/11, 6/5, 17/14, \
11/9, 16/13, 5/4, 14/11, 9/7, 13/10, 17/13, 4/3, 15/11, 11/8, 7/5, \
17/12, 10/7, 13/9, 16/11, 3/2, 17/11, 14/9, 11/7, 8/5, 13/8, 5/3, \
17/10, 12/7, 7/4, 16/9, 9/5, 11/6, 13/7, 15/8, 17/9, 2, 17/8, 15/7, \
13/6, 11/5, 9/4, 16/7, 7/3, 12/5, 17/7, 5/2, 13/5, 8/3, 11/4, 14/5, \
17/6, 3, 16/5, 13/4, 10/3, 17/5, 7/2, 11/3, 15/4, 4, 17/4, 13/3, 9/2, \
14/3, 5, 16/3, 11/2, 17/3, 6, 13/2, 7, 15/2, 8, 17/2, 9, 10, 11, 12, \
13, 14, 15, 16, 17}
In[183]:= Clear[x]
x = (sparK3[17][[193 ;; 383]]) /. {x_Integer -> {x, 1},
x_Rational :> {Numerator[x], Denominator[x]}}
Out[184]= {{1, 17}, {1, 16}, {1, 15}, {1, 14}, {1, 13}, {1, 12}, {1,
11}, {1, 10}, {1, 9}, {2, 17}, {1, 8}, {2, 15}, {1, 7}, {2, 13}, {1,
6}, {3, 17}, {2, 11}, {3, 16}, {1, 5}, {3, 14}, {2, 9}, {3,
13}, {4, 17}, {1, 4}, {4, 15}, {3, 11}, {2, 7}, {5, 17}, {3,
10}, {4, 13}, {5, 16}, {1, 3}, {6, 17}, {5, 14}, {4, 11}, {3,
8}, {5, 13}, {2, 5}, {7, 17}, {5, 12}, {3, 7}, {7, 16}, {4, 9}, {5,
11}, {6, 13}, {7, 15}, {8, 17}, {1, 2}, {9, 17}, {8, 15}, {7,
13}, {6, 11}, {5, 9}, {9, 16}, {4, 7}, {7, 12}, {10, 17}, {3,
5}, {8, 13}, {5, 8}, {7, 11}, {9, 14}, {11, 17}, {2, 3}, {11,
16}, {9, 13}, {7, 10}, {12, 17}, {5, 7}, {8, 11}, {11, 15}, {3,
4}, {13, 17}, {10, 13}, {7, 9}, {11, 14}, {4, 5}, {13, 16}, {9,
11}, {14, 17}, {5, 6}, {11, 13}, {6, 7}, {13, 15}, {7, 8}, {15,
17}, {8, 9}, {9, 10}, {10, 11}, {11, 12}, {12, 13}, {13, 14}, {14,
15}, {15, 16}, {16, 17}, {1, 1}, {17, 16}, {16, 15}, {15, 14}, {14,
13}, {13, 12}, {12, 11}, {11, 10}, {10, 9}, {9, 8}, {17, 15}, {8,
7}, {15, 13}, {7, 6}, {13, 11}, {6, 5}, {17, 14}, {11, 9}, {16,
13}, {5, 4}, {14, 11}, {9, 7}, {13, 10}, {17, 13}, {4, 3}, {15,
11}, {11, 8}, {7, 5}, {17, 12}, {10, 7}, {13, 9}, {16, 11}, {3,
2}, {17, 11}, {14, 9}, {11, 7}, {8, 5}, {13, 8}, {5, 3}, {17,
10}, {12, 7}, {7, 4}, {16, 9}, {9, 5}, {11, 6}, {13, 7}, {15,
8}, {17, 9}, {2, 1}, {17, 8}, {15, 7}, {13, 6}, {11, 5}, {9,
4}, {16, 7}, {7, 3}, {12, 5}, {17, 7}, {5, 2}, {13, 5}, {8, 3}, {11,
4}, {14, 5}, {17, 6}, {3, 1}, {16, 5}, {13, 4}, {10, 3}, {17,
5}, {7, 2}, {11, 3}, {15, 4}, {4, 1}, {17, 4}, {13, 3}, {9, 2}, {14,
3}, {5, 1}, {16, 3}, {11, 2}, {17, 3}, {6, 1}, {13, 2}, {7,
1}, {15, 2}, {8, 1}, {17, 2}, {9, 1}, {10, 1}, {11, 1}, {12,
1}, {13, 1}, {14, 1}, {15, 1}, {16, 1}, {17, 1}}
In[190]:= Transpose[x][[1]] == Reverse[Transpose[x][[2]]]
Out[190]= True
the numerators consist of the same list as the reversed denominators: a symmetry between numerators and denominators. In fact one needs only to generate one list, let’s say the numerators
In[191]:= x1 = Transpose[x][[1]]
Out[191]= {1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 2, 1, 2, 1, 3, 2, 3, 1, \
3, 2, 3, 4, 1, 4, 3, 2, 5, 3, 4, 5, 1, 6, 5, 4, 3, 5, 2, 7, 5, 3, 7, \
4, 5, 6, 7, 8, 1, 9, 8, 7, 6, 5, 9, 4, 7, 10, 3, 8, 5, 7, 9, 11, 2, \
11, 9, 7, 12, 5, 8, 11, 3, 13, 10, 7, 11, 4, 13, 9, 14, 5, 11, 6, 13, \
7, 15, 8, 9, 10, 11, 12, 13, 14, 15, 16, 1, 17, 16, 15, 14, 13, 12, \
11, 10, 9, 17, 8, 15, 7, 13, 6, 17, 11, 16, 5, 14, 9, 13, 17, 4, 15, \
11, 7, 17, 10, 13, 16, 3, 17, 14, 11, 8, 13, 5, 17, 12, 7, 16, 9, 11, \
13, 15, 17, 2, 17, 15, 13, 11, 9, 16, 7, 12, 17, 5, 13, 8, 11, 14, \
17, 3, 16, 13, 10, 17, 7, 11, 15, 4, 17, 13, 9, 14, 5, 16, 11, 17, 6, \
13, 7, 15, 8, 17, 9, 10, 11, 12, 13, 14, 15, 16, 17}
then
In[192]:= sparK3[17] == Join[-Reverse[#], {0}, #]&[x1/Reverse[x1]]
Out[192]= True
that’s really short … but how to generate the list of numerators x1 for a given positive n?
The sequence relates to this series (well after transformation 2k-1)
There is also some mathematica code there, but I wanted a simple formulation, without relying on the totient function.
The relevant sequence is beautiful under ListPlot
![sparK3[100] relevant sequence](/c/portal/getImageAttachment?filename=comm382040.PNG&userId=28832)
One function that is very much related is
FareySequence
The Farey sequence of order n is the sorted sequence of completely reduced fractions between 0 and 1 with denominators not exceeding n.
As an example:
FareySequence[7]
{0,1/5,1/4,1/3,2/5,1/2,3/5,2/3,3/4,4/5,1}
So I think you want something like this:
spark[n_] := Union[Times @@@ Tuples[{FareySequence[n], Range[-n, n]}]]
spark[1]
spark[2]
spark[3]
spark[4]
Giving:
{-1, 0, 1}
{-2, -1, -(1/2), 0, 1/2, 1, 2}
{-3, -2, -(3/2), -(4/3), -1, -(2/3), -(1/2), -(1/3), 0, 1/3, 1/2, 2/3, 1, 4/3, 3/2, 2, 3}
{-4, -3, -(8/3), -(9/4), -2, -(3/2), -(4/3), -1, -(3/4), -(2/3), -(1/2), -(1/3), -(1/4), 0, 1/4, 1/3, 1/2, 2/3, 3/4, 1, 4/3, 3/2, 2, 9/4, 8/3, 3, 4}
The problem owner wishes a sequence which has for n=4 length 23
In[51]:= (* Huisman *)
Clear[sparK5]
sparK5[n_] := Union[Times @@@ Tuples[{FareySequence[n], Range[-n, n]}]]
In[53]:= Length[sparK5[4]]
Out[53]= 27
9/4 and 8/3 do not meet the conditions.
Here is another implementation, it’s so slow (despite the fact it computes exactly the minimal set of numbers), but works
In[27]:= Clear[sparK4]
sparK4[n_Integer] := Block[{nume = Range[n], deno = Table[n, {n}], r = {}, x, r0 = 0},
While[r0 < 1,
x = nume/deno;
r0 = Min[x];
r = Join[r, {r0}];
deno -= Table[If[MemberQ[Flatten[Position[x, r0]], o], 1, 0], {o, 1, n}];
];
r = Join[First[#], {1}, Last[#]]&[Transpose[Most[r] /. {y_Integer -> {y, 1}, y_Rational :> {Numerator[y], Denominator[y]}}]];
Join[-Reverse[#], {0}, #]&[r/Reverse[r]]
] /; n > 1
In[50]:= And @@ ((sparK3[#] == sparK4[#]) & /@ RandomInteger[{2, 100}, 17])
Out[50]= True
In[54]:= Length[sparK4[4]]
Out[54]= 23
O yes You are right! I oversaw something.
Here are the current list of methods with their timings:
ClearAll[spark,spark2,spark3,spark4]
spark[n_]:=Union@@Outer[Divide,Range[-n,n],Range[n]]
spark2[n_]:=Union[Catenate[Outer[Divide,Range[-n,n],Range[n]]]]
spark3[n_]:=Join[-Reverse[#],{0},#]&[Union[Flatten[Table[o/oo,{o,1,n},{oo,n,1,-1}]]]]
spark4[n_]:=Catenate[{-#,{0},#}]&[Union@@Outer[Divide,Range[n],Range[n]]]
AbsoluteTiming[spark[501];]
AbsoluteTiming[spark2[501];]
AbsoluteTiming[spark3[501];]
AbsoluteTiming[spark4[501];]
giving:
{1.309208,Null}
{1.349903,Null}
{0.844597,Null}
{0.826349,Null}
I oversaw something.
Yes, but not what you meant to have overseen, because FareySequence delivers in fact the relevant set for this job.
In[38]:= Clear[sparK6]
sparK6[n_Integer] :=
Block[{r = Join[First[#], {1}, Last[#]]&[Transpose[(FareySequence[n][[2 ;; -2]]) /. {y_Rational :> {Numerator[y], Denominator[y]}}]]},
Join[-Reverse[#], {0}, #]&[r/Reverse[r]]
] /; n > 1
In[46]:= sparK6[472] == sparK3[472]
Out[46]= True
let’s do the comparison again
In[47]:= ClearAll[spark, spark2, spark3, spark4, sparK6]
spark[n_] := Union @@ Outer[Divide, Range[-n, n], Range[n]]
spark2[n_] := Union[Catenate[Outer[Divide, Range[-n, n], Range[n]]]]
spark3[n_] := Join[-Reverse[#], {0}, #]&[Union[Flatten[Table[o/oo, {o, 1, n}, {oo, n, 1, -1}]]]]
spark4[n_] := Catenate[{-#, {0}, #}] &[Union @@ Outer[Divide, Range[n], Range[n]]]
sparK6[n_Integer] :=
Block[{r = Join[First[#], {1}, Last[#]]&[Transpose[(FareySequence[n][[2 ;; -2]]) /. {y_Rational :> {Numerator[y], Denominator[y]}}]]},
Join[-Reverse[#], {0}, #] &[r/Reverse[r]]
] /; n > 1
In[53]:= AbsoluteTiming[spark[501];]
AbsoluteTiming[spark2[501];]
AbsoluteTiming[spark3[501];]
AbsoluteTiming[spark4[501];]
AbsoluteTiming[sparK6[501];]
Out[53]= {1.528803, Null}
Out[54]= {1.544403, Null}
Out[55]= {0.904802, Null}
Out[56]= {0.936002, Null}
Out[57]= {0.312001, Null}