# 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[[1]]]], edge[[2]]];
AppendTo[list[[edge[[2]]]], edge[[1]]];
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
Commented Jan 30, 2016 at 4:41
• Nice solution, very clever. Commented Jan 30, 2016 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. Commented Mar 15, 2016 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[1]

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
Commented Jan 30, 2016 at 4:46
• I don't mind at all, it's a much better solution. Commented Jan 30, 2016 at 7:48

For posterity (and anyone interested) I extended @halmir's solution to count all hamiltonian paths that start from a specific vertex:

allHamiltonianPaths[g0_, s0_] := Module[{g = g0, s = s0},
g = DirectedGraph[g];
g = EdgeDelete[g, _ \[DirectedEdge] s];
g = EdgeAdd[g, (# -> s) &
/@ Complement[VertexList[g], {s}]];
paths = FindHamiltonianCycle[g, All];
(First /@ #) & /@ paths
]

• In the way that you have written this answer, it is not clear if it is a complete answer or an attempted generalisation for which you need help.
– bmf
Commented Apr 24 at 3:10
• You're correct, it wasn't my intention to ask for help, I was offering a complete solution. Commented Apr 27 at 23:30