Revisions to Probability a polynomial has a root which is a root of unity

added 6 characters in body

Source Link

edited May 28, 2014 at 15:39

user44143

I get $$\left\{\frac{2}{3},\frac{2}{3},\frac{4}{9},\frac{35}{81},\frac{94}{243},\frac{275}{729} ,\frac{263}{729},\frac{2267}{6561}\right\}$$

for the monic polynomials of degree 1 to 8, using Mathematica:

f[a_, b_] := a x^(b - 1)

PolysOfDegree[n_] := First /@ Table[ x^n + Plus @@
                     MapIndexed[f, IntegerDigits[i, 3, n] - 1], {i, 0, 3^n - 1}]

TestFactors[n_] := Table[FactorList[x^i - 1], {i, 1, 2 n + 2}]
                   // Flatten // Union // Rest

HasRootOfUnityAsRoot[poly_] := Or @@ Map[ PolynomialMod[poly , #] === 0 &,
                                          TestFactors[Exponent[poly, x]]]

Prob[n_] := Count[Map[HasRootOfUnityAsRoot, PolysOfDegree[n]], True]/3^n

Table[Prob[n], {n,1,8}]

I've enumerated the polynomials of degree $n$, and enumerated the characteristic polynomials of roots of unity of degree up to $2n+2$. Then it's just a matter of testing which are divisible by which.

I get $$\left\{\frac{2}{3},\frac{2}{3},\frac{4}{9},\frac{35}{81},\frac{94}{243},\frac{275}{729} ,\frac{263}{729},\frac{2267}{6561}\right\}$$

for the monic polynomials of degree 1 to 8, using Mathematica:

f[a_, b_] := a x^(b - 1)

PolysOfDegree[n_] := First /@ Table[ x^n + Plus @@
                     MapIndexed[f, IntegerDigits[i, 3, n] - 1], {i, 0, 3^n - 1}]

TestFactors[n_] := Table[FactorList[x^i - 1], {i, 1, 2 n + 2}]
                   // Flatten // Union // Rest

HasRootOfUnityAsRoot[poly_] := Or @@ Map[ PolynomialMod[poly , #] === 0 &,
                                          TestFactors[Exponent[poly, x]]]

Prob[n_] := Count[Map[HasRootOfUnityAsRoot, PolysOfDegree[n]], True]/3^n

Table[Prob[n], {n,1,8}]

I've enumerated the polynomials of degree $n$, and enumerated the characteristic polynomials of roots of unity of degree $2n+2$. Then it's just a matter of testing which are divisible by which.

I get $$\left\{\frac{2}{3},\frac{2}{3},\frac{4}{9},\frac{35}{81},\frac{94}{243},\frac{275}{729} ,\frac{263}{729},\frac{2267}{6561}\right\}$$

for the monic polynomials of degree 1 to 8, using Mathematica:

f[a_, b_] := a x^(b - 1)

PolysOfDegree[n_] := First /@ Table[ x^n + Plus @@
                     MapIndexed[f, IntegerDigits[i, 3, n] - 1], {i, 0, 3^n - 1}]

TestFactors[n_] := Table[FactorList[x^i - 1], {i, 1, 2 n + 2}]
                   // Flatten // Union // Rest

HasRootOfUnityAsRoot[poly_] := Or @@ Map[ PolynomialMod[poly , #] === 0 &,
                                          TestFactors[Exponent[poly, x]]]

Prob[n_] := Count[Map[HasRootOfUnityAsRoot, PolysOfDegree[n]], True]/3^n

Table[Prob[n], {n,1,8}]

I've enumerated the polynomials of degree $n$, and enumerated the characteristic polynomials of roots of unity of degree up to $2n+2$. Then it's just a matter of testing which are divisible by which.

improved code

Source Link

edited May 28, 2014 at 14:58

user44143

I get $$\left\{\frac{2}{3},\frac{2}{3},\frac{4}{9},\frac{35}{81},\frac{94}{243},\frac{275}{729} ,\frac{263}{729},\frac{2267}{6561}\right\}$$

for the monic polynomials of degree 1 to 8, using Mathematica:

f[a_, b_] := a x^(b - 1)

PolysOfDegree[n_] := Map[(First /@ Table[ x^n + Plus @@ MapIndexed[f, #] // First) &, 
                        MapIndexed[f, Table[IntegerDigits[iIntegerDigits[i, 3, n] - 11], {i, 0, 3^n - 1}]]]

TestFactors[n_] := Table[FactorList[x^i - 1], {i, 1, 2 n + 2}]
                   // Flatten // Union // Rest

HasRootOfUnityAsRoot[poly_] := Or @@ Map[ PolynomialMod[poly , #] === 0 &,
                                          TestFactors[Exponent[poly, x]]]

Prob[n_] := Count[Map[HasRootOfUnityAsRoot, PolysOfDegree[n]], True]/3^n

Table[Prob[n], {n,1,8}]

I've enumerated the polynomials of degree $n$, and enumerated the characteristic polynomials of roots of unity of degree $2n+2$. Then it's just a matter of testing which are divisible by which.

I get $$\left\{\frac{2}{3},\frac{2}{3},\frac{4}{9},\frac{35}{81},\frac{94}{243},\frac{275}{729} ,\frac{263}{729},\frac{2267}{6561}\right\}$$

for the monic polynomials of degree 1 to 8, using Mathematica:

f[a_, b_] := a x^(b - 1)

PolysOfDegree[n_] := Map[(x^n + Plus @@ MapIndexed[f, #] // First) &, 
                         Table[IntegerDigits[i, 3, n] - 1, {i, 0, 3^n - 1}]]

TestFactors[n_] := Table[FactorList[x^i - 1], {i, 1, 2 n + 2}]
                   // Flatten // Union // Rest

HasRootOfUnityAsRoot[poly_] := Or @@ Map[ PolynomialMod[poly , #] === 0 &,
                                          TestFactors[Exponent[poly, x]]]

Prob[n_] := Count[Map[HasRootOfUnityAsRoot, PolysOfDegree[n]], True]/3^n

Table[Prob[n], {n,1,8}]

I've enumerated the polynomials of degree $n$, and enumerated the characteristic polynomials of roots of unity of degree $2n+2$. Then it's just a matter of testing which are divisible by which.

I get $$\left\{\frac{2}{3},\frac{2}{3},\frac{4}{9},\frac{35}{81},\frac{94}{243},\frac{275}{729} ,\frac{263}{729},\frac{2267}{6561}\right\}$$

for the monic polynomials of degree 1 to 8, using Mathematica:

f[a_, b_] := a x^(b - 1)

PolysOfDegree[n_] := First /@ Table[ x^n + Plus @@
                     MapIndexed[f, IntegerDigits[i, 3, n] - 1], {i, 0, 3^n - 1}]

TestFactors[n_] := Table[FactorList[x^i - 1], {i, 1, 2 n + 2}]
                   // Flatten // Union // Rest

HasRootOfUnityAsRoot[poly_] := Or @@ Map[ PolynomialMod[poly , #] === 0 &,
                                          TestFactors[Exponent[poly, x]]]

Prob[n_] := Count[Map[HasRootOfUnityAsRoot, PolysOfDegree[n]], True]/3^n

Table[Prob[n], {n,1,8}]

I've enumerated the polynomials of degree $n$, and enumerated the characteristic polynomials of roots of unity of degree $2n+2$. Then it's just a matter of testing which are divisible by which.

Source Link

created May 28, 2014 at 14:28

user44143

I get $$\left\{\frac{2}{3},\frac{2}{3},\frac{4}{9},\frac{35}{81},\frac{94}{243},\frac{275}{729} ,\frac{263}{729},\frac{2267}{6561}\right\}$$

for the monic polynomials of degree 1 to 8, using Mathematica:

f[a_, b_] := a x^(b - 1)

PolysOfDegree[n_] := Map[(x^n + Plus @@ MapIndexed[f, #] // First) &, 
                         Table[IntegerDigits[i, 3, n] - 1, {i, 0, 3^n - 1}]]

TestFactors[n_] := Table[FactorList[x^i - 1], {i, 1, 2 n + 2}]
                   // Flatten // Union // Rest

HasRootOfUnityAsRoot[poly_] := Or @@ Map[ PolynomialMod[poly , #] === 0 &,
                                          TestFactors[Exponent[poly, x]]]

Prob[n_] := Count[Map[HasRootOfUnityAsRoot, PolysOfDegree[n]], True]/3^n

Table[Prob[n], {n,1,8}]

I've enumerated the polynomials of degree $n$, and enumerated the characteristic polynomials of roots of unity of degree $2n+2$. Then it's just a matter of testing which are divisible by which.

Stack Exchange Network

Return to Answer