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

Last change on this file since 34337 was 34337, checked in by kon, 23 months ago

expose more

File size: 3.6 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)
25
26(import chicken)
27
28(import
29  (only data-structures sort!)
30  (only extras random) )
31(require-library extras data-structures)
32
33(import (only (srfi 1) map!))
34(require-library (srfi 1))
35
36(import
37  (only miscmacros let/cc define-parameter)
38  (only type-errors warning-argument-type)
39  (only condition-utils make-exn-condition+))
40(require-library
41  miscmacros type-errors condition-utils)
42
43;;;
44
45;;
46
47(define (amb-exhausted)
48  (signal (make-amb-exhausted-condition)) )
49
50(define make-amb-exhausted-condition
51  (let ((+cached-amb-exhausted-condition+
52          (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb)))
53    (lambda () +cached-amb-exhausted-condition+) ) )
54
55;;
56
57(define-parameter amb-random-function random
58  (lambda (x)
59    (if (procedure? x)
60      x
61      (begin
62        (warning 'amb-random-function "not a procedure" x)
63        (amb-random-function) ) ) ) )
64
65(define-parameter amb-failure-continuation amb-exhausted
66  (lambda (x)
67    (if (procedure? x)
68      x
69      (begin
70        (warning-argument-type 'amb-failure-continuation x 'procedure)
71        (amb-failure-continuation) ) ) ) )
72
73;;
74
75(define-syntax amb
76  (syntax-rules ()
77    ((_)
78     ((amb-failure-continuation)) )
79    ((_ ?expr0 ...)
80     (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
81
82(define-syntax amb/random
83  (syntax-rules ()
84    ((_)
85     ((amb-failure-continuation)) )
86    ((_ ?expr0 ...)
87     (amb-thunks-shuffled (list (lambda () ?expr0) ...)) ) ) )
88
89(define-syntax amb-find
90  (syntax-rules ()
91    ((_ ?expr)
92     (amb-find-thunk (lambda () ?expr)) )
93    ((_ ?expr ?fail)
94     (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
95
96(define-syntax amb-collect
97  (syntax-rules ()
98    ((_ ?expr)
99     (amb-collect-thunk (lambda () ?expr)) ) ) )
100
101(define-syntax amb-assert
102  (syntax-rules ()
103    ((_ ?expr)
104     (unless ?expr ((amb-failure-continuation))) ) ) )
105
106;;
107
108(define (amb-thunks thunks)
109  (let ((afc (amb-failure-continuation)))
110    (let/cc return
111      (let loop ((tt thunks))
112        (cond
113          ((null? tt)
114            (amb-failure-continuation afc)
115            (afc) )
116          (else
117            (amb-failure-continuation (lambda () (loop (cdr tt))))
118            (return ((car tt))) ) ) ) ) ) )
119
120(define (amb-thunks-shuffled thunks #!optional (rand (amb-random-function)))
121  (amb-thunks (shuffle thunks rand)) )
122
123(define (amb-find-thunk thunk #!optional (failure amb-exhausted))
124  (let/cc return
125    (let ((fail-k (lambda () (return (failure)))))
126      (parameterize ((amb-failure-continuation fail-k))
127        (thunk) ) ) ) )
128
129(define (amb-collect-thunk thunk)
130  (let ((afc #f))
131    (dynamic-wind
132      (lambda ()
133        (set! afc (amb-failure-continuation)) )
134      (lambda ()
135        (let/cc return
136          (let* ((root (list #f))
137                 (head root) )
138            (amb-failure-continuation (lambda () (return (cdr root))))
139            (set-cdr! head (list (thunk)))
140            (set! head (cdr head))
141            ((amb-failure-continuation))) ) )
142      (lambda ()
143        (amb-failure-continuation afc) ) ) ) )
144
145;;;
146
147(define (shuffle ls random)
148  (let ((len (length ls)))
149    (map!
150      cdr
151      (sort!
152        (map (lambda (x) (cons (random len) x)) ls)
153        (lambda (x y) (< (car x) (car y)))) ) ) )
154
155) ;module amb
Note: See TracBrowser for help on using the repository browser.