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]

## 2 comments:

Good to see you back, and kicking ass

One is glad to be of service.

Post a Comment