sicp-ex-4.41



<< Previous exercise (4.39) | Index | Next exercise (4.42) >>


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

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) 

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