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

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

Save.

File size: 3.3 KB
Line 
1;;;; amb.scm
2;;;; The fundamental non-deterministic backtracking operator
3;;;; Chicken 4 Port: Kon Lovett, Mar '09
4
5(declare
6  (usual-integrations)
7  (fixnum-arithmetic)
8  (inline)
9  (local)
10  (no-procedure-checks))
11
12;;; Module `amb'
13
14(module amb (;export
15  amb
16  amb/random
17  amb-find
18  amb-collect
19  amb-assert
20  amb-failure-continuation
21  amb-thunks
22  amb-find-thunk
23  amb-collect-thunk
24  #;choose
25  #;one
26  #;all
27  #;required)
28
29(import scheme chicken)
30
31;;
32
33(define-syntax let/cc
34  (syntax-rules ()
35    ((_ ?k ?expr0 ...)
36     (call-with-current-continuation (lambda (?k) ?expr0 ...)) ) ) )
37
38;;
39
40(define-syntax amb
41  (syntax-rules ()
42    ((_)
43     ((amb-failure-continuation)) )
44    ((_ ?expr0 ...)
45     (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
46
47(define-syntax amb/random
48  (syntax-rules ()
49    ((_)
50     ((amb-failure-continuation)) )
51    ((_ ?expr0 ...)
52     (amb-thunks (shuffle (list (lambda () ?expr0) ...))) ) ) )
53
54(define-syntax amb-find
55  (syntax-rules ()
56    ((_ ?expr)
57     (amb-find-thunk (lambda () ?expr)) )
58    ((_ ?expr ?fail)
59     (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
60
61(define-syntax amb-collect
62  (syntax-rules ()
63    ((_ ?expr)
64     (amb-collect-thunk (lambda () ?expr)) ) ) )
65
66(define-syntax amb-assert
67  (syntax-rules ()
68    ((_ ?expr)
69     (if (not ?expr) ((amb-failure-continuation))) ) ) )
70
71;;
72
73#;
74(define-syntax choose
75  (syntax-rules ()
76    ((_ ?expr0 ...)
77     (amb/random ?expr0 ...) ) ) )
78
79#;
80(define-syntax one
81  (syntax-rules ()
82    ((_ ?expr)
83     (amb-find ?expr) )
84    ((_ ?expr ?fail)
85     (amb-find ?expr ?fail) ) ) )
86
87#;
88(define-syntax all
89  (syntax-rules ()
90    ((_ ?expr)
91     (amb-collect ?expr) ) ) )
92
93#;
94(define-syntax required
95  (syntax-rules ()
96    ((_ ?expr)
97     (amb-assert ?expr) ) ) )
98
99;;
100
101(define (make-exn-condition loc msg args)
102  (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
103
104(define (make-amb-exhausted-condition)
105  (make-composite-condition
106   (make-exn-condition 'amb "expression tree exhausted" '())
107   (make-property-condition 'amb)) )
108
109(define (amb-exhausted) (signal (make-amb-exhausted-condition)))
110
111;;
112
113(define amb-failure-continuation
114  (make-parameter amb-exhausted
115    (lambda (x)
116      (cond ((procedure? x) x)
117            (else
118             (warning 'amb-failure-continuation "bad argument type - not a procedure" x)
119             (amb-failure-continuation) ) ) ) ) )
120
121;;
122
123(define (amb-thunks thunks)
124  (let ((afc (amb-failure-continuation)))
125    (let/cc arc
126      (let loop ((tt thunks))
127        (cond ((null? tt)
128               (amb-failure-continuation afc)
129               (afc) )
130              (else
131               (amb-failure-continuation (lambda () (loop (cdr tt))))
132               (arc ((car tt))) ) ) ) ) ) )
133
134(define (amb-find-thunk thunk #!optional (failure amb-exhausted))
135  (let/cc q
136    (parameterize ((amb-failure-continuation (lambda () (q (failure)))))
137      (thunk) ) ) )
138
139(define (amb-collect-thunk thunk)
140  (let ((afc #f))
141    (dynamic-wind
142      (lambda ()
143        (set! afc (amb-failure-continuation)) )
144      (lambda ()
145        (let/cc q
146          (let* ((root (list #f))
147                 (head root))
148            (amb-failure-continuation (lambda () (q (cdr root))))
149            (set-cdr! head (list (thunk)))
150            (set! head (cdr head))
151            ((amb-failure-continuation))) ) )
152      (lambda ()
153        (amb-failure-continuation afc) ) ) ) )
154
155) ;module amb
Note: See TracBrowser for help on using the repository browser.