# How to obtain all the distinct De Bruijn sequences?

In combinatorial mathematics, a $k$-ary De Bruijn sequence $B(k, n)$ of order $n$ is a cyclic sequence of a given alphabet $A$ with size $k$ for which every possible subsequence of length $n$ in $A$ appears as a sequence of consecutive characters exactly once.

Each $B(k, n)$ has length $k^n$ and there are $\dfrac{(k!)^{k^{n-1}}}{k^n}$ distinct De Bruijn sequences.

By using DeBruijnGraph and FindEulerianCycle should be possible to obtain all the distinct sequences. In the example below I should obtain 24 sequences ($k = 3$, $n = 2$). However, I get only three distinct sequences:

out=FindEulerianCycle[DeBruijnGraph[3, 1], 24];
(First /@ #) & /@ out


{{1, 1, 2, 1, 3, 2, 2, 3, 3}, {2, 1, 1, 2, 2, 3, 1, 3, 3}, {3, 1, 1, 2, 1, 3, 2, 2, 3}}

How can I obtain all the distinct De Bruijn sequences?

-
I can't reproduce your problem on MMA 9 -- I get 24 cycles. –  mfvonh Jun 24 '14 at 17:59
I can reproduce the result in the question on version 8.0.4 –  Jens Jun 24 '14 at 18:22
So it is probably a bug of version 8 which I'm also running. It would be great to find a workaround though. –  VLC Jun 24 '14 at 18:41
@mfvonh Just out of curiosity, does it work on MMA 9 if you run: FindEulerianCycle[DeBruijnGraph[4, 1], 20736]? –  VLC Jun 25 '14 at 8:35
Have you tried using FindHamiltonianCycle (with appropriate adjustments to the graph, etc.) to see if perhaps the bug is in FindEulerianCycle? (I'm on 9, so both work...) –  ciao Jun 25 '14 at 9:26

An idea for a workaround, but the Permutations is pretty inefficient and quickly burns through memory. Any ideas how to improve this?

DeBruijnGraph[3, 1] // EdgeList
Cases[
Permutations[List @@@ %],
x_ /; x[[;; -2, 2]] == x[[2 ;;, 1]]];
NestWhile[
RotateLeft,
#,
First@# != {1, 1} &] & /@ % // DeleteDuplicates;
Apply[DirectedEdge, %, {2}] // Length


24

-
This works for DeBruijnGraph[3,1], but it get stuck for DeBruijnGraph[4,1]. There are too many possible permutations I guess. There must be another way that is less memory demanding. –  VLC Jun 25 '14 at 8:55

I post this (it was an approach to a New York Times NumberPlay). Note there are major scaling issues for this (Hamiltonian cycles). Apologies if this is unhelpful.

Some examples:

f[k_, n_] := (k!)^k^(n - 1)/k^n
fun[alpha_, n_] := Module[{t, g, gp},
t = Tuples[alpha, n];
g = Map[Function[x, {#, Take[Join[#, {x}], -n]}], alpha] & /@ t;
gp = DirectedEdge @@@ Join @@ Map[StringJoin, g, {3}]]
seq[u_] := Module[{tk},
tk = u[[All, 1]];
StringJoin @@ {First@tk}~Join~(StringTake[#, -1] & /@ Rest@tk)]


Some tests: For 3 letter alphabet, 2 symbols: f[3,2] =24

grp = Graph[fun[{"a", "b", "c"}, 2],
];
ham = FindHamiltonianCycle[grp, All];
Column[seq /@ ham]


yields the desired 24:

Similarly f[4,2] is 20736 :

Length@FindHamiltonianCycle[Graph[fun[CharacterRange["a", "d"], 2]],
All]


also yields 20736.

And just for illustration f[4,1] =6 (as f[n,1]=(n-1)!).

Column[seq /@
FindHamiltonianCycle[Graph[fun[CharacterRange["a", "d"], 1]], All]]


-
Thanks for your contribution, but FindHamiltonianCycle on MMA 8 accepts only undirected graphs, so, unfortunately, this approach doesn't work for me. –  VLC Jun 25 '14 at 12:48
@VLC ok...did not appreciate that –  ubpdqn Jun 25 '14 at 13:08