Changeset 35102 in project
- Timestamp:
- 02/01/18 07:33:54 (13 months ago)
- Location:
- release/4/amb/trunk
- Files:
-
- 2 added
- 9 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/amb/trunk/amb-dwelling.scm
r13802 r35102 1 1 ;;;; amb-dwelling.scm 2 2 3 ( require-extensionamb amb-extras)3 (use amb amb-extras) 4 4 5 5 ;; Baker, Cooper, Fletcher, Miller, and Smith live on different … … 14 14 15 15 (define (solve-dwelling-puzzle) 16 17 (let ((baker (amb 1 2 3 4 5)) 18 (cooper (amb 1 2 3 4 5)) 19 (fletcher (amb 1 2 3 4 5)) 20 (miller (amb 1 2 3 4 5)) 21 (smith (amb 1 2 3 4 5))) 22 16 ; 17 (let ( 18 (baker (amb 1 2 3 4 5)) 19 (cooper (amb 1 2 3 4 5)) 20 (fletcher (amb 1 2 3 4 5)) 21 (miller (amb 1 2 3 4 5)) 22 (smith (amb 1 2 3 4 5)) ) 23 ; 23 24 ;; They live on different floors. 24 25 (required (distinct? (list baker cooper fletcher miller smith))) 25 26 ; 26 27 ;; Baker does not live on the top floor. 27 28 (required (not (= baker 5))) 28 29 ; 29 30 ;; Cooper does not live on the bottom floor. 30 31 (required (not (= cooper 1))) 31 32 ; 32 33 ;; Fletcher does not live on either the top or the bottom floor. 33 34 (required (not (= fletcher 5))) 34 35 (required (not (= fletcher 1))) 35 36 ; 36 37 ;; Miller lives on a higher floor than does Cooper. 37 38 (required (> miller cooper)) 38 39 ;; Smith does not live on a floor adjacent to Fletcher's. 39 ; 40 ;; Smith does not live on a floor adjacent to Fletcher's. 40 41 (required (not (= (abs (- smith fletcher)) 1))) 41 42 ; 42 43 ;; Fletcher does not live on a floor adjacent to Cooper's. 43 44 (required (not (= (abs (- fletcher cooper)) 1))) 44 45 `((baker ,baker) (cooper ,cooper) (fletcher ,fletcher) (miller ,miller) (smith ,smith))) ) 45 ; 46 `((baker ,baker) 47 (cooper ,cooper) 48 (fletcher ,fletcher) 49 (miller ,miller) 50 (smith ,smith))) ) -
release/4/amb/trunk/amb-extras.scm
r34422 r35102 12 12 all-of 13 13 required 14 xor 14 15 implies 15 16 distinct? 16 ;17 17 count-member 18 only-member? 18 19 list-constantly) 19 20 20 (import scheme) 21 22 (import chicken) 23 24 (import 21 (import scheme chicken) 22 (use 25 23 (only extras random) 26 (only data-structures sort! constantly)) 27 (require-library extras data-structures) 28 29 (import (only (srfi 1) count every)) 30 (require-library (srfi 1)) 31 32 (import (only type-checks check-list check-procedure)) 33 (require-library type-checks) 34 35 (require-extension amb) 24 (only data-structures sort! constantly) 25 (only (srfi 1) count every) 26 amb) 36 27 37 28 ;;; 38 29 39 ;; 30 ;; Convenience 40 31 41 32 (define-syntax amb1 … … 57 48 (amb-thunks-shuffled (list-constantly ?ls) (amb-random-function)) ) ) ) 58 49 50 ;; Aliases 51 59 52 (define-syntax one-of 60 53 (syntax-rules () … … 72 65 (amb-assert ?expr) ) ) ) 73 66 74 ;; 67 ;; Logic Control 75 68 76 (define (implies a b) 77 (or (not a) b) ) 69 (define-syntax xor 70 (syntax-rules () 71 ((_ ?a ?b) 72 (let ((_a ?a) (_b ?b)) 73 (if (and _a _b) #f (or _a _b)) ) ) ) ) 78 74 79 (define (distinct? xs #!optional (eql? equal?)) 80 (check-procedure 'distinct? eql? '=?) 81 (every 82 (lambda (t) (fx= 1 (count-member t xs eql?))) 83 (check-list 'distinct? xs 'list)) ) 75 (define-syntax implies 76 (syntax-rules () 77 ((_ ?a ?b) 78 (or (not ?a) ?b) ) ) ) 84 79 85 80 ;;; … … 90 85 (count (cut eql? x <>) xs) ) 91 86 87 (define (only-member? x xs #!optional (eql? equal?)) 88 (= 1 (count-member x xs eql?)) ) 89 90 ;; 91 92 92 (define (list-constantly ls) 93 93 (map constantly ls) ) 94 94 95 ;; 96 97 (define (distinct? xs #!optional (eql? equal?)) 98 (every (cut only-member? <> xs eql?) xs) ) 99 95 100 ) ;module amb-extras -
release/4/amb/trunk/amb-kalotan.scm
r13802 r35102 1 1 ;;;; amb-kalotan.scm 2 2 3 ( require-extension amb)3 (use amb amb-extras) 4 4 5 5 ;; The following code is a rewrite of an example from the book "Teach Yourself … … 22 22 23 23 (define (solve-kalotan-puzzle) 24 25 (define (xor a? b?) (if (and a? b?) #f (or a? b?))) 26 27 (let ((parent1 (amb 'male 'female)) 28 (parent2 (amb 'male 'female)) 29 (kibi (amb 'male 'female)) 30 (kibi-self-desc (amb 'male 'female)) 31 (kibi-lied? (amb #t #f)) ) 32 24 ; 25 (let ( 26 (parent1 (amb 'male 'female)) 27 (parent2 (amb 'male 'female)) 28 (kibi (amb 'male 'female)) 29 (kibi-self-desc (amb 'male 'female)) 30 (kibi-lied? (amb #t #f)) ) 31 ; 33 32 (amb-assert (not (eq? parent1 parent2))) 34 33 ; 35 34 (when kibi-lied? 36 (amb-assert (xor (and (eq? kibi-self-desc 'male) 37 (eq? kibi 'female)) 38 (and (eq? kibi-self-desc 'female) 39 (eq? kibi 'male)))) ) 40 35 (amb-assert 36 (xor (and (eq? kibi-self-desc 'male) (eq? kibi 'female)) 37 (and (eq? kibi-self-desc 'female) (eq? kibi 'male)))) ) 38 ; 41 39 (unless kibi-lied? 42 (amb-assert (xor (and (eq? kibi-self-desc 'male) 43 (eq? kibi 'male)) 44 (and (eq? kibi-self-desc 'female) 45 (eq? kibi 'female)))) ) 46 40 (amb-assert 41 (xor (and (eq? kibi-self-desc 'male) (eq? kibi 'male)) 42 (and (eq? kibi-self-desc 'female) (eq? kibi 'female)))) ) 43 ; 47 44 (when (eq? parent1 'male) 48 (amb-assert (and (eq? kibi-self-desc 'male) 49 (xor (and (eq? kibi 'female) 50 (not kibi-lied?)) 51 (and (eq? kibi 'male) 52 kibi-lied?)))) ) 53 45 (amb-assert 46 (and (eq? kibi-self-desc 'male) 47 (xor (and (eq? kibi 'female) (not kibi-lied?)) 48 (and (eq? kibi 'male) kibi-lied?)))) ) 49 ; 54 50 (when (eq? parent1 'female) 55 (amb-assert (and (eq? kibi 'female) 56 kibi-lied?)) ) 57 51 (amb-assert (and (eq? kibi 'female) kibi-lied?)) ) 52 ; 58 53 (list parent1 parent2 kibi) ) ) -
release/4/amb/trunk/amb-money.scm
r14208 r35102 1 1 ;;;; amb-money.scm 2 2 3 ( require-extensionsrfi-1 amb amb-extras)3 (use srfi-1 amb amb-extras) 4 4 5 5 ;; Assign different numerals to different symbols … … 27 27 28 28 (define (solve-money-puzzle) 29 30 (let ((trial 0) 31 (m 1) ) 32 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)) ) ) 37 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) ) ) 44 29 ; 30 (let ( 31 (digits '(0 1 2 3 4 5 6 7 8 9)) 32 (trial 0) 33 (m 1) ) 34 ; 35 (let ( 36 (p1 (amb 0 1)) 37 (p2 (amb 0 1)) 38 (p3 (amb 0 1)) 39 (d (choose digits) ) ) 40 ; 41 (let* ( 42 (e (choose (lset-difference equal? digits (list d)))) 43 (y (modulo (+ d e (* -10 p1)) 10)) 44 (n (choose (lset-difference equal? digits (list d e y)))) 45 (r (modulo (+ (* 10 p2) e (- p1) (- n)) 10)) 46 (o (modulo (+ (* 10 p3) n (- p2) (- e)) 10)) 47 (s (modulo (+ (* 9 m) o (- p3)) 10) ) ) 48 ; 45 49 (set! trial (add1 trial)) 46 50 ; 47 51 (required (distinct? (list s e n d m o r y))) 48 52 (required (= (+ d e) (+ (* 10 p1) y))) … … 50 54 (required (= (+ p2 e o) (+ (* 10 p3) n))) 51 55 (required (= (+ p3 s m) (+ (* 10 m) o))) 52 56 ; 53 57 ;; Result, including a number of recorded trials 54 58 `((,trial trials) -
release/4/amb/trunk/amb-pythagorean.scm
r34107 r35102 2 2 ;;;; From "Continuations by example" ..." by Matt Might 3 3 4 ( require-extension amb)4 (use amb amb-extras) 5 5 6 (let ((a (amb 1 2 3 4 5 6 7)) 7 (b (amb 1 2 3 4 5 6 7)) 8 (c (amb 1 2 3 4 5 6 7))) 9 10 ; We're looking for dimensions of a legal right 11 ; triangle using the Pythagorean theorem: 6 (define (pythagorean) 12 7 ; 13 (amb-assert (= (* c c) (+ (* a a) (* b b)))) 14 15 ; And, we want the second side to be the shorter one: 16 ; 17 (amb-assert (< b a)) 18 19 ; Print out the answer: 20 ; 21 (print " a = " a ", b = " b ", c = " c)) 8 (let ( 9 (a (amb 1 2 3 4 5 6 7)) 10 (b (amb 1 2 3 4 5 6 7)) 11 (c (amb 1 2 3 4 5 6 7)) ) 12 ; 13 ; We're looking for dimensions of a legal right 14 ; triangle using the Pythagorean theorem: 15 ; 16 (amb-assert (= (* c c) (+ (* a a) (* b b)))) 17 ; 18 ; And, we want the second side to be the shorter one: 19 ; 20 (amb-assert (< b a)) 21 ; 22 ; the answer: 23 ; 24 (list a b c) ) ) -
release/4/amb/trunk/amb-sat-solve.scm
r23312 r35102 1 1 ;;;; amb-sat-solve.scm 2 ;;;; From "Continuations by example" ..." by Matt Might3 2 4 (require-extension amb) 5 6 (define (implies a b) (or (not a) b)) 7 8 ;; The is not the most efficient implementation, 9 ;; because a continuation is captured for each 10 ;; occurrence of the same variable, instead of 11 ;; one for each variable. 12 13 (define-syntax sat-solve 14 (syntax-rules (and or implies not) 15 ((_ ?formula ?body) 16 (sat-solve ?formula ?body ?formula) ) 17 18 ((_ (not ?phi) ?body ?assertion) 19 (sat-solve ?phi ?body ?assertion) ) 20 21 ((_ (and ?phi) ?body ?assertion) 22 (sat-solve ?phi ?body ?assertion) ) 23 24 ((_ (and ?phi1 ?phi2 ...) ?body ?assertion) 25 (sat-solve ?phi1 (sat-solve (and ?phi2 ...) ?body ?assertion)) ) 26 27 ((_ (or ?phi) ?body ?assertion) 28 (sat-solve ?phi ?body ?assertion) ) 29 30 ((_ (or ?phi1 ?phi2 ...) ?body ?assertion) 31 (sat-solve ?phi1 (sat-solve (or ?phi2 ...) ?body ?assertion)) ) 32 33 ((_ (implies ?phi1 ?phi2) ?body ?assertion) 34 (sat-solve ?phi1 (sat-solve ?phi2 ?body ?assertion)) ) 35 36 ((_ #t ?body ?assertion) 37 ?body ) 38 39 ((_ #f ?body ?assertion) 40 (amb-failure-continuation) ) 41 42 ((_ v ?body ?assertion) 43 (let ((v (amb #t #f))) 44 (amb-assert ?assertion) 45 ?body ) ) ) ) 46 3 (include "../amb-pl-solver") 4 (import amb-pl-solver) 47 5 48 6 ; The following prints (#f #f #t) 49 (sat-solve (and (implies a (not b)) 50 (not a) 51 c) 52 (print "a = " a ", b = " b ", c = " c)) 7 (define (sat-solve) 8 (with-solution (and (implies a (not b)) (not a) c) 9 (list a b c) ) ) -
release/4/amb/trunk/amb.meta
r34138 r35102 13 13 (condition-utils "1.0.0")) 14 14 (test-depends test) 15 (files "amb.meta" "amb.setup" "amb.scm" "amb-extras.scm" 16 "amb-dwelling.scm" "amb.release-info" "amb-pythagorean.scm" "amb-money.scm" "amb-kalotan.scm" "amb-sat-solve.scm" 17 "tests/run.scm") ) 18 15 (files 16 "amb.meta" "amb.setup" 17 "amb.scm" "amb-extras.scm" 18 "amb-pl-solver.scm" 19 "amb-dwelling.scm" "amb-pythagorean.scm" "amb-money.scm" "amb-kalotan.scm" "amb-sat-solve.scm" 20 "tests/run.scm" "tests/amb-test.scm") ) -
release/4/amb/trunk/amb.scm
r34422 r35102 22 22 shuffle) 23 23 24 (import scheme) 25 26 (import chicken) 27 28 (import 24 (import scheme chicken) 25 (use 29 26 (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 27 (only extras random) 28 (only (srfi 1) map!) 37 29 (only miscmacros let/cc define-parameter) 38 30 (only type-errors warning-argument-type) 39 31 (only condition-utils make-exn-condition+)) 40 (require-library41 miscmacros type-errors condition-utils)42 32 43 33 ;;; … … 49 39 50 40 (define make-amb-exhausted-condition 51 (let ((+cached-amb-exhausted-condition+ 52 (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb))) 41 (let ( 42 (+cached-amb-exhausted-condition+ 43 (make-exn-condition+ 'amb "expression tree exhausted" '() 'amb))) 44 ; 53 45 (lambda () +cached-amb-exhausted-condition+) ) ) 54 46 … … 136 128 (let ((afc #f)) 137 129 (dynamic-wind 130 ; 138 131 (lambda () 139 132 (set! afc (amb-failure-continuation)) ) 133 ; 140 134 (lambda () 141 135 (let/cc return 142 (let* ((root (list #f)) 143 (head root) ) 136 (let* ( 137 (root (list #f)) 138 (head root) ) 139 ; 144 140 (amb-failure-continuation (lambda () (return (cdr root)))) 145 141 (set-cdr! head (list (thunk))) 146 142 (set! head (cdr head)) 147 143 ((amb-failure-continuation))) ) ) 144 ; 148 145 (lambda () 149 146 (amb-failure-continuation afc) ) ) ) ) … … 152 149 153 150 (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)))) ) ) ) 151 ; 152 (define (car< x y) 153 (fx< (car x) (car y)) ) 154 ; 155 (let* ( 156 (len (length ls)) 157 (tagged-ls (map (lambda (x) (cons (random len) x)) ls)) ) 158 ; 159 (map! cdr (sort! tagged-ls car<) ) ) ) 160 160 161 161 ) ;module amb -
release/4/amb/trunk/tests/run.scm
r34107 r35102 1 ;;;; amb test2 (use test)3 1 4 ( test-begin"amb")2 (define EGG-NAME "amb") 5 3 6 (include "../amb-kalotan") 7 (test "kalotan" 8 '(female male female) 9 (solve-kalotan-puzzle)) 4 ;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>" 10 5 11 (include "../amb-money") 12 (test "amb-money" 13 '(9 5 6 7 + 1 0 8 5 = 1 0 6 5 2) 14 (caddr (solve-money-puzzle))) 6 (use files) 15 7 16 (include "../amb-dwelling") 17 (test "amb-dwelling" 18 '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)) 19 (solve-dwelling-puzzle)) 8 ;no -disable-interrupts 9 (define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2") 20 10 21 (test-end "amb") 11 (define *args* (argv)) 12 13 (define (test-name #!optional (eggnam EGG-NAME)) 14 (string-append eggnam "-test") ) 15 16 (define (egg-name #!optional (def EGG-NAME)) 17 (cond 18 ((<= 4 (length *args*)) 19 (cadddr *args*) ) 20 (def 21 def ) 22 (else 23 (error 'test "cannot determine egg-name") ) ) ) 24 25 ;;; 26 27 (set! EGG-NAME (egg-name)) 28 29 (define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*)) 30 (let ((tstnam (test-name eggnam))) 31 (print "*** csi ***") 32 (system (string-append "csi -s " (make-pathname #f tstnam "scm"))) 33 (newline) 34 (print "*** csc (" cscopts ") ***") 35 (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm"))) 36 (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) ) 37 38 (define (run-tests eggnams #!optional (cscopts *csc-options*)) 39 (for-each (cut run-test <> cscopts) eggnams) ) 40 41 ;;; 42 43 (run-test)
Note: See TracChangeset
for help on using the changeset viewer.