Prolog-style backtracking in Scheme using continuations

backtrack.scm

;; vim: set sts=2 sw=2 et lisp sm :

(define *bt-chain* '())

(define (bt-fork starter . remains)
  (call/cc (lambda (ret)
             (set! *bt-chain*
               (append
                 (map (lambda (x)
                        `(,ret . ,x))
                      remains)
                 *bt-chain*))
             starter)))

(define (bt-retry)
  (if (null? *bt-chain*)
    #f
    (let* ((contpair (car *bt-chain*))
           (cont     (car contpair))
           (retval   (cdr contpair)))
      (set! *bt-chain* (cdr *bt-chain*))
      (apply cont `(,retval)))))

(define (bt-find-all fn)
  (let ((acc '()))
    (let ((result (fn)))
      (begin
        (if result
          (begin
            (set! acc (cons result acc))
            (bt-retry)))
        acc))))

(define (get-valid-number peak)
  (do ((acc (list) (cons i acc))
       (i 1 (+ i 1)))
    ((> i peak) (apply bt-fork acc))))

(display
  (bt-find-all
    (lambda ()
      (let ((x (get-valid-number 100)))
        (if (= (modulo 100 x) 0)
          x
          (bt-retry))))))
(newline)

;; Result:
;; (1 2 4 5 10 20 25 50 100)