<< Previous exercise (4.39) | Index | Next exercise (4.42) >>
Simple and very efficient solution that treats (list fletcher smith cooper miller baker) as a big-endian base-5 number (with possible digits 1-5 instead of 0-4), which we then iterate through in order.
(define (nearby? j k) (>= 1 (abs (- j k)))) (define (ordinary-multiple-dwelling) (define (display-solution f s c m b) (display (list (list 'baker b) (list 'cooper c) (list 'fletcher f) (list 'miller m) (list 'smith s))) (newline)) (define (iter-f f) (cond ((= f 1) (iter-f 2)) ((= f 5) 'done) (else (iter-s f 1)))) (define (iter-s f s) (cond ((> s 5) (iter-f (1+ f))) ((nearby? f s) (iter-s f (1+ s))) ;; see additional note (else (iter-c f s 1)))) (define (iter-c f s c) (cond ((> c 5) (iter-s f (1+ s))) ((or (nearby? f c) (= c 1) (= c s)) (iter-c f s (1+ c))) (else (iter-m f s c 1)))) (define (iter-m f s c m) (cond ((> m 5) (iter-c f s (1+ c))) ((or (<= m c) (= m s) (= m f)) (iter-m f s c (1+ m))) (else (iter-b f s c m 1)))) (define (iter-b f s c m b) (cond ((> b 5) (iter-m f s c (1+ m))) (else (if (not (or (= b 5) (= b m) (= b c) (= b s) (= b f))) (display-solution f s c m b)) (iter-b f s c m (1+ b))))) (iter-f 1)) (ordinary-multiple-dwelling) ;; ((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)) ;Value: done
Additional note: if we change the predicate (nearby? f s) to (= f s) and re-run this procedure, we obtain the extra solutions from exercise 4.38:
(ordinary-multiple-dwelling) ;; ((baker 3) (cooper 4) (fletcher 2) (miller 5) (smith 1)) ;; ((baker 1) (cooper 4) (fletcher 2) (miller 5) (smith 3)) ;; ((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)) ;; ((baker 1) (cooper 2) (fletcher 4) (miller 5) (smith 3)) ;; ((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5)) ;; ;Value: done
(define (flatmap proc li) (if (null? li) '() (let ((result (proc (car li))) (rest (flatmap proc (cdr li)))) (if (pair? result) (append result rest) (cons result rest))))) (define (permutations lists) (if (null? lists) '(()) (flatmap (lambda (x) (map (lambda (y) (cons x y)) (permutations (cdr lists)))) (car lists)))) (define (restrictions l) (apply (lambda (baker cooper fletcher miller smith) (and (> miller cooper) (not (= (abs (- smith fletcher)) 1)) (not (= (abs (- fletcher cooper)) 1)) (distinct? (list baker cooper fletcher miller smith)))) l)) (define (mutiple-dwelling) (let ((baker '(1 2 3 4)) (cooper '(2 3 4 5)) (fletcher '(2 3 4)) (miller '(3 4 5)) (smith '(1 2 3 4 5))) (filter restrictions (permutations (list baker cooper fletcher miller smith)))))
another solution, closer to the original amb program.
(define (multiple-dwelling) (define (flat-map proc lst) (if (null? lst) '() (let ((first (proc (car lst)))) ((if (pair? first) append cons) first (flat-map proc (cdr lst)))))) (define (permutations lst) (if (null? lst) (list '()) (flat-map (lambda (first) (map (lambda (rest) (cons first rest)) (permutations (filter (lambda (x) (not (= x first))) lst)))) lst))) (for-each (lambda (try) (apply (lambda (baker cooper fletcher miller smith) (if (and (!= baker 5) (!= cooper 1) (!= fletcher 1) (!= fletcher 5) (> miller cooper) (!= (abs (- smith fletcher)) 1) (!= (abs (- fletcher cooper)) 1)) (display (list baker cooper fletcher miller smith)))) try)) (permutations '(1 2 3 4 5)))) (multiple-dwelling)
An ugly solution.
(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 (distinct? l) (define (member? a lst) (cond ((null? lst) #f) ((eq? (car lst) a) #t) (else (member? a (cdr lst))))) (cond ((null? l) #t) ((member? (car l) (cdr l)) #f) (else (distinct? (cdr l))))) (define (solve) (flatmap (lambda (cooper) (flatmap (lambda (baker) (flatmap (lambda (fletcher) (if (= (abs (- cooper fletcher)) 1) null (flatmap (lambda (miller) (if (not (> miller cooper)) null (flatmap (lambda (smith) (if (and (not (= (abs (- smith fletcher)) 1)) (distinct? (list cooper baker fletcher miller smith))) (list (list 'cooper cooper) (list 'baker baker) (list 'fletcher fletcher) (list 'miller miller) (list 'smith smith)) null)) '(1 2 3 4 5)))) '(3 4 5)))) '(2 3 4))) '(1 2 3 4))) '(2 3 4 5))) ;;((cooper 2) (baker 3) (fletcher 4) (miller 5) (smith 1))
Another ugly solution.
(define (solve) (let ((result '())) (map (lambda (cooper) (map (lambda (baker) (map (lambda (fletcher) (if (= (abs (- cooper fletcher)) 1) null (map (lambda (miller) (if (not (> miller cooper)) null (map (lambda (smith) (if (and (not (= (abs (- smith fletcher)) 1)) (distinct? (list cooper baker fletcher miller smith))) (set! result (cons (list (list 'cooper cooper) (list 'baker baker) (list 'fletcher fletcher) (list 'miller miller) (list 'smith smith)) result)) null)) '(1 2 3 4 5)))) '(3 4 5)))) '(2 3 4))) '(1 2 3 4))) '(2 3 4 5)) (display result))) ;;(((cooper 2) (baker 3) (fletcher 4) (miller 5) (smith 1)))
for your consideration
(define (multiple-dwelling) (let ((result '())) (define (iter-b b) (define (iter-c c) (define (iter-m m) (define (iter-f f) (define (iter-s s) (cond ((or (= s b) (= s c) (= s m) (= s f) (= (abs (- s f)) 1)) (iter-s (+ s 1))) ((> s 5) (iter-f (+ f 1))) (else (set! result (cons (list (list 'baker b) (list 'cooper c) (list 'miller m) (list 'fletcher f) (list 'smith s)) result)) (iter-s (+ s 1))))) (cond ((or (= f b) (= f c) (= f m) (= (abs (- f c)) 1)) (iter-f (+ f 1))) ((> f 4) (iter-m (+ m 1))) (else (iter-s 1)))) (cond ((or (= m b) (<= m c)) (iter-m (+ m 1))) ((> m 5) (iter-c (+ c 1))) (else (iter-f 2)))) (cond ((= c b) (iter-c (+ c 1))) ((> c 5) (iter-b (+ b 1))) (else (iter-m 3)))) (cond ((> b 4) result) (else (iter-c 2)))) (iter-b 1))) ;;(((baker 3) (cooper 2) (miller 5) (fletcher 4) (smith 1)
Instead of generating permutations, we can consider the separate dwellings as a 5 digit base-5 number, and with each pass we increment that number.
(define (multiple-dwellings) (define (house-iter b c m f s) (cond ((> b 4) ; Baker can't live on 5th floor. '(no answer available)) ((> c 5) (house-iter (+ b 1) 2 3 2 1)) ((> m 5) (house-iter b (+ c 1) (+ c 2) 2 1)) ; miller is above cooper ((> f 4) ; fletcher can't live on 5th floor (house-iter b c (+ m 1) 2 1)) ((> s 5) (house-iter b c m (+ f 1) 1)) ((and (not (= (abs (- s f)) 1)) (not (= (abs (- c f)) 1)) (distinct? (list b c m f s))) (list (list 'baker b) (list 'cooper c) (list 'fletcher f) (list 'miller m) (list 'smith s))) (else (house-iter b c m f (+ s 1))))) (house-iter 1 2 3 2 1)) ; initial values take some restrictions into account
Racket has great list comprehensions.
(define (solution? baker cooper fletcher miller smith) (and ; (distinct? (list baker cooper fletcher miller smith)) (not (= baker 5)) (not (= cooper 1)) (not (= fletcher 5)) (not (= fletcher 1)) (> miller cooper) (not (= (abs (- smith fletcher)) 1)) (not (= (abs (- fletcher cooper)) 1)))) (define (show-solutions) (for/list ([tenants (in-permutations (range 1 6))] #:when (apply solution? tenants)) (map list '(baker cooper fletcher miller smith) tenants))) (show-solutions) ;; '(((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
A solution that is easy to read or understand.
;; aliases for Chez Scheme (define false #f) (define true #t) (define (multiple-dwelling) (define ans '()) (define names (list 'baker 'cooper 'fletcher 'miller 'smith)) ;; selectors (define (baker assignment) (list-ref assignment 0)) (define (cooper assignment) (list-ref assignment 1)) (define (fletcher assignment) (list-ref assignment 2)) (define (miller assignment) (list-ref assignment 3)) (define (smith assignment) (list-ref assignment 4)) (define (distinct? items) (cond ((null? items) true) ((null? (cdr items)) true) ((member (car items) (cdr items)) false) (else (distinct? (cdr items))))) ;; is an satiable assignment? (define (satiable? assignment) (and (distinct? (list (baker assignment) (cooper assignment) (fletcher assignment) (miller assignment) (smith assignment))) (not (= (baker assignment) 5)) (not (= (cooper assignment) 1)) (not (= (fletcher assignment) 5)) (not (= (fletcher assignment) 1)) (> (miller assignment) (cooper assignment)) ;; (not (= (abs (- (smith assignment) (fletcher assignment))) 1)) (not (= (abs (- (fletcher assignment) (cooper assignment))) 1)))) ;; try with experimental assignment at the specified stage. (define (try r-assignment stage) (cond [(< stage 5) (let loop ([floor 1]) (if (< floor 6) (begin (try (cons floor r-assignment) (+ stage 1)) (loop (+ floor 1)))))] [(= stage 5) (if (satiable? (reverse r-assignment)) (set! ans (cons (reverse r-assignment) ans)))])) (try '() 0) ;; combine names with floors ;; ``reverse`` is optional (reverse (map (lambda (assignment) (map list names assignment)) ans)))
>>>Thomas simple solution. Just filter from permutations
(define (multiple-dwelling)
;;helper procedures
(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 (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 (list-position obj list)
(define (search rem-list n)
(if (null? rem-list) (length list)
(if (eq? (car rem-list) obj) n
(search (cdr rem-list) (+ n 1)))))
(search list 1))
(define (higher? A B list)
(> (list-position A list) (list-position B list)))
(define (adjacent? A B list)
(= 1 (abs (- (list-position A list) (list-position B list)))))
(define (filter predicate list)
(if (null? list) '()
(if (predicate (car list))
(cons (car list) (filter predicate (cdr list)))
(filter predicate (cdr list)))))
;;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 (not (eq? fifth 'B))
(not (eq? first 'C))
(not (or (eq? first 'F) (eq? fifth 'F)))
(higher? 'M 'C list)
(not (adjacent? 'S 'F list))
(not (adjacent? 'F 'C list))))) (permutations (list 'B 'C 'F 'M 'S))))
Backtracking with plain recursion. No permutations.