source: project/release/5/amb/trunk/amb.scm @ 38019

Last change on this file since 38019 was 38019, checked in by Kon Lovett, 12 months ago

rm fx in favor of type system

File size: 5.0 KB
Line 
1;;;; amb.scm  -*- Scheme -*-
2;;;; The fundamental non-deterministic backtracking operator
3
4;;;; 4 CHICKEN
5;;;; Kon Lovett, Jul '18
6;;;; Kon Lovett, Aug '17
7;;;; Kon Lovett, May '17
8;;;; Kon Lovett, Mar '09
9
10(module amb
11
12(;export
13  ;
14  shuffle
15  ;
16  amb
17  amb/random
18  amb-find
19  amb-collect
20  amb-assert
21  amb-failure-continuation
22  amb-thunks amb-thunks-shuffled
23  amb-find-thunk
24  amb-collect-thunk
25  amb-random-function)
26
27(import scheme
28  (chicken base)
29  (chicken fixnum)
30  (only (chicken bitwise) integer-length)
31  (chicken syntax)
32  (chicken type)
33  (only (chicken sort) sort!)
34  (only (chicken random) pseudo-random-integer)
35  (only (srfi 1) map!)
36  (srfi 12)
37  (only type-errors warning-argument-type)
38  (only exn-condition make-exn-condition+))
39
40;;; data-structures
41
42(import
43  (chicken type)
44  (only (chicken random) pseudo-random-integer) )
45(define platform-random pseudo-random-integer)
46
47(: vector-shuffle! ((vector-of *) #!optional (procedure (fixnum) fixnum) -> void))
48;
49(define (vector-shuffle! vec #!optional (rnd platform-random))
50  (let (
51    (len (vector-length vec)) )
52    (define (swap-adj! i)
53      (let (
54        (i+1 (modulo (+ i 1) len))
55        (tmp (vector-ref vec i)) )
56        (vector-set! vec i (vector-ref vec i+1))
57        (vector-set! vec i+1 tmp) ) )
58    (do ((n (integer-length len) (- n 1)))
59        ((= n 0))
60      (swap-adj! (rnd len)) ) ) )
61
62(: shuffle ((list-of *) #!optional (procedure (fixnum) fixnum) -> (list-of *)))
63;
64(define (shuffle ls #!optional (rnd platform-random))
65  (let (
66    (vec (list->vector ls)) )
67    (vector-shuffle! vec rnd)
68    (vector->list vec) ) )
69
70;;; miscmacros
71
72(define-syntax let/cc
73  (syntax-rules ()
74    ((let/cc k e0 e1 ...)
75     (call-with-current-continuation
76      (lambda (k) e0 e1 ...)))))
77
78(define-syntax define-parameter
79  (syntax-rules ()
80    ((define-parameter name value guard)
81     (define name (make-parameter value guard)))
82    ((define-parameter name value)
83     (define name (make-parameter value)))
84    ((define-parameter name)
85     (define name (make-parameter (void))))))
86
87;;;
88
89;;
90
91(define (amb-exhausted)
92  (signal (make-amb-exhausted-condition)) )
93
94(define make-amb-exhausted-condition
95  (let (
96    (+cached-amb-exhausted-condition+
97      (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb)) )
98    (lambda () +cached-amb-exhausted-condition+) ) )
99
100;;
101
102(define-parameter amb-random-function pseudo-random-integer
103  (lambda (x)
104    (if (procedure? x)
105      x
106      (begin
107        (warning 'amb-random-function "not a procedure" x)
108        (amb-random-function) ) ) ) )
109
110(define-parameter amb-failure-continuation amb-exhausted
111  (lambda (x)
112    (if (procedure? x)
113      x
114      (begin
115        (warning-argument-type 'amb-failure-continuation x 'procedure)
116        (amb-failure-continuation) ) ) ) )
117
118;;
119
120(define-syntax amb
121  (syntax-rules ()
122    ;
123    ((_)
124     ((amb-failure-continuation)) )
125    ;
126    ((_ ?expr0 ...)
127     (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
128
129(define-syntax amb/random
130  (syntax-rules ()
131    ;
132    ((_)
133     ((amb-failure-continuation)) )
134    ;
135    ((_ ?expr0 ...)
136     (amb-thunks-shuffled (list (lambda () ?expr0) ...)) ) ) )
137
138(define-syntax amb-find
139  (syntax-rules ()
140    ;
141    ((_ ?expr)
142     (amb-find-thunk (lambda () ?expr)) )
143    ;
144    ((_ ?expr ?fail)
145     (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
146
147(define-syntax amb-collect
148  (syntax-rules ()
149    ((_ ?expr)
150     (amb-collect-thunk (lambda () ?expr)) ) ) )
151
152(define-syntax amb-assert
153  (syntax-rules ()
154    ((_ ?expr)
155     (unless ?expr ((amb-failure-continuation))) ) ) )
156
157;;
158
159(: amb-thunks ((list-of procedure) -> *))
160;
161(define (amb-thunks thunks)
162  (let ((afc (amb-failure-continuation)))
163    (let/cc return
164      (let loop ((tt thunks))
165        (cond
166          ((null? tt)
167            (amb-failure-continuation afc)
168            (afc) )
169          (else
170            (amb-failure-continuation (lambda () (loop (cdr tt))))
171            (return ((car tt))) ) ) ) ) ) )
172
173(: amb-thunks-shuffled ((list-of procedure) #!rest (list procedure) -> *))
174;
175(define (amb-thunks-shuffled thunks . opts)
176  (let ((rand (optional opts (amb-random-function))))
177    (amb-thunks (shuffle thunks rand)) ) )
178
179(: amb-find-thunk (procedure #!rest (list procedure) -> *))
180;
181(define (amb-find-thunk thunk . opts)
182  (let ((failure (optional opts amb-exhausted)))
183    (let/cc return
184      (let ((fail-k (lambda () (return (failure)))))
185        (parameterize ((amb-failure-continuation fail-k))
186          (thunk) ) ) ) ) )
187
188(: amb-collect-thunk (procedure -> *))
189;
190(define (amb-collect-thunk thunk)
191  (let ((afc #f))
192    (dynamic-wind
193      ;
194      (lambda ()
195        (set! afc (amb-failure-continuation)) )
196      ;
197      (lambda ()
198        (let/cc return
199          (let* (
200            (root (list #f))
201            (head root) )
202            ;
203            (amb-failure-continuation (lambda () (return (cdr root))))
204            (set-cdr! head (list (thunk)))
205            (set! head (cdr head))
206            ((amb-failure-continuation))) ) )
207      ;
208      (lambda ()
209        (amb-failure-continuation afc) ) ) ) )
210
211) ;module amb
Note: See TracBrowser for help on using the repository browser.