Showing why conditions are a bad match for doing backtracking -- all you need is CATCH/THROW and a special variable.

bt.lisp

;;;; In response to:
;;;;
;;;;    http://www.reddit.com/r/lisp/comments/3710zq/directed_procrastination_backtracking_with_the/
;;;;    http://directed-procrastination.blogspot.se/2011/05/backtracking-with-common-lisp-condition.html
;;;;
;;;; Demonstrating why one should not use conditions for this kind of stuff,
;;;; instead using the dynamic binding and unwinding facilities on which the
;;;; condition system is built. The author's backtracking system doesn't compare
;;;; badly to Screamer because his is simple: it compares badly because using
;;;; conditions is a bad match for the task.
;;;;
;;;; (The original post is from 2011, and I expect the author is by now
;;;; cognizant of all I have to say -- just wanted to get the story on reddit
;;;; straight.)
;;;;
;;;; COND-BT is a simple backtracking system discussed in the linked page,
;;;; which uses the condition system.
;;;;
;;;; TRIVIAL-BT is essentially otherwise identical, except it uses a single
;;;; special variable and CATCH/THROW instead of the condition system.
;;;; TRIVIAL-BT performs an order of maginitude better, with zero additional
;;;; code complexity.
;;;;
;;;; NB: If you want to use this code for backtracking, you want to consider
;;;; the semantics of WITH-BACKTRACKING returning normally, instead of via
;;;; SUCCESS/FAIL. That bit is a bit grotty right now.
;;;;
;;;; CL-USER> (defvar *cond-res* (time (cond-bt::pyth-triples 100)))
;;;; Evaluation took:
;;;;   0.200 seconds of real time
;;;;   0.203125 seconds of total run time (0.203125 user, 0.000000 system)
;;;;   [ Run times consist of 0.016 seconds GC time, and 0.188 seconds non-GC time. ]
;;;;   101.50% CPU
;;;;   478,478,174 processor cycles
;;;;   141,144,752 bytes consed
;;;;
;;;; CL-USER> (assert (equal *cond-res* (time (trivial-bt::pyth-triples 100))))
;;;; Evaluation took:
;;;;   0.028 seconds of real time
;;;;   0.015625 seconds of total run time (0.015625 user, 0.000000 system)
;;;;   57.14% CPU
;;;;   65,926,654 processor cycles
;;;;   15,695,872 bytes consed

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload "iterate"))

;;;; COND-BT contains code from
;;;; http://directed-procrastination.blogspot.se/2011/05/backtracking-with-common-lisp-condition.html
;;;; -- just copy-pasted, with missing definitions added in, etc.
(defpackage :cond-bt
  (:use :cl :iterate))

(in-package :cond-bt)

;; Define a parent type for flexibility...
(define-condition 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) )

(defvar *solutions*)

(defvar *mode*)

(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) )))

(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) ))))

(defun pyth-triples (n)
  (with-backtracking (find-all)
    (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) ))))

;;;; TRIVIAL-BT takes COND-BT and replaces the use of conditions with a single
;;;; special variable and CATCH/THROW.
(defpackage :trivial-bt
  (:use :cl :iterate))

(in-package :trivial-bt)

(defvar *success*)

(defun success (&rest args)
  (apply *success* args))

(defun fail ()
  (throw 'backtrack nil))

(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 ((option-list (gensym))
        bt-var 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)
                    (block nil
                      (catch 'backtrack
                        (return (bt-let* ,rest-bindings ,@body)))
                      (if ,option-list
                          (try-with (pop ,option-list))
                          (throw 'backtrack nil)))))
               (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 ((success (gensym "SUCCESS"))
        (solutions (gensym "SOLUTIONS")))
    `(let (,@(when (eq 'find-all mode)
               `(,solutions)))
       (block nil
         (flet ((,success (&rest args)
                  ,@(ecase mode
                     (find-one
                      `((return args)))
                     (find-all
                      `((push args ,solutions)
                        (throw 'backtrack nil))))))
           (let ((*success* #',success))
             (catch 'backtrack
               ,(if (eq 'find-one mode)
                    `(return (progn ,@body))
                    `(progn ,@body)))
             ,(if (eq 'find-one mode)
                  `(error "No solutions found.")
                  `,solutions)))))))

(defun pyth-triples (n)
  (with-backtracking (find-all)
    (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)))))