source: project/release/4/amb/trunk/amb.scm @ 13799

Last change on this file since 13799 was 13799, checked in by Kon Lovett, 12 years ago

Save.

File size: 2.3 KB
Line 
1;;;; amb.scm
2;;;; The fundamental non-deterministic backtracking operator
3
4(declare
5  (usual-integrations)
6  (fixnum-arithmetic))
7
8(module amb (;export
9  amb
10  amb/random
11  amb-find
12  amb-collect
13  amb-assert
14  amb-failure-continuation
15  amb-thunks
16  amb-find-thunk amb-collect-thunk)
17
18(define-syntax amb
19  (syntax-rules ()
20    ((amb)
21     ((amb-failure-continuation)))
22    ((amb x ...)
23     (amb-thunks (list (lambda () x) ...)))))
24
25(define-syntax amb/random
26  (syntax-rules ()
27    ((amb)
28     ((amb-failure-continuation)))
29    ((amb x ...)
30     (amb-thunks (shuffle (list (lambda () x) ...))))))
31
32(define-syntax amb-find
33  (syntax-rules ()
34    ((amb-find x)
35     (amb-find-thunk (lambda () x)))
36    ((amb-find x f)
37     (amb-find-thunk (lambda () x) (lambda () f)))))
38
39(define-syntax amb-collect
40  (syntax-rules ()
41    ((amb-collect x)
42     (amb-collect-thunk (lambda () x)))))
43
44(define-syntax amb-assert
45  (syntax-rules ()
46    ((amb-assert ok?)
47     (if (not ok?) ((amb-failure-continuation))))))
48
49(define (amb-exhausted)
50  (signal
51   (make-composite-condition
52    (make-property-condition
53     'exn
54     'message "expression tree exhausted" 'location 'amb 'arguments '())
55    (make-property-condition
56     'amb))))
57
58(define amb-failure-continuation
59  (make-parameter amb-exhausted))
60
61(define (amb-thunks thunks)
62  (let ((afc (amb-failure-continuation)))
63    (call-with-current-continuation
64     (lambda (arc)
65       (let loop ((tt thunks))
66         (if (null? tt)
67             (begin
68               (amb-failure-continuation afc)
69               (afc))
70             (begin
71               (amb-failure-continuation (lambda () (loop (cdr tt))))
72               (arc ((car tt))))))))))
73
74(define (amb-find-thunk thunk #!optional (failure amb-exhausted))
75  (call-with-current-continuation
76   (lambda (q)
77     (parameterize ((amb-failure-continuation (lambda () (q (failure)))))
78       (thunk)))))
79
80(define (amb-collect-thunk thunk)
81  (let ((afc #f))
82    (dynamic-wind
83        (lambda () (set! afc (amb-failure-continuation)))
84        (lambda ()
85          (call-with-current-continuation
86           (lambda (q)
87             (let* ((root (list #f))
88                    (head root))
89               (amb-failure-continuation (lambda () (q (cdr root))))
90               (set-cdr! head (list (thunk)))
91               (set! head (cdr head))
92               ((amb-failure-continuation))))))
93        (lambda () (amb-failure-continuation afc)))))
94
95) ;module amb
Note: See TracBrowser for help on using the repository browser.