# Producing a particular integer sequence

Posted 9 years ago
3806 Views
|
11 Replies
|
2 Total Likes
|
 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!
11 Replies
Sort By:
Posted 9 years ago
 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} 
Posted 9 years ago
 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 
Posted 9 years ago
 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} 
Posted 9 years ago
 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} 
Posted 9 years ago
 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.
Posted 9 years ago
 The relevant sequence is beautiful under ListPlot
Posted 9 years ago
 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?
Posted 9 years ago
 Thank you so much! Exactly what I was looking for.
Posted 9 years ago
 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.
Posted 9 years ago
 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.
Posted 9 years ago
 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