# How can I make this code to count Hamiltonian paths faster?

I have this very basic code to count Hamiltonian paths in a graph:

privateCountHamiltonians =
Function[{vertices, current, visited}, Module[{newVisited }, (
newVisited = Append[visited, current];
If[
Length[newVisited] == Length[vertices],
1,
Total[ Map[
If[! MemberQ[newVisited, #],
privateCountHamiltonians[vertices, #, newVisited], 0] &,
vertices[[current]]
]]
])
]];

makeVertices[edges_] := Module[{list}, (
list = ConstantArray[{}, Max[edges]];
Scan[Function[edge, (
AppendTo[list[[edge[]]], edge[]];
AppendTo[list[[edge[]]], edge[]];
list
)], edges];
list
)];

countHamiltonians[edges_] := Module[{vertices}, (
vertices = makeVertices[edges];
Total[
Map[privateCountHamiltonians[vertices, #, {}] &,
Range[1, Length[vertices]]]]
)];


The edges argument must have the form {{1, 2}, {2, 3}, ...} where each item inside represents an edge. The bottleneck is privateCountHamiltonians since is where recursion occurs. I thought using Combinatorica's HamiltonianPath would be more effective, but surprisingly that one is way slower than mine, at least on not so big graphs, as per this code:

<< Combinatorica
g = CombinatoricaGridGraph[2, 4];
Timing[countHamiltonians[CombinatoricaEdges[g]]]
Timing[Length[CombinatoricaHamiltonianPath[g, All]]]


Which yielded:

{0.015625, 28}
{21.093750, 28}


I'm not hoping to implement some of the existing advanced algorithms, but since I'm new to Mathematica, I wonder if there is some simple things I'm overlooking that could make my code run faster.

You can also use FindHamiltonianCycle.

To convert Hamiltonian path problem to Hamiltonian cycle problem, just add one vertex and connect it to all other vertices. After that just run FindHamiltonianCycle[g, All]

For example,

countHamiltonianPaths[g_] :=
Length[
FindHamiltonianCycle[
All]
]


Test:

g = GridGraph[{4, 5}];

AbsoluteTiming[countHamiltonianPaths[g]]
(* {0.005012, 1006} *)


Note that FindHamiltonianCycle for undirected graphs doesn't consider the direction of cycles ,i.e, {1,2,3} and {3,2,1} are regarded as the same cycles. That's why the number is the half of your function.

• This is neat. Wonder why they didn't implement it this way in combinatorica. – Juan Jan 30 '16 at 4:41
• Nice solution, very clever. – Simon Woods Jan 30 '16 at 7:43
• Can you take a look at this? mathematica.stackexchange.com/q/110102/12 Is it a bug? I am not familiar with k-plexes. – Szabolcs Mar 15 '16 at 19:13

This is the same basic algorithm but in my own style. It runs only about twice as fast as yours, but hopefully it will be of interest anyway.

The recursive function count maintains the current vertex, the adjacency list $a$ and a counter $i$. At each call the current vertex is removed from the adjacency list and the function recursively scanned over the available next vertices. The counter starts at $n$ (the number of vertices) and decreases by 1 on each recursive call, so when it hits 1 a Hamiltonian path has been completed. I use Sow and Reap to collect the paths.

mycount is the main function. Note that I have written it to work with built-in Graph expressions (not combinatorica) and I'm using AdjacencyMatrix to get the adjacency list.

count[current_, a_, i_] := Module[{b = DeleteCases[a, current, {2}]},
Scan[count[#, b, i - 1] &, b[[current]]]; 0]

count[_, _, 1] := Sow

mycount[g_Graph] := Module[{a, n},
n = Length[a];
Total[Reap[count[#, a, n] & /@ Range[n]], -1]]


Testing:

g = GridGraph[{4, 5}];

AbsoluteTiming[mycount[g]]
(* {3.73159, 2012} *)

AbsoluteTiming[countHamiltonians[List @@@ EdgeList[g]]]
(* {7.39043, 2012} *)

• This was really helpful, but I hope you don't mind I'm changing the accepted answer since that version is a lot faster. – Juan Jan 30 '16 at 4:46
• I don't mind at all, it's a much better solution. – Simon Woods Jan 30 '16 at 7:48