Changeset 13802 in project

Timestamp:

03/17/09 23:44:56 (11 years ago)

Author:

Kon Lovett

Message:

Added extras, test.

Location:

release/4/amb/trunk

Files:

• amb-dwelling.scm (modified) (2 diffs)
• amb-extras.scm (added)
• amb-kalotan.scm (modified) (1 diff)
• amb-money.scm (modified) (2 diffs)
• amb.meta (modified) (1 diff)
• amb.scm (modified) (4 diffs)
• amb.setup (modified) (1 diff)
• tests/run.scm (modified) (1 diff)

release/4/amb/trunk/amb-dwelling.scm

@@ -1 +1 @@
 ;;;; amb-dwelling.scm
 
-(require-extension amb)
+(require-extension amb amb-extras)
 
 ;; Baker, Cooper, Fletcher, Miller, and Smith live on different
@@ -13 +13 @@
 ;; Where does everyone live?
 
-(define (multiple-dwelling)
-  (let ((baker  (amb 1 2 3 4 5))
+(define (solve-dwelling-puzzle)
+
+  (let ((baker (amb 1 2 3 4 5))
         (cooper (amb 1 2 3 4 5))
-        (fletcher  (amb 1 2 3 4 5))
+        (fletcher (amb 1 2 3 4 5))
         (miller (amb 1 2 3 4 5))
-        (smith  (amb 1 2 3 4 5)))
+        (smith (amb 1 2 3 4 5)))
 
     ;; They live on different floors.
-    (amb-assert (distinct? (list baker cooper fletcher miller smith)))
+    (required (distinct? (list baker cooper fletcher miller smith)))
 
     ;; Baker does not live on the top floor.
-    (amb-assert (not (= baker 5)))
+    (required (not (= baker 5)))
 
     ;; Cooper does not live on the bottom floor.
-    (amb-assert (not (= cooper 1)))
+    (required (not (= cooper 1)))
 
-    ;; Fletcher does not live on either the top 
-    ;; or the bottom floor.
-    (amb-assert (not (= fletcher 5)))
-    (amb-assert (not (= fletcher 1)))
+    ;; Fletcher does not live on either the top or the bottom floor.
+    (required (not (= fletcher 5)))
+    (required (not (= fletcher 1)))
 
     ;; Miller lives on a higher floor than does Cooper.
-    (amb-assert (> miller cooper))
+    (required (> miller cooper))
 
     ;; Smith does not live on a floor adjacent to Fletcher's. 
-    (amb-assert (not (= (abs (- smith fletch)) 1)))
+    (required (not (= (abs (- smith fletcher)) 1)))
 
     ;; Fletcher does not live on a floor adjacent to Cooper's.
-    (amb-assert (not (= (abs (- fletcher cooper)) 1)))
+    (required (not (= (abs (- fletcher cooper)) 1)))
 
     `((baker ,baker) (cooper ,cooper) (fletcher ,fletcher) (miller ,miller) (smith ,smith))) )

release/4/amb/trunk/amb-kalotan.scm

@@ -57 +57 @@
 
     (list parent1 parent2 kibi) ) )
-
-(let* ((res (amb-collect (solve-kalotan-puzzle)))
-       (ls (car res))
-       (p1 (car ls))
-       (p2 (cadr ls))
-       (kibi (caddr ls)) )
-  (print "Gender Parent 1 " p1 " Parent 2 " p2 " Kibi " kibi)
-  (newline) )

release/4/amb/trunk/amb-money.scm

@@ -1 +1 @@
 ;;;; amb-money.scm
 
-(require-extension amb srfi-1)
+(require-extension amb amb-extras srfi-1)
 
 ;; 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
 ;;    take into account the effect of 'modulo application)
-;;
-;; Example:
-;; (money) ==>
-;; ((4385 trials)
-;;  (s e n d + m o r e = m o n e y)
-;;  (9 5 6 7 + 1 0 8 5 = 1 0 6 5 2))
 
-(define (money)
+(define (solve-money-puzzle)
 
-  (define (set-difference xs ys)
-    (filter (lambda(x) (not (member x ys))) xs))
+  (let ((trial 0)
+        (m 1) )
 
-  (define (distinct? xs)
-    (cond ((null? xs) #t)
-          ((member (car xs) (cdr xs)) #f)
-          (else (distinct? (cdr xs)))))
+    (let ((p1 (amb 0 1))
+          (p2 (amb 0 1))
+          (p3 (amb 0 1))
+          (d (choose '(0 1 2 3 4 5 6 7 8 9)) ) )
 
-  (define trial 0)
+      (let* ((e (choose (lset-difference equal? '(0 1 2 3 4 5 6 7 8 9) (list d))))
+             (y (modulo (+ d e (* -10 p1)) 10))
+             (n (choose (lset-difference equal? '(0 1 2 3 4 5 6 7 8 9) (list d e y))))
+             (r (modulo (+ (* 10 p2) e (- p1) (- n)) 10))
+             (o (modulo (+ (* 10 p3) n (- p2) (- e)) 10))
+             (s (modulo (+ (* 9 m) o (- p3)) 10) ) )
 
-  (let* ((p1 (amb 0 1))
-         (p2 (amb 0 1))
-         (p3 (amb 0 1))
+        (set! trial (add1 trial))
 
-         (d (amb/random '(0 1 2 3 4 5 6 7 8 9)))
-         (e (amb/random (set-difference '(0 1 2 3 4 5 6 7 8 9) (list d))))
-         (y (modulo (+ d e (* -10 p1)) 10))
-         (n (amb/random (set-difference '(0 1 2 3 4 5 6 7 8 9) (list d e y))))
-         (r (modulo (+ (* 10 p2) e (- p1) (- n)) 10))
-         (o (modulo (+ (* 10 p3) n (- p2) (- e)) 10))
+        (required (distinct? (list s e n d m o r y)))
+        (required (= (+ d e)    (+ (* 10 p1) y)))
+        (required (= (+ p1 n r) (+ (* 10 p2) e)))
+        (required (= (+ p2 e o) (+ (* 10 p3) n)))
+        (required (= (+ p3 s m) (+ (* 10 m)  o)))
 
-         (m 1)
-         (s (modulo (+ (* 9 m) o (- p3)) 10) ) )
-
-    (set! trial (+ trial 1))
-
-    (assert (distinct? (list s e n d m o r y)))
-    (assert (= (+ d e)    (+ (* 10 p1) y)))
-    (assert (= (+ p1 n r) (+ (* 10 p2) e)))
-    (assert (= (+ p2 e o) (+ (* 10 p3) n)))
-    (assert (= (+ p3 s m) (+ (* 10 m)  o)))
-
-    ;; Result, including a number of recorded trials
-    `((,trial trials)
-      (s e n d + m o r e = m o n e y)
-      (,s ,e ,n ,d '+ ,m ,o ,r ,e '= ,m ,o ,n ,e ,y)) ) )
+        ;; Result, including a number of recorded trials
+        `((,trial trials)
+          (s e n d + m o r e = m o n e y)
+          (,s ,e ,n ,d + ,m ,o ,r ,e = ,m ,o ,n ,e ,y)) ) ) ) )

release/4/amb/trunk/amb.meta

@@ -14 +14 @@
   "tests"
   "amb.scm"
+  "amb-extras.scm"
   "amb.setup") )

release/4/amb/trunk/amb.scm

@@ -11 +11 @@
 
 ;;; Module `amb'
+  
+(require-library data-structures extras)
 
 (module amb (;export
@@ -21 +23 @@
   amb-thunks
   amb-find-thunk
-  amb-collect-thunk
-  #;choose
-  #;one
-  #;all
-  #;required)
+  amb-collect-thunk)
 
-(import scheme chicken)
+(import scheme chicken data-structures extras)
 
 ;;
@@ -50 +48 @@
      ((amb-failure-continuation)) )
     ((_ ?expr0 ...)
-     (amb-thunks (shuffle (list (lambda () ?expr0) ...))) ) ) )
+     (amb-thunks (shuffle (list (lambda () ?expr0) ...) random)) ) ) )
 
 (define-syntax amb-find
@@ -67 +65 @@
   (syntax-rules ()
     ((_ ?expr)
-     (if (not ?expr) ((amb-failure-continuation))) ) ) )
-
-;;
-
-#;
-(define-syntax choose
-  (syntax-rules ()
-    ((_ ?expr0 ...)
-     (amb/random ?expr0 ...) ) ) )
-
-#;
-(define-syntax one
-  (syntax-rules ()
-    ((_ ?expr)
-     (amb-find ?expr) )
-    ((_ ?expr ?fail)
-     (amb-find ?expr ?fail) ) ) )
-
-#;
-(define-syntax all
-  (syntax-rules ()
-    ((_ ?expr)
-     (amb-collect ?expr) ) ) )
-
-#;
-(define-syntax required
-  (syntax-rules ()
-    ((_ ?expr)
-     (amb-assert ?expr) ) ) )
+     (unless ?expr ((amb-failure-continuation))) ) ) )
 
 ;;

release/4/amb/trunk/amb.setup

@@ -5 +5 @@
 (verify-extension-name "amb")
 
-(setup-shared-extension-module (extension-name) (extension-version "2.0.0"))
+(setup-shared-extension-module 'amb (extension-version "2.0.0"))
+
+(setup-shared-extension-module 'amb-extras (extension-version "2.0.0"))

release/4/amb/trunk/tests/run.scm

@@ +1 @@
+;;;; amb test
+
+(include "../amb-kalotan")
+(assert (equal? '(female male female) (solve-kalotan-puzzle)))
+
+(include "../amb-money")
+(assert (equal? '(9 5 6 7 + 1 0 8 5 = 1 0 6 5 2) (caddr (solve-money-puzzle))))
+
+(include "../amb-dwelling")
+(assert (equal? '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)) (solve-dwelling-puzzle)))