4
$\begingroup$

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.

$\endgroup$
6
$\begingroup$

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.

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

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} *)
| improve this answer | |
$\endgroup$
  • $\begingroup$ This was really helpful, but I hope you don't mind I'm changing the accepted answer since that version is a lot faster. $\endgroup$ – Juan Jan 30 '16 at 4:46
  • $\begingroup$ I don't mind at all, it's a much better solution. $\endgroup$ – Simon Woods Jan 30 '16 at 7:48

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.