# Acyclic orientations of an n-dimensional cube

The goal of this challenge is to check and extend the OEIS sequence A334248: Number of distinct acyclic orientations of the edges of an n-dimensional cube.

Take an n-dimensional cube (if n=1, this is a line; if n=2, a square; if n=3, a cube; if n=4, a hypercube/tesseract; etc), and give a direction to all of its edges so that no cycles are formed. The terms of the sequence are the number of (rotationally and reflectively) distinct orientations that can be obtained.

## Example

For n=2, there are 14 ways to assign directions to the edges of a square with no cycles formed: However, only three of these are distinct if they are rotated and reflected: So when n=2, the answer is 3.

The winner of this challenge will be the program that calculates the most terms when run on my computer (Ubuntu, 64GB RAM) in one hour. If there is a tie, the program that computes the terms in the shortest time will be the winner.

• You should consider extending the challenge to include n=5. Or make the winning criterion the number of terms that can be computed in under an hour. Apr 22, 2020 at 7:44
• This is a better criterion, I'll adjust it Apr 22, 2020 at 7:53
• Oh gosh, this is counting among the exponentially many orientations of graphs that are themselves exponential in size, which likely gives doubly exponential growth. Finding more terms for OEIS will be hard.
– xnor
Apr 22, 2020 at 8:11
• I'm afraid running time goes up so quickly that any stupid program works 4 out quickly but quite optimized one can't do with 5
– l4m2
Apr 22, 2020 at 13:56
• The OEIS sequence has been updated to reflect that A334248(5) = 12284402192625939. Any hope of computing the next term? Obviously this isn’t something that can be brute forced. Apr 25, 2020 at 16:45

# Wolfram Language (Mathematica), n = 4, <1 second on my computer

(* Elements of the hyperoctahedral group,represented by matrices *)
HyperoctahedralGroup[n_] :=
Join @@ Table[
Permute[IdentityMatrix@n, perm]*sign, {perm,
Permutations@Range@n}, {sign, Tuples[{1, -1}, n]}];

(* Action of group elements on a vertex of the hypercube,
where each vertex is represented by an integer from 1 to 2^n *)
ActOn[n_, g_, v_] :=
FromDigits[(1 + (IntegerDigits[v - 1, 2, n]*2 - 1) . g)/2, 2] + 1;

(* Orbits of vertices under such action *)
Orbits[n_, g_] :=
ConnectedComponents@Table[v <-> ActOn[n, g, v], {v, 2^n}];

(* Whether any orbit contains adjacent vertices *)
Or @@ Or @@@ Outer[SubsetQ, orbits, edges, 1];

(* Merging vertices in each orbit into a single vertex *)
MergeVertices[edges_, orbits_] :=
Graph@DeleteDuplicates[
Sort /@ (edges /. (Alternatives@##2 -> #1 & @@@ orbits))];

(* Number of acyclic orientations fixed by some group element *)
InvariantAcyclicOrientations[n_, edges_, g_] :=
With[{orbits = Orbits[n, g]},
Abs[ChromaticPolynomial[MergeVertices[edges, orbits], -1]]]];

(* OEIS sequence A334248 *)
A334248[n_] :=
With[{edges = List @@@ EdgeList@HypercubeGraph@n},
Sum[InvariantAcyclicOrientations[n, edges, g], {g,
HyperoctahedralGroup[n]}]/(2^n*n!)];

Do[Print[n -> A334248[n]], {n, 1, 4}]


Try it online!

Not really optimized. Takes less than 1 seconds on my computer to calculate the first four terms, but takes forever for the fifth term. It seems that Mathematica cannot compute the chromatic polynomial of HypercubeGraph in a reasonable time.

Based on Peter Kagey's deleted answer (which did not consider rotations and reflections), and uses Burnside's lemma.