<< Previous exercise (4.41) | Index | Next exercise (4.43) >>
(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))
and and or can be added to the evaluator like this:
(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'null? null?)
(list 'list list)
(list 'memq memq)
(list 'member member)
(list 'not not)
(list '+ +)
(list '- -)
(list '* *)
(list '= =)
(list '> >)
(list '>= >=)
(list 'abs abs)
(list 'remainder remainder)
(list 'integer? integer?)
(list 'sqrt sqrt)
(list 'eq? eq?)
;; more primitives
(list 'and (lambda (clause-1 clause-2) (and clause-1 clause-2)))
(list 'or (lambda (clause-1 clause-2) (or clause-1 clause-2)))
))
(define (flatmap f lst) (if (null? lst) null (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) '(()) (flatmap (lambda (x) (map (lambda (y) (cons x y)) (permuta (remove x lst)))) lst))) (define (remove a lst) (cond ((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 ethel-restrictions john-restrictions kitty-restrictions mary-restrictions)) (define name-lists (permuta '(betty ethel john kitty mary))) (define (pass-all? tests ele) (if (null? tests) #t (and ((car tests) ele) (pass-all? (cdr tests) ele)))) (define (filter f lst) (cond ((null? lst) null) ((f (car lst)) (cons (car lst) (filter f (cdr lst)))) (else (filter f (cdr lst))))) (filter (lambda (x) (pass-all? restrictions-lists x)) name-lists) ;;((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))) (require (distinct? (list betty ethel joan kitty mary))) (list (list 'betty betty) (list 'ethel ethel) (list 'joan joan) (list 'kitty kitty) (list 'mary mary)))) (liars)
The result is: ((betty 1) (ethel 5) (joan 3) (kitty 2) (mary 4))
Note that this answer cannot possibly be correct. If Betty is first that means Mary and Kitty were lying about Mary being fourth, which means that Kitty is second. But if Kitty is second then Joan can't also be second which means that Ethel was lying about Joan being second which means that Ethel was actually first. So assuming that Betty was first led us to a contradiction. It's actually easier to demonstrate that there's a contradiction by noting that Kitty being second and Mary being fourth cannot simultaneously be true because Kitty made both of those claims so one of them must be false. The correct answer is ((betty 3) (ethel 5) (joan 2) (kitty 1) (mary 4)).
Solution without permutation.