Home > Uncategorized > Pushing Buttons

## 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.

Categories: Uncategorized
1. No comments yet.
1. No trackbacks yet.