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

nytdebgr

 

Hamiltonian Cycle

 

nytdebhc

“Untangled”

nytdeb

 

 

Animated gif (“warts and all”):

 

nytbutt

 

 

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.

Advertisements
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 )

Twitter picture

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

Facebook photo

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

Google+ photo

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

Connecting to %s

%d bloggers like this: