Changeset 13801 in project


Ignore:
Timestamp:
03/17/09 19:55:25 (11 years ago)
Author:
Kon Lovett
Message:

Save.

Location:
release/4/amb/trunk
Files:
5 edited

Legend:

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

    r13799 r13801  
    1 #|
    2 Baker, Cooper, Fletcher, Miller, and Smith live on different
    3 floors of an apartment house that contains only five floors. Baker
    4 does not live on the top floor. Cooper does not live on the bottom
    5 floor. Fletcher does not live on either the top or the bottom
    6 floor. Miller lives on a higher floor than does Cooper. Smith does not
    7 live on a floor adjacent to Fletcher's. Fletcher does not live on a
    8 floor adjacent to Cooper's. Where does everyone live?
    9 |#
     1;;;; amb-dwelling.scm
     2
     3(require-extension amb)
     4
     5;; Baker, Cooper, Fletcher, Miller, and Smith live on different
     6;; floors of an apartment house that contains only five floors. Baker
     7;; does not live on the top floor. Cooper does not live on the bottom
     8;; floor. Fletcher does not live on either the top or the bottom
     9;; floor. Miller lives on a higher floor than does Cooper. Smith does not
     10;; live on a floor adjacent to Fletcher's. Fletcher does not live on a
     11;; floor adjacent to Cooper's.
     12;;
     13;; Where does everyone live?
    1014
    1115(define (multiple-dwelling)
     
    1519        (miller (amb 1 2 3 4 5))
    1620        (smith  (amb 1 2 3 4 5)))
     21
    1722    ;; They live on different floors.
    18     (require
    19       (distinct? (list baker cooper fletcher miller smith)))
     23    (amb-assert (distinct? (list baker cooper fletcher miller smith)))
    2024
    2125    ;; Baker does not live on the top floor.
    22     (require (not (= baker 5)))
     26    (amb-assert (not (= baker 5)))
    2327
    2428    ;; Cooper does not live on the bottom floor.
    25     (require (not (= cooper 1)))
     29    (amb-assert (not (= cooper 1)))
    2630
    2731    ;; Fletcher does not live on either the top
    2832    ;; or the bottom floor.
    29     (require (not (= fletcher 5)))
    30     (require (not (= fletcher 1)))
     33    (amb-assert (not (= fletcher 5)))
     34    (amb-assert (not (= fletcher 1)))
    3135
    3236    ;; Miller lives on a higher floor than does Cooper.
    33     (require (> miller cooper))
     37    (amb-assert (> miller cooper))
    3438
    3539    ;; Smith does not live on a floor adjacent to Fletcher's.
    36     (require (not (= (abs (- smith fletch)) 1)))
     40    (amb-assert (not (= (abs (- smith fletch)) 1)))
    3741
    3842    ;; Fletcher does not live on a floor adjacent to Cooper's.
    39     (require (not (= (abs (- fletcher cooper)) 1)))
     43    (amb-assert (not (= (abs (- fletcher cooper)) 1)))
    4044
    41     (list (list 'baker baker)
    42           (list 'cooper cooper)
    43           (list 'fletcher fletcher)
    44           (list 'miller miller)
    45           (list 'smith smith))))
     45    `((baker ,baker) (cooper ,cooper) (fletcher ,fletcher) (miller ,miller) (smith ,smith))) )
  • release/4/amb/trunk/amb-kalotan.scm

    r13799 r13801  
    11;;;; amb-kalotan.scm
    2 ;;;; A solution for the Kalotan puzzle using amb
    32
    43(require-extension amb)
    54
    6 (define (xor a? b?)
    7   (if (and a? b?) #f (or a? b?)))
     5;; The following code is a rewrite of an example from the book "Teach Yourself
     6;; Scheme in Fixnum Days" by Dorai Sitaram. The book gives the following problem
     7;; setting:
     8;;
     9;; The Kalotans are a tribe with a peculiar quirk. Their males always tell the
     10;; truth. Their females never make two consecutive true statements, or two
     11;; consecutive untrue statements.
     12;;
     13;; An anthropologist (let's call him Worf) has begun to study them. Worf does not
     14;; yet know the Kalotan language. One day, he meets a Kalotan (heterosexual)
     15;; couple and their child Kibi. Worf asks Kibi: "Are you a boy?" Kibi answers in
     16;; Kalotan, which of course Worf doesn't understand.
     17;;
     18;; Worf turns to the parents (who know English) for explanation. One of them says:
     19;; "Kibi said: 'I am a boy.'" The other adds: "Kibi is a girl. Kibi lied.
     20;;
     21;; Solve for the sex of the parents and Kibi.
    822
    923(define (solve-kalotan-puzzle)
    10   (let ((parent1 (amb 'm 'f))
    11         (parent2 (amb 'm 'f))
    12         (kibi (amb 'm 'f))
    13         (kibi-self-desc (amb 'm 'f))
    14         (kibi-lied? (amb #t #f)))
    15     (amb-assert
    16      (not (eq? parent1 parent2)))
    17     (if kibi-lied?
    18         (amb-assert
    19          (xor
    20           (and (eqv? kibi-self-desc 'm)
    21                (eqv? kibi 'f))
    22           (and (eqv? kibi-self-desc 'f)
    23                (eqv? kibi 'm)))))
    24     (if (not kibi-lied?)
    25         (amb-assert
    26          (xor
    27           (and (eqv? kibi-self-desc 'm)
    28                (eqv? kibi 'm))
    29           (and (eqv? kibi-self-desc 'f)
    30                (eqv? kibi 'f)))))
    31     (if (eqv? parent1 'm)
    32         (amb-assert
    33          (and
    34           (eqv? kibi-self-desc 'm)
    35           (xor
    36            (and (eqv? kibi 'f)
    37                 (eqv? kibi-lied? #f))
    38            (and (eqv? kibi 'm)
    39                 (eqv? kibi-lied? #t))))))
    40     (if (eqv? parent1 'f)
    41         (amb-assert
    42          (and
    43           (eqv? kibi 'f)
    44           (eqv? kibi-lied? #t))))
    45     (list parent1 parent2 kibi)))
    4624
    47 (write (amb-collect (solve-kalotan-puzzle)))
    48 (newline)
     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
     33    (amb-assert (not (eq? parent1 parent2)))
     34
     35    (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
     41    (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
     47    (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
     54    (when (eq? parent1 'female)
     55      (amb-assert (and (eq? kibi 'female)
     56                       kibi-lied?)) )
     57
     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

    r13799 r13801  
    1 (require-extension amb)
     1;;;; amb-money.scm
     2
     3(require-extension amb srfi-1)
    24
    35;; Assign different numerals to different symbols
     
    1820;;    ordered in some specific way within the 'let* clause,
    1921;;    rather than the 'let one.
    20 ;; 2. Later variables use the info from the previous ones to reduce
    21 their
    22 ;;    domains. This is a constraint propagation mechanism for this
    23 puzzle.
    24 ;; 3. Some assignments are deterministic (no amb or choose is directly
    25 used),
    26 ;;    which significantly reduces the original domain space of a
    27 variable
    28 ;;    from 10 (or 9) to 1 (or to 2 if we take into account the effect
    29 of
    30 ;;    'modulo application)
     22;; 2. Later variables use the info from the previous ones to reduce their
     23;;    domains. This is a constraint propagation mechanism for this puzzle.
     24;; 3. Some assignments are deterministic, which significantly reduces the
     25;;    original domain space of a variable from 10 (or 9) to 1 (or to 2 if we
     26;;    take into account the effect of 'modulo application)
    3127;;
    3228;; Example:
     
    3531;;  (s e n d + m o r e = m o n e y)
    3632;;  (9 5 6 7 + 1 0 8 5 = 1 0 6 5 2))
    37 ;;
     33
    3834(define (money)
    3935
    40    (define (set-difference xs ys)
    41       (filter (lambda(x)(not (member x ys))) xs))
     36  (define (set-difference xs ys)
     37    (filter (lambda(x) (not (member x ys))) xs))
    4238
    43    (define (distinct? xs)
    44       (cond
    45          ((null? xs) #t)
    46          ((member (car xs) (cdr xs)) #f)
    47          (else (distinct? (cdr xs)))))
     39  (define (distinct? xs)
     40    (cond ((null? xs) #t)
     41          ((member (car xs) (cdr xs)) #f)
     42          (else (distinct? (cdr xs)))))
    4843
    49    (define trial 0)
     44  (define trial 0)
    5045
    51    (let* (
     46  (let* ((p1 (amb 0 1))
     47         (p2 (amb 0 1))
     48         (p3 (amb 0 1))
    5249
    53       (p1 (amb 0 1))
    54       (p2 (amb 0 1))
    55       (p3 (amb 0 1))
     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))
    5656
    57       (d (choose '(0 1 2 3 4 5 6 7 8 9)))
    58       (e (choose (set-difference '(0 1 2 3 4 5 6 7 8 9) (list d))))
    59       (y (modulo (+ d e (* -10 p1)) 10))
    60       (n (choose (set-difference '(0 1 2 3 4 5 6 7 8 9)
    61          (list d e y))))
    62       (r (modulo (+ (* 10 p2) e (- p1) (- n)) 10))
    63       (o (modulo (+ (* 10 p3) n (- p2) (- e)) 10))
     57         (m 1)
     58         (s (modulo (+ (* 9 m) o (- p3)) 10) ) )
    6459
    65       (m 1)
    66       (s (modulo (+ (* 9 m) o (- p3)) 10)))
     60    (set! trial (+ trial 1))
    6761
     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)))
    6867
    69       (set! trial (+ trial 1))
    70 
    71       (assert (distinct? (list s e n d m o r y)))
    72       (assert (= (+ d e)    (+ (* 10 p1) y)))
    73       (assert (= (+ p1 n r) (+ (* 10 p2) e)))
    74       (assert (= (+ p2 e o) (+ (* 10 p3) n)))
    75       (assert (= (+ p3 s m) (+ (* 10 m)  o)))
    76 
    77       ;; Result, including a number of recorded trials
    78       (list
    79          (list trial 'trials)
    80          (list 's 'e 'n 'd '+ 'm 'o 'r 'e '= 'm 'o 'n 'e 'y)
    81          (list s e n d '+ m o r e '= m o n e y))))
     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)) ) )
  • release/4/amb/trunk/amb.meta

    r13799 r13801  
    33((egg "amb.egg")
    44 (category data)
    5  (author "[[thomas chust]] and [[kon lovett]]")
     5 (author "[[thomas chust]]")
    66 (license "BSD")
    77 (doc-from-wiki)
  • release/4/amb/trunk/amb.scm

    r13799 r13801  
    11;;;; amb.scm
    22;;;; The fundamental non-deterministic backtracking operator
     3;;;; Chicken 4 Port: Kon Lovett, Mar '09
    34
    45(declare
    56  (usual-integrations)
    6   (fixnum-arithmetic))
     7  (fixnum-arithmetic)
     8  (inline)
     9  (local)
     10  (no-procedure-checks))
     11
     12;;; Module `amb'
    713
    814(module amb (;export
     
    1420  amb-failure-continuation
    1521  amb-thunks
    16   amb-find-thunk amb-collect-thunk)
     22  amb-find-thunk
     23  amb-collect-thunk
     24  #;choose
     25  #;one
     26  #;all
     27  #;required)
     28
     29(import scheme chicken)
     30
     31;;
     32
     33(define-syntax let/cc
     34  (syntax-rules ()
     35    ((_ ?k ?expr0 ...)
     36     (call-with-current-continuation (lambda (?k) ?expr0 ...)) ) ) )
     37
     38;;
    1739
    1840(define-syntax amb
    1941  (syntax-rules ()
    20     ((amb)
    21      ((amb-failure-continuation)))
    22     ((amb x ...)
    23      (amb-thunks (list (lambda () x) ...)))))
     42    ((_)
     43     ((amb-failure-continuation)) )
     44    ((_ ?expr0 ...)
     45     (amb-thunks (list (lambda () ?expr0) ...)) ) ) )
    2446
    2547(define-syntax amb/random
    2648  (syntax-rules ()
    27     ((amb)
    28      ((amb-failure-continuation)))
    29     ((amb x ...)
    30      (amb-thunks (shuffle (list (lambda () x) ...))))))
     49    ((_)
     50     ((amb-failure-continuation)) )
     51    ((_ ?expr0 ...)
     52     (amb-thunks (shuffle (list (lambda () ?expr0) ...))) ) ) )
    3153
    3254(define-syntax amb-find
    3355  (syntax-rules ()
    34     ((amb-find x)
    35      (amb-find-thunk (lambda () x)))
    36     ((amb-find x f)
    37      (amb-find-thunk (lambda () x) (lambda () f)))))
     56    ((_ ?expr)
     57     (amb-find-thunk (lambda () ?expr)) )
     58    ((_ ?expr ?fail)
     59     (amb-find-thunk (lambda () ?expr) (lambda () ?fail)) ) ) )
    3860
    3961(define-syntax amb-collect
    4062  (syntax-rules ()
    41     ((amb-collect x)
    42      (amb-collect-thunk (lambda () x)))))
     63    ((_ ?expr)
     64     (amb-collect-thunk (lambda () ?expr)) ) ) )
    4365
    4466(define-syntax amb-assert
    4567  (syntax-rules ()
    46     ((amb-assert ok?)
    47      (if (not ok?) ((amb-failure-continuation))))))
     68    ((_ ?expr)
     69     (if (not ?expr) ((amb-failure-continuation))) ) ) )
    4870
    49 (define (amb-exhausted)
    50   (signal
    51    (make-composite-condition
    52     (make-property-condition
    53      'exn
    54      'message "expression tree exhausted" 'location 'amb 'arguments '())
    55     (make-property-condition
    56      'amb))))
     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) ) ) )
     98
     99;;
     100
     101(define (make-exn-condition loc msg args)
     102  (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
     103
     104(define (make-amb-exhausted-condition)
     105  (make-composite-condition
     106   (make-exn-condition 'amb "expression tree exhausted" '())
     107   (make-property-condition 'amb)) )
     108
     109(define (amb-exhausted) (signal (make-amb-exhausted-condition)))
     110
     111;;
    57112
    58113(define amb-failure-continuation
    59   (make-parameter amb-exhausted))
     114  (make-parameter amb-exhausted
     115    (lambda (x)
     116      (cond ((procedure? x) x)
     117            (else
     118             (warning 'amb-failure-continuation "bad argument type - not a procedure" x)
     119             (amb-failure-continuation) ) ) ) ) )
     120
     121;;
    60122
    61123(define (amb-thunks thunks)
    62124  (let ((afc (amb-failure-continuation)))
    63     (call-with-current-continuation
    64      (lambda (arc)
    65        (let loop ((tt thunks))
    66          (if (null? tt)
    67              (begin
    68                (amb-failure-continuation afc)
    69                (afc))
    70              (begin
    71                (amb-failure-continuation (lambda () (loop (cdr tt))))
    72                (arc ((car tt))))))))))
     125    (let/cc arc
     126      (let loop ((tt thunks))
     127        (cond ((null? tt)
     128               (amb-failure-continuation afc)
     129               (afc) )
     130              (else
     131               (amb-failure-continuation (lambda () (loop (cdr tt))))
     132               (arc ((car tt))) ) ) ) ) ) )
    73133
    74134(define (amb-find-thunk thunk #!optional (failure amb-exhausted))
    75   (call-with-current-continuation
    76    (lambda (q)
    77      (parameterize ((amb-failure-continuation (lambda () (q (failure)))))
    78        (thunk)))))
     135  (let/cc q
     136    (parameterize ((amb-failure-continuation (lambda () (q (failure)))))
     137      (thunk) ) ) )
    79138
    80139(define (amb-collect-thunk thunk)
    81140  (let ((afc #f))
    82141    (dynamic-wind
    83         (lambda () (set! afc (amb-failure-continuation)))
    84         (lambda ()
    85           (call-with-current-continuation
    86            (lambda (q)
    87              (let* ((root (list #f))
    88                     (head root))
    89                (amb-failure-continuation (lambda () (q (cdr root))))
    90                (set-cdr! head (list (thunk)))
    91                (set! head (cdr head))
    92                ((amb-failure-continuation))))))
    93         (lambda () (amb-failure-continuation afc)))))
     142      (lambda ()
     143        (set! afc (amb-failure-continuation)) )
     144      (lambda ()
     145        (let/cc q
     146          (let* ((root (list #f))
     147                 (head root))
     148            (amb-failure-continuation (lambda () (q (cdr root))))
     149            (set-cdr! head (list (thunk)))
     150            (set! head (cdr head))
     151            ((amb-failure-continuation))) ) )
     152      (lambda ()
     153        (amb-failure-continuation afc) ) ) ) )
    94154
    95155) ;module amb
Note: See TracChangeset for help on using the changeset viewer.