source: project/release/3/amb/amb-base.scm @ 18200

Last change on this file since 18200 was 112, checked in by Thomas Chust, 15 years ago

v1.2.0: Non-determinism now optional, better controllability of scope

  • amb is now called amb/random
  • amb does the same as before except it doesn't shuffle the list of expressions any more
  • an amb-find macro has been added
File size: 1.5 KB
Line 
1;;;; amb-base.scm
2;;;; The backing code doing all the work for amb.scm
3
4(define-extension amb
5  (export
6   amb-failure-continuation
7   amb-thunks
8   amb-find-thunk amb-collect-thunk))
9
10(eval-when (compile)
11  (declare
12   (usual-integrations)
13   (fixnum-arithmetic)))
14
15(define (amb-exhausted)
16  (signal
17   (make-composite-condition
18    (make-property-condition
19     'exn
20     'message "expression tree exhausted" 'location 'amb 'arguments '())
21    (make-property-condition
22     'amb))))
23
24(define amb-failure-continuation
25  (make-parameter amb-exhausted))
26
27(define (amb-thunks thunks)
28  (let ((afc (amb-failure-continuation)))
29    (call-with-current-continuation
30     (lambda (arc)
31       (let loop ((tt thunks))
32         (if (null? tt)
33             (begin
34               (amb-failure-continuation afc)
35               (afc))
36             (begin
37               (amb-failure-continuation (lambda () (loop (cdr tt))))
38               (arc ((car tt))))))))))
39
40(define (amb-find-thunk thunk #!optional (failure amb-exhausted))
41  (call-with-current-continuation
42   (lambda (q)
43     (parameterize ((amb-failure-continuation (lambda () (q (failure)))))
44       (thunk)))))
45
46(define (amb-collect-thunk thunk)
47  (let ((afc #f))
48    (dynamic-wind
49        (lambda () (set! afc (amb-failure-continuation)))
50        (lambda ()
51          (call-with-current-continuation
52           (lambda (q)
53             (let* ((root (list #f))
54                    (head root))
55               (amb-failure-continuation (lambda () (q (cdr root))))
56               (set-cdr! head (list (thunk)))
57               (set! head (cdr head))
58               ((amb-failure-continuation))))))
59        (lambda () (amb-failure-continuation afc)))))
Note: See TracBrowser for help on using the repository browser.