Enigma 1469

Here is how Mathematica can be used to solve New Scientist Enigma number 1469 in the 17 November 2007 issue.

WARNING: See the comments for details. There is an error in the solution given below that I need to fix. In working on a fix I discovered a bug in the HamiltonianCycle function in Mathematica's Combinatorica package (this bug has been acknowledged by the author of the Combinatorica package) which destroyed any chance of my fix working fully correctly, although the correct solution to Enigma 1469 could be seen lurking in amongst the erroneous clutter. I will abandon my solution to Enigma 1469 because it has absorbed too much of my time already, and the discovery of the HamiltonianCycle bug can stand as a testimonial to the cleverness of Enigma 1469. I suppose that I ought to leave the rest of this posting intact otherwise the comments would be orphaned, and also there are some useful techniques illustrated in my erroneous solution.

Load the Combinatorica package.
Needs["Combinatorica`"];

Derive the formula for triangular numbers.
triangularformula=Sum[i,{i,n}]
1/2 n (1 + n)

Compute a list of all triangular numbers less than 1000.
triangularnumbers = Table[triangularformula, {n,44}]
{1, 3, 6, 10, 15, 21, 28, 36, 45, 55, 66, 78, 91, 105, 120, 136, 153, 171, 190, 210, 231, 253, 276, 300, 325, 351, 378, 406, 435, 465, 496, 528, 561, 595, 630, 666, 703, 741, 780, 820, 861, 903, 946, 990}

Convert this to the corresponding list of lists of digits.
triangulardigits = IntegerDigits[triangularnumbers]
{{1}, {3}, {6}, {1, 0}, {1, 5}, {2, 1}, {2, 8}, {3, 6}, {4, 5}, {5, 5}, {6, 6}, {7, 8}, {9, 1}, {1, 0, 5}, {1, 2, 0}, {1, 3, 6}, {1, 5, 3}, {1, 7, 1}, {1, 9, 0}, {2, 1, 0}, {2, 3, 1}, {2, 5, 3}, {2, 7, 6}, {3, 0, 0}, {3, 2, 5}, {3, 5, 1}, {3, 7, 8}, {4, 0, 6}, {4, 3, 5}, {4, 6, 5}, {4, 9, 6}, {5, 2, 8}, {5, 6, 1}, {5, 9, 5}, {6, 3, 0}, {6, 6, 6}, {7, 0, 3}, {7, 4, 1}, {7, 8, 0}, {8, 2, 0}, {8, 6, 1}, {9, 0, 3}, {9, 4, 6}, {9, 9, 0}}

Construct the adjacency matrix of allowed adjacencies between triangular numbers.
adjacencies = Outer[(If[Last[#1]==First[#2], 1, 0])&, triangulardigits, triangulardigits, 1];

Convert the adjacency matrix to a set of rules that allow me to add a "tooltip" to each node of the corresponding the graph so that it can be explored by hovering the mouse over the graph: (1) extract the sparse array form of the adjacency matrix, (2) convert the sparse array into a list of rules for which graph nodes are linked by edges, (3) add a tooltip to each graph node.
adjacencies2 = SparseArray[adjacencies];
adjacencies3 = ((adjacencies2//ArrayRules//Most) /. HoldPattern[{i_,j_}->1] :> i->j);
adjacencies4 = adjacencies3 /. x_?IntegerQ :> Tooltip[x, triangularnumbers[[x]]];

Display the graph with tooltips.
GraphPlot[adjacencies4, DirectedEdges->True]
[Output omitted]

Convert the adjacency matrix to a graph. I need this representation in order to use graph manipulation algorithms.
g = FromAdjacencyMatrix[adjacencies, Type->Directed];

Extract the longest cycle in the graph, and extract the edges within this cycle.
longestcyclenodes = ExtractCycles[g]//Sort//Last//Most;
longestcycleedges = Partition[longestcyclenodes,2,1,{1,1}];

Display the graph with the longest cycle highlighted.
GraphPlot[adjacencies4, EdgeRenderingFunction -> (If[MemberQ[longestcycleedges,#2], {Red,Arrow[#1]}, {Opacity[0.3],LightGray,Arrow[#1]}]&)]

Convert the longest cycle to the corresponding a list of triangular numbers, and thence the sequence of digits encountered when going around the cycle.
longestcyclenumbers = triangularnumbers[[longestcyclenodes]];
longestcycledigits = longestcyclenumbers//IntegerDigits//Flatten
[Output omitted]

Compute the number of digits encountered when going around the longest cycle.
longestcycledigits//Length
[Solution omitted]