|
%I #4 Sep 28 2020 21:41:07
%S 0,0,0,0,0,0,0,0,6,0,0,1,405,1368,0,0,5,7904,4775706,6711288,0,0,15,
%T 76880,1522540416,9923557498416,1785683627824,0,0,35,486522,
%U 132342705750,234239763858347776,12979826761630383196344,53302696800142157920,0
%N Array read by descending antidiagonals: T(n,k) is the number of chiral pairs of colorings of the triangular faces of a regular n-dimensional simplex using k or fewer colors.
%C Each member of a chiral pair is a reflection, but not a rotation, of the other. An n-simplex has n+1 vertices. For n=2, the figure is a triangle with one triangular face. For n=3, the figure is a tetrahedron with 4 triangular faces. For higher n, the number of triangular faces is C(n+1,3).
%C Also the number of chiral pairs of colorings of the peaks of a regular n-dimensional simplex. A peak of an n-simplex is an (n-3)-dimensional simplex.
%H E. M. Palmer and R. W. Robinson, <a href="https://doi.org/10.1007/BF02392038">Enumeration under two representations of the wreath product</a>, Acta Math., 131 (1973), 123-143.
%F 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).
%F T(n,k) = A337883(n,k) - A337884(n,k) = (A337883(n,k) - A337886(n,k)) / 2 = A337884(n,k) - A337886(n,k).
%e Table begins with T(2,1):
%e 0 0 0 0 0 0 0 ...
%e 0 0 0 1 5 15 35 ...
%e 0 6 405 7904 76880 486522 2300305 ...
%e 0 1368 4775706 1522540416 132342705750 5076500214744 110809322249220 ...
%e For T(3,4)=1, the chiral pair is ABCD-ABDC.
%t m=2; (* dimension of color element, here a triangular face *)
%t lw[n_,k_]:=lw[n, k]=DivisorSum[GCD[n,k],MoebiusMu[#]Binomial[n/#,k/#]&]/n (*A051168*)
%t cxx[{a_, b_},{c_, d_}]:={LCM[a, c], GCD[a, c] b d}
%t 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)
%t combine[a : {{_, _} ...}, b : {{_, _} ...}] := Outer[cxx, a, b, 1]
%t CX[p_List, 0] := {{1, 1}} (* cycle index for partition p, m vertices *)
%t 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]]]}]]
%t 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]]]]
%t pc[p_] := Module[{ci, mb}, mb = DeleteDuplicates[p]; ci = Count[p, #] &/@ mb; Total[p]!/(Times @@ (ci!) Times @@ (mb^ci))] (* partition count *)
%t row[n_Integer] := row[n] = Factor[Total[If[EvenQ[Total[1-Mod[#, 2]]],1,-1] pc[#] j^Total[CX[#, m+1]][[2]] & /@ IntegerPartitions[n+1]]/(n+1)!]
%t array[n_, k_] := row[n] /. j -> k
%t Table[array[n,d+m-n], {d,8}, {n,m,d+m-1}] // Flatten
%Y Cf. A337883 (oriented), A337884 (unoriented), A337886 (achiral), A051168 (binary Lyndon words).
%Y Other elements: A325000(n,k-n) (vertices), A327085 (edges).
%Y Other polytopes: A337889 (orthotope), A337893 (orthoplex).
%Y Rows 2-4 are A000004, A000332, A331352.
%K nonn,tabl
%O 2,9
%A _Robert A. Russell_, Sep 28 2020
|
