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

Last change on this file since 37008 was 37008, checked in by Kon Lovett, 2 years ago

better shuffle

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 fixnum) fx= fx+ fx- fxmod)
45  (only (chicken random) pseudo-random-integer) )
46(define platform-random pseudo-random-integer)
47
48(: vector-shuffle! ((vector-of *) #!optional (procedure (fixnum) fixnum) -> void))
49;
50(define (vector-shuffle! vec #!optional (rnd platform-random))
51  (let (
52    (len (vector-length vec)) )
53    (define (swap-adj! i)
54      (let (
55        (i+1 (fxmod (fx+ i 1) len))
56        (tmp (vector-ref vec i)) )
57        (vector-set! vec i (vector-ref vec i+1))
58        (vector-set! vec i+1 tmp) ) )
59    (do ((n (integer-length len) (fx- n 1)))
60        ((fx= n 0))
61      (swap-adj! (rnd len)) ) ) )
62
63(: shuffle ((list-of *) #!optional (procedure (fixnum) fixnum) -> (list-of *)))
64;
65(define (shuffle ls #!optional (rnd platform-random))
66  (let (
67    (vec (list->vector ls)) )
68    (vector-shuffle! vec rnd)
69    (vector->list vec) ) )
70
71;;; miscmacros
72
73(define-syntax let/cc
74  (syntax-rules ()
75    ((let/cc k e0 e1 ...)
76     (call-with-current-continuation
77      (lambda (k) e0 e1 ...)))))
78
79(define-syntax define-parameter
80  (syntax-rules ()
81    ((define-parameter name value guard)
82     (define name (make-parameter value guard)))
83    ((define-parameter name value)
84     (define name (make-parameter value)))
85    ((define-parameter name)
86     (define name (make-parameter (void))))))
87
88;;;
89
90;;
91
92(define (amb-exhausted)
93  (signal (make-amb-exhausted-condition)) )
94
95(define make-amb-exhausted-condition
96  (let (
97    (+cached-amb-exhausted-condition+
98      (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb)) )
99    (lambda () +cached-amb-exhausted-condition+) ) )
100
101;;
102
103(define-parameter amb-random-function pseudo-random-integer
104  (lambda (x)
105    (if (procedure? x)
106      x
107      (begin
108        (warning 'amb-random-function "not a procedure" x)
109        (amb-random-function) ) ) ) )
110
111(define-parameter amb-failure-continuation amb-exhausted
112  (lambda (x)
113    (if (procedure? x)
114      x
115      (begin
116        (warning-argument-type 'amb-failure-continuation x 'procedure)
117        (amb-failure-continuation) ) ) ) )
118
119;;
120
121(define-syntax amb
122  (syntax-rules ()
123    ;
124    ((_)
125     ((amb-failure-continuation)) )
126    ;
127    ((_ ?expr0 ...)
128     (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
129
130(define-syntax amb/random
131  (syntax-rules ()
132    ;
133    ((_)
134     ((amb-failure-continuation)) )
135    ;
136    ((_ ?expr0 ...)
137     (amb-thunks-shuffled (list (lambda () ?expr0) ...)) ) ) )
138
139(define-syntax amb-find
140  (syntax-rules ()
141    ;
142    ((_ ?expr)
143     (amb-find-thunk (lambda () ?expr)) )
144    ;
145    ((_ ?expr ?fail)
146     (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
147
148(define-syntax amb-collect
149  (syntax-rules ()
150    ((_ ?expr)
151     (amb-collect-thunk (lambda () ?expr)) ) ) )
152
153(define-syntax amb-assert
154  (syntax-rules ()
155    ((_ ?expr)
156     (unless ?expr ((amb-failure-continuation))) ) ) )
157
158;;
159
160(: amb-thunks ((list-of procedure) -> *))
161;
162(define (amb-thunks thunks)
163  (let ((afc (amb-failure-continuation)))
164    (let/cc return
165      (let loop ((tt thunks))
166        (cond
167          ((null? tt)
168            (amb-failure-continuation afc)
169            (afc) )
170          (else
171            (amb-failure-continuation (lambda () (loop (cdr tt))))
172            (return ((car tt))) ) ) ) ) ) )
173
174(: amb-thunks-shuffled ((list-of procedure) #!rest (list procedure) -> *))
175;
176(define (amb-thunks-shuffled thunks . opts)
177  (let ((rand (optional opts (amb-random-function))))
178    (amb-thunks (shuffle thunks rand)) ) )
179
180(: amb-find-thunk (procedure #!rest (list procedure) -> *))
181;
182(define (amb-find-thunk thunk . opts)
183  (let ((failure (optional opts amb-exhausted)))
184    (let/cc return
185      (let ((fail-k (lambda () (return (failure)))))
186        (parameterize ((amb-failure-continuation fail-k))
187          (thunk) ) ) ) ) )
188
189(: amb-collect-thunk (procedure -> *))
190;
191(define (amb-collect-thunk thunk)
192  (let ((afc #f))
193    (dynamic-wind
194      ;
195      (lambda ()
196        (set! afc (amb-failure-continuation)) )
197      ;
198      (lambda ()
199        (let/cc return
200          (let* (
201            (root (list #f))
202            (head root) )
203            ;
204            (amb-failure-continuation (lambda () (return (cdr root))))
205            (set-cdr! head (list (thunk)))
206            (set! head (cdr head))
207            ((amb-failure-continuation))) ) )
208      ;
209      (lambda ()
210        (amb-failure-continuation afc) ) ) ) )
211
212) ;module amb
Note: See TracBrowser for help on using the repository browser.