A366908 Lexicographically earliest infinite sequence of distinct positive integers such that, for n > 1, a(n) shares a factor with n but does not equal n, while not sharing a factor with a(n-1).
1, 4, 9, 2, 15, 8, 21, 10, 3, 5, 22, 27, 26, 7, 25, 6, 85, 12, 95, 14, 33, 16, 69, 28, 45, 13, 18, 35, 58, 39, 155, 24, 11, 17, 20, 51, 74, 19, 36, 55, 82, 49, 86, 77, 30, 23, 94, 57, 56, 65, 34, 91, 106, 63, 40, 119, 38, 29, 118, 75, 122, 31, 81, 32, 105, 44, 201, 46, 87, 50, 213, 52, 219, 37
Offset: 1
Keywords
Examples
a(4) = 2 as 2 does not equal 4, shares the factor 2 with 4 while not sharing a factor with a(3) = 9. a(15) = 25 as 25 does not equal 15, shares the factor 5 with 15 while not sharing a factor with a(14) = 7. Note that 6 is unused and satisfies these requirements but as 15 + 1 = 16 = 2^4 only contains 2 as a distinct prime factor, a(15) cannot also contain 2 as a factor else a(16) would not exist.
Links
- Scott R. Shannon, Table of n, a(n) for n = 1..10000
- Michael De Vlieger, Log log scatterplot of a(n), n = 1..2^12, showing primes in red, composite prime powers in gold, squarefree composites in green, and numbers neither squarefree nor prime powers in blue, with numbers in the last category that are squareful in light blue.
- Michael De Vlieger, List of a(n), n = 1..576, read left to right in 24 rows of 24 terms each, demonstrating the confinement of most prime a(n) to n congruent to +/- 2 (mod 12). Primes appear in red, following the color convention established immediately above.
- Scott R. Shannon, Image of the first 100000 terms. The green line is a(n) = n.
Programs
-
Mathematica
nn = 1000; c[] := False; m[] := 1; f[x_] := f[x] = Times @@ FactorInteger[x][[All, 1]]; a[1] = 1; j = a[2] = 4; c[1] = c[4] = True; u = 2; Do[k = u; If[PrimePowerQ[n], p = FactorInteger[n][[1, 1]]; k = m[p]; While[ Or[c[#], ! CoprimeQ[j, #], Divisible[#, f[n + 1]], # == n] &[k p], k++]; k *= p; While[c[p m[p]], m[p]++], While[ Or[c[k], ! CoprimeQ[j, k], CoprimeQ[k, n], Divisible[k, f[n + 1]], k == n], k++] ]; Set[{a[n], c[k], j}, {k, True, k}]; If[k == u, While[c[u], u++]], {n, 3, nn}]; Array[a, nn] (* Michael De Vlieger, Oct 29 2023 *)
Comments