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

Last change on this file since 34422 was 34422, checked in by kon, 4 months ago

comments

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    ((_)
79     ((amb-failure-continuation)) )
80    ;
81    ((_ ?expr0 ...)
82     (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
83
84(define-syntax amb/random
85  (syntax-rules ()
86    ;
87    ((_)
88     ((amb-failure-continuation)) )
89    ;
90    ((_ ?expr0 ...)
91     (amb-thunks-shuffled (list (lambda () ?expr0) ...)) ) ) )
92
93(define-syntax amb-find
94  (syntax-rules ()
95    ;
96    ((_ ?expr)
97     (amb-find-thunk (lambda () ?expr)) )
98    ;
99    ((_ ?expr ?fail)
100     (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
101
102(define-syntax amb-collect
103  (syntax-rules ()
104    ((_ ?expr)
105     (amb-collect-thunk (lambda () ?expr)) ) ) )
106
107(define-syntax amb-assert
108  (syntax-rules ()
109    ((_ ?expr)
110     (unless ?expr ((amb-failure-continuation))) ) ) )
111
112;;
113
114(define (amb-thunks thunks)
115  (let ((afc (amb-failure-continuation)))
116    (let/cc return
117      (let loop ((tt thunks))
118        (cond
119          ((null? tt)
120            (amb-failure-continuation afc)
121            (afc) )
122          (else
123            (amb-failure-continuation (lambda () (loop (cdr tt))))
124            (return ((car tt))) ) ) ) ) ) )
125
126(define (amb-thunks-shuffled thunks #!optional (rand (amb-random-function)))
127  (amb-thunks (shuffle thunks rand)) )
128
129(define (amb-find-thunk thunk #!optional (failure amb-exhausted))
130  (let/cc return
131    (let ((fail-k (lambda () (return (failure)))))
132      (parameterize ((amb-failure-continuation fail-k))
133        (thunk) ) ) ) )
134
135(define (amb-collect-thunk thunk)
136  (let ((afc #f))
137    (dynamic-wind
138      (lambda ()
139        (set! afc (amb-failure-continuation)) )
140      (lambda ()
141        (let/cc return
142          (let* ((root (list #f))
143                 (head root) )
144            (amb-failure-continuation (lambda () (return (cdr root))))
145            (set-cdr! head (list (thunk)))
146            (set! head (cdr head))
147            ((amb-failure-continuation))) ) )
148      (lambda ()
149        (amb-failure-continuation afc) ) ) ) )
150
151;;;
152
153(define (shuffle ls random)
154  (let ((len (length ls)))
155    (map!
156      cdr
157      (sort!
158        (map (lambda (x) (cons (random len) x)) ls)
159        (lambda (x y) (< (car x) (car y)))) ) ) )
160
161) ;module amb
Note: See TracBrowser for help on using the repository browser.