A325013 Array read by descending antidiagonals: A(n,k) is the number of unoriented colorings of the facets of a regular n-dimensional orthoplex using up to k colors.
1, 3, 1, 6, 6, 1, 10, 21, 22, 1, 15, 55, 267, 402, 1, 21, 120, 1996, 132102, 1228158, 1, 28, 231, 10375, 11756666, 484086357207, 400507806843728, 1, 36, 406, 41406, 405385550, 4805323147589984, 74515759884862073604656433, 527471432057653004017274030725792, 1
Offset: 1
Examples
Array begins with A(1,1): 1 3 6 10 15 21 28 36 ... 1 6 21 55 120 231 406 666 ... 1 22 267 1996 10375 41406 135877 384112 ... 1 402 132102 11756666 405385550 7416923886 86986719477 735192450952 ... For A(2,2)=6, two squares have all edges the same color, two have three edges the same color, one has opposite edges the same color, and one has opposite edges different colors.
Links
- Robert A. Russell, Table of n, a(n) for n = 1..78
- E. M. Palmer and R. W. Robinson, Enumeration under two representations of the wreath product, Acta Math., 131 (1973), 123-143.
- Wikipedia, Cross-polytope
Crossrefs
Programs
-
Mathematica
a48[n_] := a48[n] = DivisorSum[NestWhile[#/2&, n, EvenQ], MoebiusMu[#]2^(n/#)&]/(2n); (* A000048 *) a37[n_] := a37[n] = DivisorSum[n, MoebiusMu[n/#]2^#&]/n; (* A001037 *) CI0[{n_Integer}] := CI0[{n}] = CI[Transpose[If[EvenQ[n], p2 = IntegerExponent[n, 2]; sub = Divisors[n/2^p2]; {2^(p2+1) sub, a48 /@ (2^p2 sub) }, sub = Divisors[n]; {sub, a37 /@ sub}]]] 2^(n-1); (* even perm. *) CI1[{n_Integer}] := CI1[{n}] = CI[sub = Divisors[n]; Transpose[If[EvenQ[n], {sub, a37 /@ sub}, {2 sub, a48 /@ sub}]]] 2^(n-1); (* odd perm. *) compress[x : {{, } ...}] := (s = Sort[x]; For[i = Length[s], i > 1, i -= 1, If[s[[i, 1]]==s[[i-1, 1]], s[[i-1, 2]] += s[[i, 2]]; s = Delete[s, i], Null]]; s) cix[{a_, b_}, {c_, d_}] := {LCM[a, c], (a b c d)/LCM[a, c]}; Unprotect[Times]; Times[CI[a_List], CI[b_List]] := (* combine *) CI[compress[Flatten[Outer[cix, a, b, 1], 1]]]; Protect[Times]; CI0[p_List] := CI0[p] = Expand[CI0[Drop[p, -1]] CI0[{Last[p]}] + CI1[Drop[p, -1]] CI1[{Last[p]}]] CI1[p_List] := CI1[p] = Expand[CI0[Drop[p, -1]] CI1[{Last[p]}] + CI1[Drop[p, -1]] CI0[{Last[p]}]] pc[p_List] := Module[{ci,mb},mb = DeleteDuplicates[p]; ci = Count[p, #] & /@ mb; n!/(Times @@ (ci!) Times @@ (mb^ci))] (* partition count *) row[n_Integer] := row[n] = Factor[(Total[((CI0[#] + CI1[#]) pc[#]) & /@ IntegerPartitions[n]])/(n! 2^n)] /. CI[l_List] :> j^(Total[l][[2]]) array[n_, k_] := row[n] /. j -> k Table[array[n, d-n+1], {d, 1, 10}, {n, 1, d}] // Flatten
Formula
The algorithm used in the Mathematica program below assigns each permutation of the axes to a partition of n. It then determines the number of permutations for each partition and the cycle index for each partition.
A(n,k) = A325012(n,k) - A325014(n,k) = (A325012(n,k) + A325015(n,k)) / 2 = A325014(n,k) + A325015(n,k).
A(n,k) = Sum_{j=1..2^n} A325017(n,j) * binomial(k,j).
Comments