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

Question

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 = Combinatorica`GridGraph[2, 4];
Timing[countHamiltonians[Combinatorica`Edges[g]]]
Timing[Length[Combinatorica`HamiltonianPath[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.

Answer 1

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[
       AdjacencyGraph[PadRight[AdjacencyMatrix[g], (VertexCount[g] + 1) {1, 1}, 1]], 
    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.

Answer 2

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},
  a = AdjacencyMatrix[g]["AdjacencyLists"];
  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} *)

Answer 3

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
]