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