%I #12 Jul 12 2012 00:40:00
%S 2,3,7,8,10,14,16,18,21,23,29,31,35,41,42,44,48,50,54,56,60,62,66,70,
%T 72,76,78,80,82,84,86,88,93,97,99,103,109,111,115,117,123,125,129,131,
%U 137,141,143,147,153,155,159,161,165,167,171,173,179,183,186,188
%N Numbers that match irreducible polynomials over {-1,0,1} with leading coefficient 1.
%C The monic polynomials y(n,x) having coefficients in {-1,0,1} are matched to the set N of positive integers as follows. First, the monic polynomials p(n,x) having coefficients in {0,1} are matched to N as in A206074; i.e., the polynomial x^d(0) + x^d(1) + ... + d(n), where d(i) is 0 or 1 for 0<=i<=n and d(0)=1, matches the binary number d(0)d(1)...d(n). Then monic polynomials having at least one negative coefficient are then inserted among the polynomials p(n,x), as follows: x-1 goes between x and x+1, and for k>1, the polynomials x^k-p(n,x), for 0<n<2^k, go between x^k and x^k+1, in this order: x^k-p(1,x), x^k-p(2,x),..., x^k-p(2^k-1,x). A program in the Mathematica section generates the resulting polynomials in the order just described. The n-th polynomial, denoted here as y(n,x), can be obtained as y[[n]] from the program. The first 11 polynomials, marked "yes" if irreducible over the field of rational numbers, are shown here:
%C n ..... y(n,x) ... irreducible
%C 1 ..... 1 ........ no
%C 2 ..... x ........ yes
%C 3 ..... 1+x ...... yes
%C 4 ..... x^2 ...... no
%C 5 .... -1+x^2 .... no
%C 6 .... -x+x^2 .... no
%C 7 .... -1-x+x^2 .. yes
%C 8 ..... 1+x^2 .... yes
%C 9 ..... x+x^2 .... no
%C 10 .... 1+x+x^2 .. yes
%C 11 .... x^3 ...... no
%C ...
%C Guide to sequences based on the polynomials y(n,x):
%C A206822, irreducible
%C A206829, number of distinct factors
%C A207187, multiples of x+1
%C A207188, multiples of x
%C A207189, multiples of x-1
%C A207190, multiples of x^2+1
%C A207191, even: y(n,-x)=y(n,x)
%C A207192, odd: y(n,-x)=-y(n,x)
%t t = Table[IntegerDigits[n, 2], {n, 1, 1000}];
%t b[n_] := Reverse[Table[x^k, {k, 0, n}]];
%t p[n_] := p[n] = t[[n]].b[-1 + Length[t[[n]]]];
%t TableForm[Table[{n, p[n], Factor[p[n]]}, {n, 1, 6}]]
%t f[k_] := 2^k - k; g[k_] := 2^k - 2 + f[k - 1];
%t q1[n_] := p[2^(k - 1)] - p[n + 1 - f[k]];
%t q2[n_] := p[n - f[k] + 2];
%t y1 = Table[p[n], {n, 1, 4}];
%t Do[AppendTo[y1,Join[Table[q1[n], {n, f[k], g[k] - 1}],
%t Table[q2[n], {n, g[k], f[k + 1] - 1}]]], {k, 3, 8}]
%t y = Flatten[y1]; (* polynomials over {-1,0,1} *)
%t w = {}; Do[n++; If[IrreduciblePolynomialQ[y[[n]]], AppendTo[w, n]], {n, 200}]
%t w (* A206821 *)
%t Complement[Range[200], w] (* A206822 *)
%Y Cf. A206073, A206284, A206822.
%K nonn
%O 1,1
%A _Clark Kimberling_, Feb 12 2012