cp's OEIS Frontend

A325014 Array read by descending antidiagonals: A(n,k) is the number of chiral pairs of colorings of the facets of a regular n-dimensional orthoplex using up to k colors.

%I A325014 #18 Jun 15 2019 14:43:43
%S A325014 0,1,0,3,0,0,6,3,1,0,10,15,66,94,0,15,45,920,97974,1047816,0,21,105,
%T A325014 6350,10700090,481141220994,400140831558512,0,28,210,29505,390081800,
%U A325014 4802390808840576,74515656021475803734579625,527471421741473576372948457251328,0
%N A325014 Array read by descending antidiagonals: A(n,k) is the number of chiral pairs of colorings of the facets of a regular n-dimensional orthoplex using up to k colors.
%C A325014 Also called cross polytope and hyperoctahedron. For n=1, the figure is a line segment with two vertices. For n=2 the figure is a square with four edges. For n=3 the figure is an octahedron with eight triangular faces. For n=4, the figure is a 16-cell with sixteen tetrahedral facets. The Schläfli symbol, {3,...,3,4}, of the regular n-dimensional orthoplex (n>1) consists of n-2 threes followed by a four. Each of its 2^n facets is an (n-1)-dimensional simplex. The chiral colorings of its facets come in pairs, each the reflection of the other.
%C A325014 Also the number of chiral pairs of colorings of the vertices of a regular n-dimensional orthotope (cube) using up to k colors.
%H A325014 Robert A. Russell, <a href="/A325014/b325014.txt">Table of n, a(n) for n = 1..78</a>
%H A325014 E. M. Palmer and R. W. Robinson, <a href="https://projecteuclid.org/euclid.acta/1485889789">Enumeration under two representations of the wreath product</a>, Acta Math., 131 (1973), 123-143.
%H A325014 Wikipedia, <a href="https://en.wikipedia.org/wiki/Cross-polytope">Cross-polytope</a>
%F A325014 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.
%F A325014 A(k,n) = A325012(n,k) - A325013(n,k) = (A325012(n,k) - A325015(n,k)) / 2 = A325013(n,k) - A325015(n,k).
%F A325014 A(n,k) = Sum_{j=2..2^n} A325018(n,j) * binomial(k,j).
%e A325014 Array begins with A(1,1):
%e A325014 0  1     3        6        10         15          21           28 ...
%e A325014 0  0     3       15        45        105         210          378 ...
%e A325014 0  1    66      920      6350      29505      106036       317856 ...
%e A325014 0 94 97974 10700090 390081800 7280687610 86121007714 730895668104 ...
%e A325014 For A(2,3)=3, each square has one of the three colors on two adjacent edges.
%t A325014 a48[n_] := a48[n] = DivisorSum[NestWhile[#/2&, n, EvenQ], MoebiusMu[#]2^(n/#)&]/(2n); (* A000048 *)
%t A325014 a37[n_] := a37[n] = DivisorSum[n, MoebiusMu[n/#]2^#&]/n; (* A001037 *)
%t A325014 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. *)
%t A325014 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. *)
%t A325014 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 A325014 cix[{a_, b_}, {c_, d_}] := {LCM[a, c], (a b c d)/LCM[a, c]};
%t A325014 Unprotect[Times]; Times[CI[a_List], CI[b_List]] :=  (* combine *) CI[compress[Flatten[Outer[cix, a, b, 1], 1]]]; Protect[Times];
%t A325014 CI0[p_List] := CI0[p] = Expand[CI0[Drop[p, -1]] CI0[{Last[p]}] + CI1[Drop[p, -1]] CI1[{Last[p]}]]
%t A325014 CI1[p_List] := CI1[p] = Expand[CI0[Drop[p, -1]] CI1[{Last[p]}] + CI1[Drop[p, -1]] CI0[{Last[p]}]]
%t A325014 pc[p_List] := Module[{ci,mb},mb = DeleteDuplicates[p]; ci = Count[p, #] & /@ mb; n!/(Times @@ (ci!) Times @@ (mb^ci))] (* partition count *)
%t A325014 row[n_Integer] := row[n] = Factor[(Total[((CI0[#] - CI1[#]) pc[#]) & /@ IntegerPartitions[n]])/(n! 2^n)] /. CI[l_List] :> j^(Total[l][[2]])
%t A325014 array[n_, k_] := row[n] /. j -> k
%t A325014 Table[array[n, d-n+1], {d, 1, 10}, {n, 1, d}] // Flatten
%Y A325014 Cf. A325012 (oriented), A325013 (unoriented), A325015 (achiral), A325018 (exactly k colors).
%Y A325014 Other n-dimensional polytopes: A007318(k,n+1) (simplex), A325006 (orthotope).
%Y A325014 Rows 1-2 are A161680, A050534.
%Y A325014 Cf. A000048, A001037.
%K A325014 nonn,tabl,easy
%O A325014 1,4
%A A325014 _Robert A. Russell_, May 27 2019