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

Last change on this file since 35142 was 35142, checked in by kon, 8 months ago

use typed-define

File size: 3.8 KB
Line 
1;;;; amb.scm
2;;;; The fundamental non-deterministic backtracking operator
3
4;;;; Chicken 4 Port: Kon Lovett, Mar '09
5;;;; Kon Lovett, May '17
6;;;; Kon Lovett, Aug '17
7
8(module amb
9
10(;export
11  amb
12  amb/random
13  amb-find
14  amb-collect
15  amb-assert
16  amb-failure-continuation
17  amb-thunks amb-thunks-shuffled
18  amb-find-thunk
19  amb-collect-thunk
20  amb-random-function
21  ;
22  shuffle)
23
24(import scheme chicken)
25(use
26  (only data-structures sort!)
27  (only extras random)
28  (only (srfi 1) map!)
29  (only miscmacros let/cc define-parameter)
30  (only type-errors warning-argument-type)
31  (only condition-utils make-exn-condition+)
32  typed-define)
33
34;;;
35
36;;
37
38(define (amb-exhausted)
39  (signal (make-amb-exhausted-condition)) )
40
41(define make-amb-exhausted-condition
42  (let (
43    (+cached-amb-exhausted-condition+
44      (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb)))
45    ;
46    (lambda () +cached-amb-exhausted-condition+) ) )
47
48;;
49
50(define-parameter amb-random-function random
51  (lambda (x)
52    (if (procedure? x)
53      x
54      (begin
55        (warning 'amb-random-function "not a procedure" x)
56        (amb-random-function) ) ) ) )
57
58(define-parameter amb-failure-continuation amb-exhausted
59  (lambda (x)
60    (if (procedure? x)
61      x
62      (begin
63        (warning-argument-type 'amb-failure-continuation x 'procedure)
64        (amb-failure-continuation) ) ) ) )
65
66;;
67
68(define-syntax amb
69  (syntax-rules ()
70    ;
71    ((_)
72     ((amb-failure-continuation)) )
73    ;
74    ((_ ?expr0 ...)
75     (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
76
77(define-syntax amb/random
78  (syntax-rules ()
79    ;
80    ((_)
81     ((amb-failure-continuation)) )
82    ;
83    ((_ ?expr0 ...)
84     (amb-thunks-shuffled (list (lambda () ?expr0) ...)) ) ) )
85
86(define-syntax amb-find
87  (syntax-rules ()
88    ;
89    ((_ ?expr)
90     (amb-find-thunk (lambda () ?expr)) )
91    ;
92    ((_ ?expr ?fail)
93     (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
94
95(define-syntax amb-collect
96  (syntax-rules ()
97    ((_ ?expr)
98     (amb-collect-thunk (lambda () ?expr)) ) ) )
99
100(define-syntax amb-assert
101  (syntax-rules ()
102    ((_ ?expr)
103     (unless ?expr ((amb-failure-continuation))) ) ) )
104
105;;
106
107(define: (amb-thunks (thunks (list-of procedure))) -> *
108  (let ((afc (amb-failure-continuation)))
109    (let/cc return
110      (let loop ((tt thunks))
111        (cond
112          ((null? tt)
113            (amb-failure-continuation afc)
114            (afc) )
115          (else
116            (amb-failure-continuation (lambda () (loop (cdr tt))))
117            (return ((car tt))) ) ) ) ) ) )
118
119(define: (amb-thunks-shuffled (thunks (list-of procedure)) . (opts (list procedure))) -> *
120  (let ((rand (optional opts (amb-random-function))))
121    (amb-thunks (shuffle thunks rand)) ) )
122
123(define: (amb-find-thunk (thunk procedure) . (opts (list procedure))) -> *
124  (let ((failure (optional opts amb-exhausted)))
125    (let/cc return
126      (let ((fail-k (lambda () (return (failure)))))
127        (parameterize ((amb-failure-continuation fail-k))
128          (thunk) ) ) ) ) )
129
130(define: (amb-collect-thunk (thunk procedure)) -> *
131  (let ((afc #f))
132    (dynamic-wind
133      ;
134      (lambda ()
135        (set! afc (amb-failure-continuation)) )
136      ;
137      (lambda ()
138        (let/cc return
139          (let* (
140            (root (list #f))
141            (head root) )
142            ;
143            (amb-failure-continuation (lambda () (return (cdr root))))
144            (set-cdr! head (list (thunk)))
145            (set! head (cdr head))
146            ((amb-failure-continuation))) ) )
147      ;
148      (lambda ()
149        (amb-failure-continuation afc) ) ) ) )
150
151;;;
152
153(define: (shuffle (ls (list-of *)) (random procedure)) -> (list-of *)
154  ;
155  (define (car< x y)
156  (fx< (car x) (car y)) )
157  ;
158  (let* (
159    (len (length ls))
160    (tagged-ls (map (lambda (x) (cons (random len) x)) ls)) )
161    ;
162    (map! cdr (sort! tagged-ls car<) ) ) )
163
164) ;module amb
Note: See TracBrowser for help on using the repository browser.