Changeset 13802 in project


Ignore:
Timestamp:
03/17/09 23:44:56 (11 years ago)
Author:
Kon Lovett
Message:

Added extras, test.

Location:
release/4/amb/trunk
Files:
1 added
7 edited

Legend:

Unmodified
Added
Removed
  • release/4/amb/trunk/amb-dwelling.scm

    r13801 r13802  
    11;;;; amb-dwelling.scm
    22
    3 (require-extension amb)
     3(require-extension amb amb-extras)
    44
    55;; Baker, Cooper, Fletcher, Miller, and Smith live on different
     
    1313;; Where does everyone live?
    1414
    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))
    1718        (cooper (amb 1 2 3 4 5))
    18         (fletcher  (amb 1 2 3 4 5))
     19        (fletcher (amb 1 2 3 4 5))
    1920        (miller (amb 1 2 3 4 5))
    20         (smith  (amb 1 2 3 4 5)))
     21        (smith (amb 1 2 3 4 5)))
    2122
    2223    ;; They live on different floors.
    23     (amb-assert (distinct? (list baker cooper fletcher miller smith)))
     24    (required (distinct? (list baker cooper fletcher miller smith)))
    2425
    2526    ;; Baker does not live on the top floor.
    26     (amb-assert (not (= baker 5)))
     27    (required (not (= baker 5)))
    2728
    2829    ;; Cooper does not live on the bottom floor.
    29     (amb-assert (not (= cooper 1)))
     30    (required (not (= cooper 1)))
    3031
    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)))
    3535
    3636    ;; Miller lives on a higher floor than does Cooper.
    37     (amb-assert (> miller cooper))
     37    (required (> miller cooper))
    3838
    3939    ;; 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)))
    4141
    4242    ;; 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)))
    4444
    4545    `((baker ,baker) (cooper ,cooper) (fletcher ,fletcher) (miller ,miller) (smith ,smith))) )
  • release/4/amb/trunk/amb-kalotan.scm

    r13801 r13802  
    5757
    5858    (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  
    11;;;; amb-money.scm
    22
    3 (require-extension amb srfi-1)
     3(require-extension amb amb-extras srfi-1)
    44
    55;; Assign different numerals to different symbols
     
    2525;;    original domain space of a variable from 10 (or 9) to 1 (or to 2 if we
    2626;;    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))
    3327
    34 (define (money)
     28(define (solve-money-puzzle)
    3529
    36   (define (set-difference xs ys)
    37     (filter (lambda(x) (not (member x ys))) xs))
     30  (let ((trial 0)
     31        (m 1) )
    3832
    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)) ) )
    4337
    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) ) )
    4544
    46   (let* ((p1 (amb 0 1))
    47          (p2 (amb 0 1))
    48          (p3 (amb 0 1))
     45        (set! trial (add1 trial))
    4946
    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)))
    5652
    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  
    1414  "tests"
    1515  "amb.scm"
     16  "amb-extras.scm"
    1617  "amb.setup") )
  • release/4/amb/trunk/amb.scm

    r13801 r13802  
    1111
    1212;;; Module `amb'
     13 
     14(require-library data-structures extras)
    1315
    1416(module amb (;export
     
    2123  amb-thunks
    2224  amb-find-thunk
    23   amb-collect-thunk
    24   #;choose
    25   #;one
    26   #;all
    27   #;required)
     25  amb-collect-thunk)
    2826
    29 (import scheme chicken)
     27(import scheme chicken data-structures extras)
    3028
    3129;;
     
    5048     ((amb-failure-continuation)) )
    5149    ((_ ?expr0 ...)
    52      (amb-thunks (shuffle (list (lambda () ?expr0) ...))) ) ) )
     50     (amb-thunks (shuffle (list (lambda () ?expr0) ...) random)) ) ) )
    5351
    5452(define-syntax amb-find
     
    6765  (syntax-rules ()
    6866    ((_ ?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))) ) ) )
    9868
    9969;;
  • release/4/amb/trunk/amb.setup

    r13799 r13802  
    55(verify-extension-name "amb")
    66
    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.