Enigma 1468

I have had to skip a couple of Enigmas because there hasn't been time to do them. I may come back to them later, but don't hold your breath.

Here is how Mathematica can be used to solve New Scientist Enigma number 1468 in the 10 November 2007 issue. This solution draws heavily on the graph manipulation facilities in the Combinatorica package. Most of the work involves setting up an appropriate graph to represent the problem, after which the solution to the problem drops out by simply calling the HamiltonianCycle function.

Load the Combinatorica package for doing operations on graphs.

Needs["Combinatorica`"];

Define a function for computing 2D indexing from 1D indexing on a 6 by 6 array.

indices[i_] := {Quotient[i+5,6], Mod[i,6,1]};

Define a function for computing if a pair of nodes is adjacent in a Manhattan metric. You could use GridGraph[6,6] instead, but I want to show how to use an explicit adjacency function here.

manhattan[{i1_,j1_}, {i2_,j2_}] := Abs[i1-i2]==1&&j1==j2 || Abs[j1-j2]==1&&i1==i2;

Define a function for testing if adjacency between a pair of nodes is excluded.

exception[{i1_,j1_}, {i2_,j2_}] := Apply[Or, Map[{i1,j1}==#[[1]] && {i2,j2}!=#[[2]]&, {{{2,3},{1,3}}, {{3,4},{4,4}}, {{5,3},{6,3}}, {{5,6},{5,5}}}]];

Use these adjacency functions to define an adjacency matrix.

adjacency = SparseArray[{{_, _}?((manhattan[#1,#2] && Not[exception[#1,#2]])&[indices[#[[1]]], indices[#[[2]]]]&)->1}, {36,36}];

Use this adjacency matrix to define an adjacency function.

edge[from_, to_] := adjacency[[from, to]]==1;

Define the layout (i.e. embedding) of the graph.

coordinates = Table[index->{{0,1},{-1,0}}.indices[index], {index,36}];

Display the graph.

GraphPlot[g=MakeGraph[Range[36],edge], DirectedEdges->True, VertexLabeling->True, VertexCoordinateRules->coordinates]

[Output omitted]

Compute all of the Hamiltonian cycles in the graph. There is only one, as expected.

cycles = HamiltonianCycle[g,All]

[Output omitted]

Extract the edges in the Hamiltonian cycle.

cycleedges = Partition[cycles[[1]],2,1];

Define a function for drawing only the edges that lie on the Hamiltonian cycle.

cycleedge[coords_, vertices_, label_] := If[MemberQ[cycleedges,vertices], {Red,Thickness[0.01],Arrow[coords]}, {}];

Display the Hamiltonian cycle.

GraphPlot[MakeGraph[Range[36],edge], VertexLabeling->True, VertexCoordinateRules->coordinates, EdgeRenderingFunction->cycleedge]

[Output omitted]

Rotate the Hamiltonian cycle so that it starts at the correct node.

cycles2 = RotateLeft[#, Position[#,11][[1,1]]-1]&[Most[cycles[[1]]]]

[Output omitted]

Compute which positions in the Hamiltonian cycle fall on the nodes labelled "ENIGMA".

Map[Position[cycles2,#][[1,1]]&, Range[19,24]]

[Solution omitted]