Changeset 13802 in project
- Timestamp:
- 03/17/09 23:44:56 (11 years ago)
- Location:
- release/4/amb/trunk
- Files:
-
- 1 added
- 7 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/amb/trunk/amb-dwelling.scm
r13801 r13802 1 1 ;;;; amb-dwelling.scm 2 2 3 (require-extension amb )3 (require-extension amb amb-extras) 4 4 5 5 ;; Baker, Cooper, Fletcher, Miller, and Smith live on different … … 13 13 ;; Where does everyone live? 14 14 15 (define (multiple-dwelling) 16 (let ((baker (amb 1 2 3 4 5)) 15 (define (solve-dwelling-puzzle) 16 17 (let ((baker (amb 1 2 3 4 5)) 17 18 (cooper (amb 1 2 3 4 5)) 18 (fletcher 19 (fletcher (amb 1 2 3 4 5)) 19 20 (miller (amb 1 2 3 4 5)) 20 (smith 21 (smith (amb 1 2 3 4 5))) 21 22 22 23 ;; They live on different floors. 23 ( amb-assert(distinct? (list baker cooper fletcher miller smith)))24 (required (distinct? (list baker cooper fletcher miller smith))) 24 25 25 26 ;; Baker does not live on the top floor. 26 ( amb-assert(not (= baker 5)))27 (required (not (= baker 5))) 27 28 28 29 ;; Cooper does not live on the bottom floor. 29 ( amb-assert(not (= cooper 1)))30 (required (not (= cooper 1))) 30 31 31 ;; Fletcher does not live on either the top 32 ;; or the bottom floor. 33 (amb-assert (not (= fletcher 5))) 34 (amb-assert (not (= fletcher 1))) 32 ;; Fletcher does not live on either the top or the bottom floor. 33 (required (not (= fletcher 5))) 34 (required (not (= fletcher 1))) 35 35 36 36 ;; Miller lives on a higher floor than does Cooper. 37 ( amb-assert(> miller cooper))37 (required (> miller cooper)) 38 38 39 39 ;; Smith does not live on a floor adjacent to Fletcher's. 40 ( amb-assert (not (= (abs (- smith fletch)) 1)))40 (required (not (= (abs (- smith fletcher)) 1))) 41 41 42 42 ;; Fletcher does not live on a floor adjacent to Cooper's. 43 ( amb-assert(not (= (abs (- fletcher cooper)) 1)))43 (required (not (= (abs (- fletcher cooper)) 1))) 44 44 45 45 `((baker ,baker) (cooper ,cooper) (fletcher ,fletcher) (miller ,miller) (smith ,smith))) ) -
release/4/amb/trunk/amb-kalotan.scm
r13801 r13802 57 57 58 58 (list parent1 parent2 kibi) ) ) 59 60 (let* ((res (amb-collect (solve-kalotan-puzzle)))61 (ls (car res))62 (p1 (car ls))63 (p2 (cadr ls))64 (kibi (caddr ls)) )65 (print "Gender Parent 1 " p1 " Parent 2 " p2 " Kibi " kibi)66 (newline) ) -
release/4/amb/trunk/amb-money.scm
r13801 r13802 1 1 ;;;; amb-money.scm 2 2 3 (require-extension amb srfi-1)3 (require-extension amb amb-extras srfi-1) 4 4 5 5 ;; Assign different numerals to different symbols … … 25 25 ;; original domain space of a variable from 10 (or 9) to 1 (or to 2 if we 26 26 ;; take into account the effect of 'modulo application) 27 ;;28 ;; Example:29 ;; (money) ==>30 ;; ((4385 trials)31 ;; (s e n d + m o r e = m o n e y)32 ;; (9 5 6 7 + 1 0 8 5 = 1 0 6 5 2))33 27 34 (define ( money)28 (define (solve-money-puzzle) 35 29 36 ( define (set-difference xs ys)37 (filter (lambda(x) (not (member x ys))) xs))30 (let ((trial 0) 31 (m 1) ) 38 32 39 (define (distinct? xs)40 (cond ((null? xs) #t)41 ( (member (car xs) (cdr xs)) #f)42 ( else (distinct? (cdr xs)))))33 (let ((p1 (amb 0 1)) 34 (p2 (amb 0 1)) 35 (p3 (amb 0 1)) 36 (d (choose '(0 1 2 3 4 5 6 7 8 9)) ) ) 43 37 44 (define trial 0) 38 (let* ((e (choose (lset-difference equal? '(0 1 2 3 4 5 6 7 8 9) (list d)))) 39 (y (modulo (+ d e (* -10 p1)) 10)) 40 (n (choose (lset-difference equal? '(0 1 2 3 4 5 6 7 8 9) (list d e y)))) 41 (r (modulo (+ (* 10 p2) e (- p1) (- n)) 10)) 42 (o (modulo (+ (* 10 p3) n (- p2) (- e)) 10)) 43 (s (modulo (+ (* 9 m) o (- p3)) 10) ) ) 45 44 46 (let* ((p1 (amb 0 1)) 47 (p2 (amb 0 1)) 48 (p3 (amb 0 1)) 45 (set! trial (add1 trial)) 49 46 50 (d (amb/random '(0 1 2 3 4 5 6 7 8 9))) 51 (e (amb/random (set-difference '(0 1 2 3 4 5 6 7 8 9) (list d)))) 52 (y (modulo (+ d e (* -10 p1)) 10)) 53 (n (amb/random (set-difference '(0 1 2 3 4 5 6 7 8 9) (list d e y)))) 54 (r (modulo (+ (* 10 p2) e (- p1) (- n)) 10)) 55 (o (modulo (+ (* 10 p3) n (- p2) (- e)) 10)) 47 (required (distinct? (list s e n d m o r y))) 48 (required (= (+ d e) (+ (* 10 p1) y))) 49 (required (= (+ p1 n r) (+ (* 10 p2) e))) 50 (required (= (+ p2 e o) (+ (* 10 p3) n))) 51 (required (= (+ p3 s m) (+ (* 10 m) o))) 56 52 57 (m 1) 58 (s (modulo (+ (* 9 m) o (- p3)) 10) ) ) 59 60 (set! trial (+ trial 1)) 61 62 (assert (distinct? (list s e n d m o r y))) 63 (assert (= (+ d e) (+ (* 10 p1) y))) 64 (assert (= (+ p1 n r) (+ (* 10 p2) e))) 65 (assert (= (+ p2 e o) (+ (* 10 p3) n))) 66 (assert (= (+ p3 s m) (+ (* 10 m) o))) 67 68 ;; Result, including a number of recorded trials 69 `((,trial trials) 70 (s e n d + m o r e = m o n e y) 71 (,s ,e ,n ,d '+ ,m ,o ,r ,e '= ,m ,o ,n ,e ,y)) ) ) 53 ;; Result, including a number of recorded trials 54 `((,trial trials) 55 (s e n d + m o r e = m o n e y) 56 (,s ,e ,n ,d + ,m ,o ,r ,e = ,m ,o ,n ,e ,y)) ) ) ) ) -
release/4/amb/trunk/amb.meta
r13801 r13802 14 14 "tests" 15 15 "amb.scm" 16 "amb-extras.scm" 16 17 "amb.setup") ) -
release/4/amb/trunk/amb.scm
r13801 r13802 11 11 12 12 ;;; Module `amb' 13 14 (require-library data-structures extras) 13 15 14 16 (module amb (;export … … 21 23 amb-thunks 22 24 amb-find-thunk 23 amb-collect-thunk 24 #;choose 25 #;one 26 #;all 27 #;required) 25 amb-collect-thunk) 28 26 29 (import scheme chicken )27 (import scheme chicken data-structures extras) 30 28 31 29 ;; … … 50 48 ((amb-failure-continuation)) ) 51 49 ((_ ?expr0 ...) 52 (amb-thunks (shuffle (list (lambda () ?expr0) ...) )) ) ) )50 (amb-thunks (shuffle (list (lambda () ?expr0) ...) random)) ) ) ) 53 51 54 52 (define-syntax amb-find … … 67 65 (syntax-rules () 68 66 ((_ ?expr) 69 (if (not ?expr) ((amb-failure-continuation))) ) ) ) 70 71 ;; 72 73 #; 74 (define-syntax choose 75 (syntax-rules () 76 ((_ ?expr0 ...) 77 (amb/random ?expr0 ...) ) ) ) 78 79 #; 80 (define-syntax one 81 (syntax-rules () 82 ((_ ?expr) 83 (amb-find ?expr) ) 84 ((_ ?expr ?fail) 85 (amb-find ?expr ?fail) ) ) ) 86 87 #; 88 (define-syntax all 89 (syntax-rules () 90 ((_ ?expr) 91 (amb-collect ?expr) ) ) ) 92 93 #; 94 (define-syntax required 95 (syntax-rules () 96 ((_ ?expr) 97 (amb-assert ?expr) ) ) ) 67 (unless ?expr ((amb-failure-continuation))) ) ) ) 98 68 99 69 ;; -
release/4/amb/trunk/amb.setup
r13799 r13802 5 5 (verify-extension-name "amb") 6 6 7 (setup-shared-extension-module (extension-name) (extension-version "2.0.0")) 7 (setup-shared-extension-module 'amb (extension-version "2.0.0")) 8 9 (setup-shared-extension-module 'amb-extras (extension-version "2.0.0")) -
release/4/amb/trunk/tests/run.scm
r13799 r13802 1 ;;;; amb test 2 3 (include "../amb-kalotan") 4 (assert (equal? '(female male female) (solve-kalotan-puzzle))) 5 6 (include "../amb-money") 7 (assert (equal? '(9 5 6 7 + 1 0 8 5 = 1 0 6 5 2) (caddr (solve-money-puzzle)))) 8 9 (include "../amb-dwelling") 10 (assert (equal? '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)) (solve-dwelling-puzzle)))
Note: See TracChangeset
for help on using the changeset viewer.