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