haskeem-0.7.9: choice.scm

; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>
; $Id: choice.scm,v 1.2 2009-07-11 04:32:54 uwe Exp $
; BSD3

; Non-deterministic programming: my version of (amb) with slightly different
; names, except this is more limited in that I can't call (fail) arbitrarily
; far into the future.

; Still TODO: make it work with streams as well as lists: that means that in
; the call to (,loop (cdr ,chs)) near the bottom of the macro, we might need
; to force a promise. ----> TODO^2: need to be able to query if something is
; a promise: write (promise?) primitive

; With streams, there is the issue that an infinite stream locks in all the
; previous choices, since this stuff does things in order from innermost to
; outermost: if an inner set of alternatives is infinite, it'll take infinite
; time to explore it all.

; Stack of escapers for the different choices

(define *choice-stack* (make-stack))
(define *choice-fail* (gensym))

; This function rejects the current set of choices: it pops the top
; escaper off the stack, then calls it with the failure symbol as its
; arg.  The failure symbol is gensym'ed, so it can't be generated by
; the user; so there is no worry about collisions with something the
; user might want to return.

(define (bad-choice)
  (if (*choice-stack* 'empty?)
      (raise "All out of choices!")
      ((*choice-stack* 'pop) *choice-fail*)))

; This macro does the binding of the variable sym to one of the choices given,
; then executes the body. If the body calls (bad-choice), this loops to the
; next choice. If the current set of choices is exhausted, the next-lower
; choice gets reset, and so on, until we run out of choices, in which case
; the (bad-choice) function raises an(other) exception.

(defmacro (let-choice sym choices . body)
  (let ((ret (gensym))
	(cont (gensym))
	(chs (gensym))
	(loop (gensym)))
    `(letrec* ((,loop (lambda (,chs)
			(if (null? ,chs)
			    (bad-choice)
			    (let* ((,sym (car ,chs))
				   (,ret (let/cc1 ,cont
					   (*choice-stack* 'push ,cont)
					   ,@body)))
			      (if (eqv? ,ret *choice-fail*)
				  (,loop (cdr ,chs))
				  (begin (*choice-stack* 'pop)
					 ,ret)))))))
	      (,loop ,choices))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Some simple examples

(define (require pred?) (if (not pred?) (bad-choice)))

(define (parlor-trick n)
  (let-choice j '(1 2 3 4 5)
    (let-choice i '(1 2 3 4 5)
      (require (= (+ i j) n))
      (list i j))))

(display (parlor-trick 4))
(newline)

(display (parlor-trick 6))
(newline)

(display (parlor-trick 10))
(newline)

(display (parlor-trick 11))
(newline)