A337883 Array read by descending antidiagonals: T(n,k) is the number of oriented colorings of the triangular faces of a regular n-dimensional simplex using k or fewer colors.
1, 2, 1, 3, 5, 1, 4, 15, 40, 1, 5, 36, 1197, 3504, 1, 6, 75, 18592, 9753615, 13724608, 1, 7, 141, 166885, 3056311808, 19854224207910, 3574466244480, 1, 8, 245, 1019880, 264940140875, 468488921670219776, 25959704193068472575379, 106607224611810055168, 1
Offset: 2
Examples
The table begins with T(2,1): 1 2 3 4 5 6 7 ... 1 5 15 36 75 141 245 ... 1 40 1197 18592 166885 1019880 4738153 ... 1 3504 9753615 3056311808 264940140875 10156268150064 221646915632373 ... For T(3,4)=36, the 34 achiral arrangements are AAAA, AAAB, AAAC, AAAD, AABB, AABC, AABD, AACC, AACD, AADD, ABBB, ABBC, ABBD, ABCC, ABDD, ACCC, ACCD, ACDD, ADDD, BBBB, BBBC, BBBD, BBCC, BBCD, BBDD, BCCC, BCCD, BCDD, BDDD, CCCC, CCCD, CCDD, CDDD, and DDDD. The chiral pair is ABCD-ABDC.
Links
- E. M. Palmer and R. W. Robinson, Enumeration under two representations of the wreath product, Acta Math., 131 (1973), 123-143.
Crossrefs
Programs
-
Mathematica
m=2; (* dimension of color element, here a triangular face *) lw[n_,k_]:=lw[n, k]=DivisorSum[GCD[n,k],MoebiusMu[#]Binomial[n/#,k/#]&]/n (*A051168*) cxx[{a_, b_},{c_, d_}]:={LCM[a, c], GCD[a, c] b d} 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) combine[a : {{, } ...}, b : {{, } ...}] := Outer[cxx, a, b, 1] CX[p_List, 0] := {{1, 1}} (* cycle index for partition p, m vertices *) CX[{n_Integer}, m_] := If[2m>n, CX[{n}, n-m], CX[{n},m] = Table[{n/k, lw[n/k, m/k]}, {k, Reverse[Divisors[GCD[n, m]]]}]] CX[p_List, m_Integer] := CX[p, m] = Module[{v = Total[p], q, r}, If[2 m > v, CX[p, v - m], q = Drop[p, -1]; r = Last[p]; compress[Flatten[Join[{{CX[q, m]}}, Table[combine[CX[q, m - j], CX[{r}, j]], {j, Min[m, r]}]], 2]]]] pc[p_] := Module[{ci, mb}, mb = DeleteDuplicates[p]; ci = Count[p, #] &/@ mb; Total[p]!/(Times @@ (ci!) Times @@ (mb^ci))] (* partition count *) row[n_Integer] := row[n] = Factor[Total[If[EvenQ[Total[1-Mod[#, 2]]], pc[#] j^Total[CX[#, m+1]][[2]], 0] & /@ IntegerPartitions[n+1]]/((n+1)!/2)] array[n_, k_] := row[n] /. j -> k Table[array[n,d+m-n], {d,8}, {n,m,d+m-1}] // Flatten
Formula
The algorithm used in the Mathematica program below assigns each permutation of the vertices to a partition of n+1. It then determines the number of permutations for each partition and the cycle index for each partition using a formula for binary Lyndon words. If the value of m is increased, one can enumerate colorings of higher-dimensional elements beginning with T(m,1).
Comments