cp's OEIS Frontend

A206330 Numbers that match polynomials irreducible over the integers.

%I A206330 #7 Jul 12 2012 00:40:00
%S A206330 3,4,5,6,9,10,17,18,19,20,21,22,29,30,33,34,37,38,39,40,41,42,43,44,
%T A206330 45,46,47,48,53,54,55,56,57,58,59,60,69,70,73,74,77,78,81,82,83,84,87,
%U A206330 88,97,98,101,102,105,106,109,110,113,114,117,118,119,120,123
%N A206330 Numbers that match polynomials irreducible over the integers.
%C A206330 Each n>1 matches a polynomial having integer coefficients
%C A206330 determined by the prime factorization of n.  Let c be a
%C A206330 positive integer, and write
%C A206330 c=p(1)^e(1) * p(2)^e(2) * ... * p(k)^e(k), and
%C A206330 define p(n,x) = e(1) + e(2)x + e(3)x^2 + ... + e(k)x^k.
%C A206330 If c/d is a rational number with GCD(c,d)=1, define
%C A206330 Q(c/d,x)=p(c,x)-p(d,x).  Let c(n)/d(n) be the n-th
%C A206330 positive rational number given by the canonical
%C A206330 bijection; i.e., c(n)=A038568(n)/A038569(n).
%C A206330 Define P(0,x)=1 and P(n,x)=Q(c(n)/d(n),x).  Polynomials
%C A206330 having nonnegative integer coefficients are matched to
%C A206330 the nonnegative integers as follows:
%C A206330 ...
%C A206330 n .... P[n,x] .. irreducible
%C A206330 0 .... 0 ....... no
%C A206330 1 ... -1 ....... no
%C A206330 2 .... 1 ....... no
%C A206330 3 ... -x ....... yes
%C A206330 4 .... x ....... yes
%C A206330 5 ... 1-x ...... yes
%C A206330 6 .. -1+x ...... yes
%C A206330 7 .. -2 ........ no
%C A206330 8 ... 2 ........ no
%C A206330 9 .. -2+x ...... yes
%C A206330 10 .. 2-x ...... yes
%e A206330 In the table under Comments, read "yes" for n=3,4,5,6,9,10.
%t A206330 b[n_] := Table[x^k, {k, 0, n}];
%t A206330 f[n_] := f[n] = FactorInteger[n]; z = 1000;
%t A206330 t[n_, m_, k_] := If[PrimeQ[f[n][[m, 1]]] && f[n][[m, 1]]
%t A206330  == Prime[k], f[n][[m, 2]], 0];
%t A206330 u = Table[Apply[Plus,
%t A206330     Table[Table[t[n, m, k], {k, 1, PrimePi[n]}], {m, 1,
%t A206330       Length[f[n]]}]], {n, 1, z}];
%t A206330 c[n_] := Module[{s = 1, k = 2, j = 1},
%t A206330    While[s <= n, s = s + 2*EulerPhi[k]; k = k + 1];
%t A206330    s = s - 2*EulerPhi[k - 1];
%t A206330    While[s <= n, If[GCD[j, k - 1]
%t A206330       == 1, s = s + 2]; j = j + 1];
%t A206330    If[s > n + 1, j - 1, k - 1]];
%t A206330 d[n_] := Module[{s = 1, k = 2, j = 1},
%t A206330    While[s <= n, s = s + 2*EulerPhi[k]; k = k + 1];
%t A206330    s = s - 2*EulerPhi[k - 1];
%t A206330    While[s <= n, If[GCD[j, k - 1]
%t A206330       == 1, s = s + 2]; j = j + 1];
%t A206330    If[s > n + 1, k - 1, j - 1]];
%t A206330 P[n_, x_] :=
%t A206330  u[[c[n]]].b[-1 + Length[u[[c[n]]]]] -
%t A206330   u[[d[n]]].b[-1 + Length[u[[d[n]]]]]
%t A206330 TableForm[Table[{n, P[n, x], Factor[P[n, x]]},
%t A206330    {n, 1, z/4}]];
%t A206330 v = {}; Do[n++;
%t A206330  If[IrreduciblePolynomialQ[P[n, x]], AppendTo[v, n]], {n, z/2}]
%t A206330 v                            (* A206330 *)
%t A206330 Complement[Range[0,200], v]  (* A206331 *)
%Y A206330 Cf. A206284 (polynomials over the positive integers),
%Y A206330 A206331 (complement of A206330).
%K A206330 nonn
%O A206330 1,1
%A A206330 _Clark Kimberling_, Feb 06 2012