Efficient backtracking with Mathematica

Question

Backtracking is a general algorithm for finding all (or some) solutions to some computational problem, that incrementally builds candidates to the solutions, and abandons each partial candidate c ("backtracks") as soon as it determines that c cannot possibly be completed to a valid solution. (from Wikipedia)

In pseudo-code, a backtracking algorithm looks something like this:

 procedure bt(c)
   if reject(P,c) then return
   if accept(P,c) then output(P,c)
   s ← first(P,c)
   while s ≠ Λ do
     bt(s)
     s ← next(P,s)

Here,

1. root(P): return the partial candidate at the root of the search tree.
2. reject(P,c): return true only if the partial candidate c is not worth completing.
3. accept(P,c): return true if c is a solution of P, and false otherwise.
4. first(P,c): generate the first extension of candidate c.
5. next(P,s): generate the next alternative extension of a candidate, after the extension s.
6. output(P,c): use the solution c of P, as appropriate to the application.

The backtracking algorithm then starts with the call bt(root(P)).

I'm trying to program this as efficiently as possible in Mathematica. I have already coded the pertinent root, reject, accept, first, and next functions. Since I only need to obtain one solution, I am doing the output through a Throw, Catch combo.

Given that one has the basic logic of root, reject, ..., already coded, are there alternative ways to program the backtracking loop (procedure bt above) in Mathematica?

What I have in mind is a substitution of while with something more Mathematica friendly, such as Fold or Map, but I have no idea of how to do this.

Answer 1

Backtracking is never efficient so I would suggest always using C for this. However if you must do this in mathematica, here is an example of the generalized backtrack algorithm (as taken almost literally from the Combinatorica` package's Backtrack function) specifically applied to graph coloring:

backtrack[space_List, partialQ_, solutionQ_, flag_: 1] := 
 Module[{n = Length[space], all = {}, done, index, v = 2, solution},
    index = Prepend[Table[0, {n - 1}], 1];
    Monitor[While[v > 0,
            done = False;
            While[! done && (index[[v]] < Length[space[[v]]]),
                   index[[v]]++;
                   done = partialQ[Solution[space, index, v]];
                        ];
            If[done, v++, index[[v--]] = 0];
            If[v > n,
                solution = Solution[space, index, n];
                If[solutionQ[solution], 
                    If[SameQ[flag, All],
                            AppendTo[all, solution],
                            all = solution; v = 0;
                            ]
                     ]
                  v--;
                ]
        ], index];
    all
  ]


Solution[space_List, index_List, count_Integer] :=

  Module[{i}, Table[space[[i, index[[i]]]], {i, count}]];

ProperColorQ[color_List] := {} == 
   Cases[EdgeList[gr] /. Thread[Range[Length[color]] -> color], 
    x_ \[UndirectedEdge] x_, \[Infinity], 1];


Ccoloring[c_Integer, g_Graph] :=

 Module[{coloring, x, v = Length[VertexList[g]]},
  coloring = backtrack[Join[{{1}}, Table[Range[c], {i, v - 1}]],
    ({} == 
       Cases[EdgeList[g] /. Thread[Range[Length[#]] -> #], 
        x_ \[UndirectedEdge] x_, \[Infinity], 1]) &,
    ({} == 
       Cases[EdgeList[g] /. Thread[Range[Length[#]] -> #], 
        x_ \[UndirectedEdge] x_, \[Infinity], 1]) &,
    One]
  ]

chromaticNumber[g_Graph /; ConnectedGraphQ[g]] :=
 Module[{c, i = 2},
  c = Ccoloring[i, gr];
  While[c == {}, c = Ccoloring[i, gr]; i++];
  {i - 1,
   Graph[EdgeList[g],
    VertexLabels -> 
     Table[i -> Placed[c[[i]], Center], {i, Length[VertexList[g]]}], 
    VertexStyle -> 
     Thread[Range[Length[VertexList[g]]] -> 
       Hue /@ Rescale[c, {0, 0.9}]]]}
  ]


gr = RandomGraph[BernoulliGraphDistribution[13, 0.5], 
  VertexLabels -> "Name"]
chromaticNumber[gr] // AbsoluteTiming