# Efficient backtracking with Mathematica

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.

-
It's hard to give a general solution for such a generic description. I do something similar to this in this answer to the Boggle question, where I start down a node and evaluate the partial candidates and reject the subtree if the partial candidate will never lead to a useful solution. I do this with using Condition. See the functions proceedQ and sowWord for the equivalents of reject/accept and output respectively. first/next are implemented via recursion... –  The Toad Jun 28 '12 at 2:26
@R.M I think I cannot use what you suggest. I cannot store my backtrack tree in a graph (or an analogue like an adjacency matrix) because it is huge. Imagine beginning a scan of chess positions by storing a graph will all the possible positions. Not possible. I haven't read Leonid's enormous answer to the question you reference, but if it also stores a representation of the search space, I can't use it. –  becko Jun 28 '12 at 3:21
Anything doable by procedural programming can be done recursively (and functionally). And then the symmetry comes to an end. Iterative (procedural) programming is the way to go if you have severe memory constraints. No le pidas peras al olmo –  belisarius Jun 28 '12 at 4:05
@belisarius I think we need to accumulate more non-trivial problems solved by some variant of backtracking, and then see if we have some common implementation patterns (e.g. using linked lists + recursion, etc). I don't believe that we can totally separate the backtracking pattern from implementation in Mathematica, given that efficiency is always one of the main goals, and (particularly in Mathematica) it depends drastically on implementation details (such as the choice of data structures, etc). –  Leonid Shifrin Jun 28 '12 at 12:14
I just discovered the guidelines tag and I think it goes with this question. @DanielLichtblau I do not need to store all the possible chess positions to search them. I just need methods that given a chess position, return other positions to explore (next and first) in an organized fashion. –  becko Jun 29 '12 at 2:09

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] := {} ==
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}]],
({} ==
x_ \[UndirectedEdge] x_, \[Infinity], 1]) &,
({} ==
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 ->
`