## Pushing Buttons

This post is motivated by the New York Times Numberplay puzzle: Alex and the Button Lock

This can be approached in a number of ways. The answer is a De Bruijn sequence and although this could be solved with in-built commands in *Mathematica* and some further manipulation, I decided to create my own graph and play.

The two button lock can be solved by a sequence of 5 pushes, e.g. ABBAA or AABBA.

The three button case has 27 triples that must be coded in minimum sequence length.

In the following, an edge exists after adding a button push, viz. adding A to AAA leads to subsequence AAA, AAA->AAA (self loop), or adding B to AAA leads to subsequence AAB,AAA->AAB and so on.

The minimum sequence length with all the triples is a Hamiltonian cycle.

The following graphics illustrate: the underlying graph, a Hamiltonian cycle, “untangled” cycle and an animated gif of the untangling (apologies for the slowness and errors).

One solution (this can obviously be cycled and I have not explored other Hamiltonian cycles).

Hamiltonian Cycle

“Untangled”

Animated gif (“warts and all”):

One solution (therefore):

AAABAACABBBACBABCACCCBBCBCCAA

Some of the code used:

Setting up underlying graoh

gen = {"A", "B", "C"};

tup = Tuples[gen, 3];

ge = Map[Function[x, {#, Take[Join[#, {x}], -3]}], gen] & /@ tup; gr =

DirectedEdge @@@ Join @@ Map[StringJoin, ge, {3}];

grlist = Join @@ Map[StringJoin, ge, {3}];

grp = Graph[gr, VertexLabels -> Placed["Name", Center],

VertexSize -> 1, GraphLayout -> "SpringEmbedding",

VertexLabelStyle ->

Directive[White, Bold, FontFamily -> "Kartika", 16],

VertexStyle -> Red]

Finding and rendering solution:

hc = FindHamiltonianCycle[grp]

HighlightGraph[grp, First@hc, GraphHighlightStyle -> "Thick"]

hcl = hc[[1]][[All, 1]];

ans = StringJoin @@ {First@hcl}~Join~(StringTake[#, -1] & /@ Rest@hcl)

Graphical interface to untangle the Hamiltonian cycle

coord = PropertyValue[{grp, #}, VertexCoordinates] & /@ (StringJoin /@

tup);

DynamicModule[{pt = coord},

LocatorPane[Dynamic[pt],

Dynamic[r = Thread[StringJoin /@ tup -> pt];

Graphics[{{Blue, Arrowheads[{0, 0.05, 0}],

Arrow /@ (grlist /. r)}, {Red, Thick, Arrowheads[{0, 0.05, 0}],

Arrow /@ (Partition[hcl, 2, 1] /. r)}, {Text[

Framed[#, Background -> White], # /. r] & /@ (StringJoin /@

tup)}}]], Appearance -> None]]

There are no doubt better ways to do this. I also not I display path (not cycle) as this is the solution.