Backtracking with the Common Lisp Condition System

The Common Lisp condition system is a pretty nice facility. I use it extensively in my work. One of its strongest benefits from my point of view is the smooth transition between programmatic error handling and interactive error handling.

The Common Lisp condition system is capable of much more than handling errors, though. However, I have yet to find time to really learn its "ins and outs". I decided try out a project using the condition system in a way that most wouldn't. Here I will show you how to use the CL condition system to implement a backtracking framework.

Update (June 2015): You can read some Reddit discussion on this. Nikodemus Siivola provided a superior roll-your-own backtracking method, pointing out that using the condition system is wasteful for this purpose. He is right, of course.

The Basic Idea

A failure of an assertion is a condition. For example, if we co-opt the error condition for our purposes…

(let ((options '(2 4 6 7 2)))  ; These are our options
  (labels
      ((fail (&rest args)    ; If we fail, for what ever reason
         (error "Failed: ~A" args) )
       (success (&rest args) ; If we find a successful condition, call this
         args )
       ;; This is our re-entry point
       (retry-with (x)
         (handler-case
             ;; This is the actual body of our function
             (if (oddp x)
                 (success x)
                 (fail x) )
           ;; If we find an error...
           (error (cond)
             (warn "Failed: ~A" cond)
             (if options
                 ;; ...we recall the function
                 (retry-with (pop options))
                 (error "No solution found") )))))
    (retry-with (pop options)) ))

All we need is to write a macro that translates the following into that.

(let ((x '(2 4 6 7 2)))
  (if (oddp x)
      (success x)
      (fail x) ))

Of course, using the error condition is a bit of a faux pas. Instead, let's define our own condition type, failure. Finding a solution to the problem could also be a condition, if we choose, and we will this time. While we're at it, we'll define two functions, fail and success, that are pretty self explanatory.

;; Define a parent type for flexibility...
(define-condition success (backtracking-condition) ())
;; NOTE can hold some data about how it failed
(define-condition failure (backtracking-condition) ((note :initarg :note)))
;; VALUE holds the solution
(define-condition success (backtracking-condition) ((value :initarg :value)))

(defun fail (&rest args)
  "For whatever reason, this has failed.  Backtrack."
  (signal 'failure :note args) )
(defun success (&rest args)
  "We found a solution.  Either return it, or add it onto the list of solutions
depending on the value of *MODE* \(as set by WITH-BACKTRACKING)."
  (cond ((eql *mode* 'find-one)
         (signal 'success :value args) )
        ((eql *mode* 'find-all)
         (push args *solutions*)
         (signal 'failure :value args) )))

These really don't do anything by themselves. We need to define a special way to bind nondeterministic variables, or variables that will change their values during the search. I've done this with the bt-let* macro, which is the real meat and potatoes of this. It behaves like let* except that it recognizes two special forms, one-of and one-in (one for objects, one for a list of objects), that perform these nondeterministic bindings. It's not perfect, these forms have to be in simple locations, but it works. We have to have a macro that sets up an environment to do things like handle success conditions, control the way the search is performed, and set up variables that save solutions that are found. This environment is set up with with-backtracking.

(defmacro bt-let* (bindings &body body)
  "Like LET*, but if you find a special nondeterministic choice form like ONE-OF
or ONE-IN, treat it specially by setting up the framework for nondeterministic
search."
  (let (bt-var
        (option-list (gensym))
        rest-bindings )
    `(let* ,(iter (for (binding . rest) on bindings)
                  (until bt-var)
                  (cond ((and (consp binding)
                              (consp (second binding))
                              (eql 'one-of (first (second binding))) )
                         (setf bt-var (first binding)
                               rest-bindings rest )
                         (collect (list option-list
                                        (cons 'list (rest (second binding))) )))
                        ((and (consp binding)
                              (consp (second binding))
                              (eql 'one-in (first (second binding))) )
                         (setf bt-var (first binding)
                               rest-bindings rest )
                         (collect (list option-list
                                        (second (second binding)) )))
                        (t (collect binding)) ))
       ,(if bt-var
            `(labels
                 ((try-with (,bt-var)
                    (handler-case (bt-let* ,rest-bindings ,@body)
                      (failure ()
                        (if ,option-list
                            (try-with (pop ,option-list))
                            (fail) )))))
               (try-with (pop ,option-list)) )
            `(progn ,@body) ))))

(defmacro with-backtracking ((mode) &body body)
  "Set up the environment where backtracking can be performed.  MODE can be set
as one of FIND-ONE or FIND-ALL in order to specify where just the first or all
possible solutions should be returned."
  `(let ((*mode* ',mode)
         *solutions* )
     (handler-case
         (progn ,@body)
       (failure ()
         (cond ((eql 'find-one *mode*)
                (error "No solutions found.") )
               ((eql 'find-all *mode*)
                *solutions* )))
       (success (cond)
         (slot-value cond 'value) ))))

Pythagorean Triples

Pythagorean Triples are three integers, $a$, $b$, and $c$, that satisfy the equation, $a^{2} + b^{2} = c^{2}$. In other words, $a$, $b$, and $c$ are the lengths of the sides of a right triangle.

(defun pyth-triples (n)
  (with-backtracking
    (bt-let* ((a (one-in (iter (for i from 1 below n) (collect i))))
              (b (one-in (iter (for i from 1 below n) (collect i))))
              (c (one-in (iter (for i from 1 below n) (collect i)))) )
      (if (= (+ (* a a) (* b b)) (* c c))
          (success (list a b c))
          (fail) ))))

Performance

Common Lisp already has a pretty good backtracking library, Screamer. We can compare the performance of our library with Screamer. Here's our version…

CL-USER> (time (pyth-triples 100))
Evaluation took:
  0.892 seconds of real time
  0.880000 seconds of total run time (0.840000 user, 0.040000 system)
  [ Run times consist of 0.030 seconds GC time, and 0.850 seconds non-GC time. ]
  98.65% CPU
  2,135,319,408 processor cycles
  345,196,992 bytes consed

…and the Screamer version?

CL-USER> (time (screams::pythagorean-triples 100))
Evaluation took:
  0.060 seconds of real time
  0.060000 seconds of total run time (0.060000 user, 0.000000 system)
  100.00% CPU
  143,821,854 processor cycles
  490,032 bytes consed

So, looks like around a factor of ten. Not so good, but maybe it's not so bad that people can't use it. Now, it might seem like exhaustive search is the time, if there ever is one, where we should be the most concerned about performance. That has some truth, but we should also remember that if we ever really rely on the exhaustive search to do the work, we probably have already lost the battle. Being ten times faster will allow you to handle an input size one larger than the slow version. I like to use nondeterminism to write an algorithm that's guaranteed correct, then improve from there. So, perhaps the slow version isn't unusable after all.

Conclusions

Well, this method is a pretty simple method of implementing backtracking in Common Lisp. It is less performant and versatile than Screamer, but Screamer is a pretty gigantic library.