Create a gist now

Instantly share code, notes, and snippets.

@nikodemus /bt.lisp
Last active Aug 29, 2015

What would you like to do?
Showing why conditions are a bad match for doing backtracking -- all you need is CATCH/THROW and a special variable.
;;;; 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)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment