scheme48/scheme/big/either.scm

; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Nondeterminism, Prolog, or whatever you want to call it.  This is
; depth-first search implemented using call/cc.

; The fluid variable $FAIL is bound to a thunk to be called in case of failure.

(define $fail
  (make-fluid (make-cell
	       (lambda ()
		 (error "call to FAIL outside WITH-NONDETERMINISM")))))

(define (with-nondeterminism thunk)
  (let-fluid $fail
	     (make-cell (lambda ()
			  (error "nondeterminism ran out of choices")))
	     thunk))

; Call the current failure function.

(define (fail)
  ((fluid-cell-ref $fail)))

; For the alternation operator, Icon's a | b or McCarthy's (amb a b),
; we write (either a b).

(define-syntax either
  (syntax-rules ()
    ((either) (fail))
    ((either x) x)
    ((either x y ...)
     (%either (lambda () x) (lambda () (either y ...))))))

; 1. Save the current failure procedure and continuation.
; 2. Install a new failure procedure that restores the old failure procedure
;    and continuation and then calls THUNK2.
; 3. Call THUNK1.

(define (%either thunk1 thunk2)
  (let ((save (fluid-cell-ref $fail)))
    ((call-with-current-continuation
       (lambda (k)
	 (fluid-cell-set! $fail
			  (lambda ()
			    (fluid-cell-set! $fail save)
			    (k thunk2)))
	 thunk1)))))

; (one-value x) is Prolog's CUT operator.  X is allowed to return only once.

(define-syntax one-value
  (syntax-rules ()
    ((one-value x) (%one-value (lambda () x)))))

(define (%one-value thunk)
  (let ((save (fluid-cell-ref $fail)))
    (call-with-values thunk
		      (lambda args
			(fluid-cell-set! $fail save)
			(apply values args)))))

; (all-values a) returns a list of all the possible values of the
; expression a.  Prolog calls this "bagof"; I forget what Icon calls it.

(define-syntax all-values
  (syntax-rules ()
    ((all-values x) (%all-values (lambda () x)))))

(define (%all-values thunk)
  (let ((results '()))
    (either (let ((new-result (thunk)))
	      (set! results (cons new-result results))
	      (fail))
	    (reverse results))))