<< Previous exercise (4.41) | Index | Next exercise (4.43) >>


Solution without permutation.

 (define stmts 
     '(((kitty 2) (betty 3)) 
       ((ethel 1) (joan 2)) 
       ((joan 3) (ethel 5)) 
       ((kitty 2) (betty 1)) 
       ((mary 4) (betty 1)))) 
 (define (no-conflict kv set) 
     (define (iter next) 
         (or (null? next) 
             (let ((k (caar next)) 
                   (v (cadar next))) 
                 (if (= (car kv) k) 
                     (and (= v (cadr kv)) (iter (cdr next))) 
                     (iter (cdr next)))))) 
     (iter set)) 
 (define (choose girl-says) 
     (define (iter rest-girl-says selected) 
         (if (null? rest-girl-says) 
             (display selected) 
             (let ((s1 (caar rest-girl-says)) 
                   (s2 (cadar rest-girl-says))) 
                 (let ((which (amb s1 s2))) 
                     (require (no-conflict which selected)) 
                     (iter (cdr rest-girl-says) (cons which selected)))))) 
     (iter girl-says '())) 
 (choose stmts) 


 (define (lier) 
   (let ((a (amb 1 2 3 4 5)) 
         (b (amb 1 2 3 4 5)) 
         (c (amb 1 2 3 4 5)) 
         (d (amb 1 2 3 4 5)) 
         (e (amb 1 2 3 4 5))) 
     (require (or (and (= d 2) (not (= a 3))) (and (not (= d 2)) (= a 3)))) 
     (require (or (and (= b 1) (not (= c 2))) (and (not (= b 1)) (= c 2)))) 
     (require (or (and (= c 3) (not (= b 5))) (and (not (= c 3)) (= b 5)))) 
     (require (or (and (= d 2) (not (= e 4))) (and (not (= d 2)) (= e 4)))) 
     (require (or (and (= e 4) (not (= a 1))) (and (not (= e 4)) (= a 1)))) 
     (require (distinct? (list a b c d e))) 
     (list a b c d e))) 
 result is: (3 5 2 1 4) 

With a ultility procedure "xor" defined like below, the solution to this exercise would look more elegant. I don't use "and" and "or" in its implementation, since a lot of work has to be done in order to make the amb-interpreter support them.

 (define (xor p q) (if p (not q) q)) 


 (define (flatmap f lst) 
   (if (null? lst) 
       (let ((result (f (car lst))) 
             (rest (flatmap f (cdr lst)))) 
         (if (or (pair? result) (null? result)) 
             (append result rest) 
             (cons result rest))))) 
 (define (permuta lst) 
   (if (null? lst) 
        (lambda (x) 
           (lambda (y) 
             (cons x y)) 
           (permuta (remove x lst)))) 
 (define (remove a lst) 
    ((null? lst) null) 
    ((eq? a (car lst)) (cdr lst)) 
    (else (cons (car lst) 
                (remove a (cdr lst)))))) 
 (define first car) 
 (define second cadr) 
 (define third caddr) 
 (define fourth cadddr) 
 (define (fifth x) 
   (car (cddddr x))) 
 (define (xor a b) 
   (and (or a b) 
        (not (and a b)))) 
 (define betty-restrictions 
   (lambda (lst) 
     (xor (eq? (second lst) 'kitty) 
          (eq? (third lst) 'betty)))) 
 (define ethel-restrictions 
   (lambda (lst) 
     (xor (eq? (first lst) 'ethel) 
          (eq? (second lst) 'john)))) 
 (define john-restrictions 
   (lambda (lst) 
     (xor (eq? (third lst) 'john) 
          (eq? (fifth lst) 'ethel)))) 
 (define kitty-restrictions 
   (lambda (lst) 
     (xor (eq? (second lst) 'kitty) 
          (eq? (fourth lst) 'mary)))) 
 (define mary-restrictions 
   (lambda (lst) 
     (xor (eq? (fourth lst) 'mary) 
          (eq? (first lst) 'betty)))) 
 (define restrictions-lists 
    (list betty-restrictions 
 (define name-lists 
   (permuta '(betty ethel john kitty mary))) 
 (define (pass-all? tests ele) 
   (if (null? tests) 
       (and ((car tests) ele) 
            (pass-all? (cdr tests) ele)))) 
 (define (filter f lst) 
    ((null? lst) null) 
    ((f (car lst)) (cons (car lst) (filter f (cdr lst)))) 
     (filter f (cdr lst))))) 
 (filter (lambda (x) (pass-all? restrictions-lists x)) 
 ;;((kitty john betty mary ethel))   


(define (require-one p q)
  (require (if p (not q) q)))

(define (liars-puzzle)
  (let ((betty (amb 1 2 3 4 5))
        (ethel (amb 1 2 3 4 5))
        (joan (amb 1 2 3 4 5))
        (kitty (amb 1 2 3 4 5))
        (mary (amb 1 2 3 4 5)))
    (require-one (= kitty 2) (= betty 3))
    (require-one (= ethel 1) (= joan 2))
    (require-one (= joan 3) (= ethel 5))
    (require-one (= kitty 2) (= mary 4))
    (require-one (= mary 4) (= betty 1))
    (require (distinct? (list betty ethel joan kitty mary)))
    (list (list 'betty betty)
          (list 'ethel ethel)
          (list 'joan joan)
          (list 'kitty kitty)
          (list 'mary mary))))

>>> Thomas (04-2020) since filter checks every permutation we just need to make sure that each statement contains one true and one false clause. (we don't need to worry that the clauses are coherent, since we're checking a given list)

 (define (liar) 
   ;;helper procedures 
   (define (filter predicate list) 
     (if (null? list) '() 
       (if (predicate (car list)) 
           (cons (car list) (filter predicate (cdr list))) 
           (filter predicate (cdr list))))) 
   (define (accumulate proc int list) 
     (if (null? list) int 
       (proc (car list) (accumulate proc int (cdr list))))) 
   (define (flatmap proc list) 
     (accumulate append '() (map proc list))) 
   (define (remove x s) 
         (filter (lambda(y) (not (eq? x y))) s)) 
   (define (permutations list) 
     (if (null? list) '(()) 
       (flatmap (lambda (x) (map (lambda (y) (cons x y))  (permutations (remove x list)))) list))) 
   (define (xor a b) 
   (and (or a b) (not (and a b)))) 
   ;;actual procedure 
   (filter (lambda (list) 
             (let ((first (list-ref list 0)) 
                   (sec (list-ref list 1)) 
                   (third (list-ref list 2)) 
                   (fourth (list-ref list 3)) 
                   (fifth (list-ref list 4))) 
               (and (xor (eq? sec 'K) (eq? third 'B)) 
                    (xor (eq? first 'E) (eq? sec 'J)) 
                    (xor (eq? third 'J) (eq? fifth 'E)) 
                    (xor (eq? sec 'K) (eq? fourth 'M)) 
                    (xor (eq? fourth 'M) (eq? first 'B))))) 
                     (permutations (list 'B 'E 'J 'K 'M)))) 


I think instead of starting with each person can take up any place from (1 2 3 4 5). We can just listen to there statements about each other, choose one from each and see if it produces a sensible result:

 (define (liars) 
   (let ((betty (amb 3 1)) 
         (ethel (amb 1 5)) 
         (joan (amb 3 2)) 
         (kitty (amb 2)) 
         (mary (amb 4))) 
          (distinct? (list betty ethel joan kitty mary))) 
        (list (list 'betty betty) 
              (list 'ethel ethel) 
              (list 'joan joan) 
              (list 'kitty kitty) 
              (list 'mary mary)))) 

The result is: ((betty 1) (ethel 5) (joan 3) (kitty 2) (mary 4))