A206330 Numbers that match polynomials irreducible over the integers.

3, 4, 5, 6, 9, 10, 17, 18, 19, 20, 21, 22, 29, 30, 33, 34, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 53, 54, 55, 56, 57, 58, 59, 60, 69, 70, 73, 74, 77, 78, 81, 82, 83, 84, 87, 88, 97, 98, 101, 102, 105, 106, 109, 110, 113, 114, 117, 118, 119, 120, 123

Offset: 1

Author

Clark Kimberling, Feb 06 2012

Keywords

• nonn

Comments

Each n>1 matches a polynomial having integer coefficients

determined by the prime factorization of n. Let c be a

positive integer, and write

c=p(1)^e(1) * p(2)^e(2) * ... * p(k)^e(k), and

define p(n,x) = e(1) + e(2)x + e(3)x^2 + ... + e(k)x^k.

If c/d is a rational number with GCD(c,d)=1, define

Q(c/d,x)=p(c,x)-p(d,x). Let c(n)/d(n) be the n-th

positive rational number given by the canonical

bijection; i.e., c(n)=A038568(n)/A038569(n).

Define P(0,x)=1 and P(n,x)=Q(c(n)/d(n),x). Polynomials

having nonnegative integer coefficients are matched to

the nonnegative integers as follows:

...

n .... P[n,x] .. irreducible

0 .... 0 ....... no

1 ... -1 ....... no

2 .... 1 ....... no

3 ... -x ....... yes

4 .... x ....... yes

5 ... 1-x ...... yes

6 .. -1+x ...... yes

7 .. -2 ........ no

8 ... 2 ........ no

9 .. -2+x ...... yes

10 .. 2-x ...... yes

Examples

			In the table under Comments, read "yes" for n=3,4,5,6,9,10.
		

Crossrefs

Cf. A206284 (polynomials over the positive integers),

A206331 (complement of A206330).

Programs

Mathematica

b[n_] := Table[x^k, {k, 0, n}];
f[n_] := f[n] = FactorInteger[n]; z = 1000;
t[n_, m_, k_] := If[PrimeQ[f[n][[m, 1]]] && f[n][[m, 1]]
 == Prime[k], f[n][[m, 2]], 0];
u = Table[Apply[Plus,
    Table[Table[t[n, m, k], {k, 1, PrimePi[n]}], {m, 1,
      Length[f[n]]}]], {n, 1, z}];
c[n_] := Module[{s = 1, k = 2, j = 1},
   While[s <= n, s = s + 2*EulerPhi[k]; k = k + 1];
   s = s - 2*EulerPhi[k - 1];
   While[s <= n, If[GCD[j, k - 1]
      == 1, s = s + 2]; j = j + 1];
   If[s > n + 1, j - 1, k - 1]];
d[n_] := Module[{s = 1, k = 2, j = 1},
   While[s <= n, s = s + 2*EulerPhi[k]; k = k + 1];
   s = s - 2*EulerPhi[k - 1];
   While[s <= n, If[GCD[j, k - 1]
      == 1, s = s + 2]; j = j + 1];
   If[s > n + 1, k - 1, j - 1]];
P[n_, x_] :=
 u[[c[n]]].b[-1 + Length[u[[c[n]]]]] -
  u[[d[n]]].b[-1 + Length[u[[d[n]]]]]
TableForm[Table[{n, P[n, x], Factor[P[n, x]]},
   {n, 1, z/4}]];
v = {}; Do[n++;
 If[IrreduciblePolynomialQ[P[n, x]], AppendTo[v, n]], {n, z/2}]
v                            (* A206330 *)
Complement[Range[0,200], v]  (* A206331 *)