# sicp-ex-4.41

woofy

Backtracking with plain recursion. No permutations.

```

(define baker 0)
(define cooper 1)
(define fletcher 2)
(define miller 3)
(define smith 4)

(define (list-ref s n)
(cond ((null? s) false)
((= n 0) (car s))
(else (list-ref (cdr s) (- n 1)))))

(define (check set who)
(let ((baker-floor (floor baker set who))
(cooper-floor (floor cooper set who))
(fletcher-floor (floor fletcher set who))
(miller-floor (floor miller set who))
(smith-floor (floor smith set who)))
;(display (list "checking..." set who))
(cond ((= who baker) (not (= baker-floor 5)))
((= who cooper)
(and (not (= cooper-floor baker-floor))
(not (= cooper-floor 1))))
((= who fletcher)
(and (not (= fletcher-floor cooper-floor))
(not (= fletcher-floor baker-floor))
(not (= fletcher-floor 1))
(not (= fletcher-floor 5))
(not (= (abs (- fletcher-floor cooper-floor)) 1))))
((= who miller)
(and (not (= miller-floor fletcher-floor))
(not (= miller-floor cooper-floor))
(not (= miller-floor baker-floor))
(> miller-floor cooper-floor)))
((= who smith)
(and (not (= smith-floor miller-floor))
(not (= smith-floor fletcher-floor))
(not (= smith-floor cooper-floor))
(not (= smith-floor baker-floor))
(not (= (abs (- smith-floor fletcher-floor)) 1))))
(else (error "invalid dweller " who)))))

(define (try-dwell)
(define (place who floor result)
(if (> who smith)
(display result)
(let ((next (cons floor result)))
(if (check next who)
(place (+ who 1) 1 next))
(if (< floor 5)
(place who (+ floor 1) result)))))
(place 0 1 '()))

(try-dwell)
; (1 5 4 2 3)
```

xdavidliu

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
```

meteorgan

```

(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)))))
```

Felix021

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)
```

Shaw

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))
```

Shaw

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)))
```

Donald

```
(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)
```

stepvhen

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.
((> 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
```

timothy235

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)))
```

revc

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)))
(= 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? 'F 'C list))))) (permutations (list 'B 'C 'F 'M 'S))))
```

chemPolonium

I think this is the ugliest, but it works:

```
(define (multiple-dwelling)
(let cooper-iter ([cooper-list (list 2 3 4 5)])
(if (null? cooper-list)
(error "no valid solution")
(let ([cooper (car cooper-list)])
(let miller-iter ([miller-list (list 3 4 5)])
(if (null? miller-list)
(cooper-iter (cdr cooper-list))
(let ([miller (car miller-list)])
(if (not (> miller cooper))
(miller-iter (cdr miller-list))
(let fletcher-iter ([fletcher-list (list 2 3 4)])
(if (null? fletcher-list)
(miller-iter (cdr miller-list))
(let ([fletcher (car fletcher-list)])
(if (= (abs (- fletcher cooper)) 1)
(fletcher-iter (cdr fletcher-list))
(let smith-iter ([smith-list (list 1 2 3 4 5)])
(if (null? smith-list)
(fletcher-iter (cdr fletcher-list))
(let ([smith (car smith-list)])
(if (= (abs (- smith fletcher)) 1)
(smith-iter (cdr smith-list))
(let baker-iter ([baker-list (list 1 2 3 4)])
(if (null? baker-list)
(smith-iter (cdr smith-list))
(let ([baker (car baker-list)])
(if (not (distinct? (list baker cooper fletcher miller smith)))
(baker-iter (cdr baker-list))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith))))))))))))))))))))))
```