75 lines
2.0 KiB
Scheme
75 lines
2.0 KiB
Scheme
|
; Copyright (c) 1993-2001 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))))
|