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







Animated gif (“warts and all”):





One solution (therefore):




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 /@
DynamicModule[{pt = coord},
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.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

%d bloggers like this: