[math-fun] gefundenes Fressen 2
consider the table of necklace polynomials, n beads, c<=n colours, substitute colour k by Exp[2 Pi I k/c], Table[NecklacePolynomial[n,Exp[2 I Pi Range[c]/c],Cyclic]//FullSimplify,{n,13},{c,n}] and find: {1}, {1,1}, {1,0,2}, {1,2,0,2}, {1,0,0,0,4}, {1,2,4,0,0,2}, {1,0,0,0,0,0,6}, {1,4,0,6,0,0,0,4}, {1,0,8,0,0,0,0,0,6}, {1,4,0,0,12,0,0,0,0,4}, {1,0,0,0,0,0,0,0,0,0,10}, {1,8,16,12,0,8,0,0,0,0,0,4}, {1,0,0,0,0,0,0,0,0,0,0,0,12}, and that might very well be: if c|n then Sum(d|(n/c), phi(c d) d^(n/c/d) /n) else 0 or, Table[If[MemberQ[Divisors[n],c], Fold[ #1 + EulerPhi[c #2]c^(n/c/#2)/(n) &, 0, Divisors[n/c]],0 ],{n,20},{c,n}] which is nice too, Wouter. earlier: ----- Original Message ----- From: "wouter meeussen" <wouter.meeussen@pandora.be> To: "math-fun" <math-fun@mailman.xmission.com> Sent: Saturday, July 28, 2007 9:57 PM Subject: [math-fun] gefundenes Fressen (a cheap find)
Imagine a necklace with n beads of up to n colours, say n=3 beads made of colours x[1], x[2] and x[3], then these are counted by:
Table[NecklacePolynomial[n,Array[x,n],Cyclic],{n,3,3}] {x[1]^3 + x[1]^2*x[2] + x[1]*x[2]^2 + x[2]^3 + x[1]^2*x[3] + 2*x[1]*x[2]*x[3] + x[2]^2*x[3] + x[1]*x[3]^2 + x[2]*x[3]^2 + x[3]^3}
now, change the colours into complex roots of 1 x[k] -> E^(2I Pi k/n) so that they do a 'complex cancellation' on the unit circle, and, hey presto, the whole caboodle collapses to EulerPhi[n]:
EulerPhi[n] == NecklacePolynomial[n,E^(2I Pi Range[n]/n),Cyclic]
which is nice...
Wouter.
neclaces are elegant, but bracelets look gross: consider the table of bracelet polynomials, n beads, c<=n colours, substitute colour k by Exp[2 Pi I k/c], Table[NecklacePolynomial[n,Exp[2 I Pi Range[c]/c],Dihedral]//FullSimplify,{n,13},{c,n}] and find: {1}, {1,1}, {1,0,1}, {1,2,0,1}, {1,0,0,0,2}, {1,3,2,0,0,1}, {1,0,0,0,0,0,3}, {1,6,0,3,0,0,0,2}, {1,0,4,0,0,0,0,0,3}, {1,10,0,0,6,0,0,0,0,2}, {1,0,0,0,0,0,0,0,0,0,5}, {1,20,8,6,0,4,0,0,0,0,0,2}, {1,0,0,0,0,0,0,0,0,0,0,0,6}, and that might very well be: if c|n then if(c=1,2,1)*(1/2/c)* (if(c=2,2^(n/c),0)+ Sum(d|(n/c), phi(c*d)*c^(n/c/d)/(n/c)) else 0 or, Table[If[MemberQ[Divisors[n],c],If[c===1,2,1]*(1/2/c) *(If[c===2,2^(n/c),0]+Fold[#1+ EulerPhi[c #2]*c^(n/#2/c) /(n/c)&,0,Divisors[n/c]]),0],{n,13},{c,n}] which is not nice at all, with ugly If's showing definite lack of elegance (?!) Anyone to de-grossify this? But I honestly admit still not to grasp (=grok) the 'why' of these triviae. So, I give up. Wouter.
participants (1)
-
wouter meeussen