sicp-ex-4.43

  
  
 ; a. Lorna's father is Colonel Downing 
  
 ; b. 
 (define yacht-names  
     '((Moore Lorna)  
       (Downing Melissa)  
       (Barnacle Gabrielle)  
       (Hall Rosalind) 
       (Parker Mary))) 
  
 (define daddy-options 
     '((Lorna (Downing Barnacle Hall Parker)) 
       (Melissa (Barnacle)) 
       (Gabrielle (Moore Downing Hall Parker)) 
       (Rosalind (Moore Downing Parker)) 
       (Mary (Moore Downing Barnacle Hall)))) 
  
 (define (find-cdr kv-list k) 
     (define (iter rest) 
         (cond ((null? rest) false) 
               ((eq? k (caar rest)) (cadar rest)) 
               (else (iter (cdr rest))))) 
     (iter kv-list)) 
  
 (define (find-car kv-list k) 
     (define (iter rest) 
         (cond ((null? rest) false) 
               ((eq? k (cadar rest)) (caar rest)) 
               (else (iter (cdr rest))))) 
     (iter kv-list)) 
  
 (define (daddy girl set) (find-cdr set girl)) 
 (define (daughter daddy set) (find-car set daddy)) 
 (define (yacht daddy set) (find-cdr set daddy)) 
  
 (define (no-share-daddy daddy set) 
     (define (iter rest) 
         (cond ((null? rest) true) 
               ((eq? (cadar rest) daddy) false) 
               (else (iter (cdr rest))))) 
     (iter set)) 
  
 (define (nice-daughters) 
     (define (iter options result) 
         (if (null? options) 
             (begin 
                 (require (eq? (yacht (daddy 'Gabrielle)) (daughter 'Parker))) 
                 result) 
             (let ((girl (caar options)) 
                   (daddies (cadar options))) 
                 (let ((daddy (a-element-of daddies))) 
                     (require (no-share-daddy daddy result)) 
                     (iter (cdr options) (cons (list girl daddy) result)))))) 
     (iter daddy-options '())) 

Here's a solution that doesn't explicitly leave out solutions, instead having amb and require eliminate them naturally.

 (define (yacht) 
   (define gab 'gabrielle) 
   (define lor 'lorna) 
   (define ros 'rosalind) 
   (define mel 'melissa) 
   (define mar 'mary-ann) 
   (let ((barnacle (amb gab lor ros mel mar))) 
     (require (eq? barnacle mel)) 
     (let ((moore (amb gab lor ros mel mar))) 
       (require (eq? moore mar))     
       (let ((hall (amb gab lor ros mel mar))) 
         (require (not (memq hall (list barnacle moore ros))))  
         (let ((downing (amb gab lor ros mel mar))) 
           (require (not (memq downing (list barnacle moore hall mel)))) 
           (let ((parker (amb gab lor ros mel mar))) 
             (require (not (memq parker 
                                 (list barnacle moore hall downing mar)))) 
             (let ((yacht-names 
                    (list (list barnacle gab) 
                          (list moore lor) 
                          (list hall ros) 
                          (list downing mel) 
                          (list parker mar)))) 
               (require (eq? parker (cadr (assq gab yacht-names)))) 
               (list (list 'barnacle barnacle) 
                     (list 'moore moore) 
                     (list 'hall hall) 
                     (list 'downing downing) 
                     (list 'parker parker))))))))) 

  
  
  
 (define (father-daughter) 
   (let ((Moore 'Mary) 
         (Barnacle 'Melissa) 
         (Hall (amb 'Gabrielle 'Lorna)) 
         (Downing (amb 'Gabrielle 'Lorna 'Rosalind)) 
         (Parker (amb 'Lorna 'Rosalind))) 
     (require (cond ((eq? Hall 'Gabrielle) (eq? 'Rosalind Parker)) 
                    ((eq? Downing 'Gabrielle) (eq? 'Melissa Parker)) 
                    (else false))) 
     (require (distinct? (list Hall Downing Parker))) 
     (list (list 'Barnacle Barnacle) 
           (list 'Moore Moore) 
           (list 'Hall Hall) 
           (list 'Downing Downing) 
           (list 'Parker Parker)))) 
  
 run (father-daughter), get ((Barnacle Melissa) (Moore Mary) (Hall Gabrielle) (Downing Lorna) (Parker Rosalind)), so Lorna's father is Colonel Downing. 
 If we don't know Mary Ann's family name is Moore, we get: 
 ;;; Starting a new problem 
 ;;; Amb-Eval output: 
 ((Barnacle Melissa) (Moore Gabrielle) (Hall Mary) (Downing Rosalind) (Parker Lorna)) 
  
 ;;; Amb-Eval input: 
 try-again 
  
 ;;; Amb-Eval output: 
 ((Barnacle Melissa) (Moore Mary) (Hall Gabrielle) (Downing Lorna) (Parker Rosalind)) 
  

To express `Gabrielle's father owns the yacht that is named after Dr. Parker's daughter', I introduce 2 procedures `name-of-his-yacht` and `her-father`

 (define (game-of-yacht) 
   (define (all-fathers) (amb 'mr-moore 'colonel-downing 'mr-hall 'sir-barnacle-hood 'dr-parker)) 
  
   (define (all-fathers-except except-father) 
     (let ((fathers (all-fathers))) 
       (require (not (eq? fathers except-father))) 
       fathers)) 
  
   (define (name-of-his-yacht father-name) 
     (cond ((eq? father-name 'mr-moore) 'lorna) 
           ((eq? father-name 'colonel-downing) 'melissa) 
           ((eq? father-name 'mr-hall) 'rosalind) 
           ((eq? father-name 'sir-barnacle-hood) 'gabrielle) 
           ((eq? father-name 'dr-parker) 'marry))) ;; a little jumpy here 
  
   (define lorna-father (all-fathers-except 'mr-moore)) 
   (define melissa-father 'sir-barnacle-hood) 
   (define rosalind-father (all-fathers-except 'mr-hall)) 
   (define gabrielle-father (all-fathers-except 'sir-barnacle-hood)) 
   (define marry-father 'mr-moore) 
  
   (define (her-father she) 
     (cond ((eq? she 'lorna) lorna-father) 
           ((eq? she 'melissa) melissa-father) 
           ((eq? she 'rosalind) rosalind-father) 
           ((eq? she 'gabrielle) gabrielle-father) 
           ((eq? she 'marry) marry-father))) 
  
   (require (distinct? (list lorna-father melissa-father rosalind-father gabrielle-father marry-father))) 
   (require (eq? (her-father (name-of-his-yacht gabrielle-father)) 'dr-parker)) 
   (list lorna-father melissa-father rosalind-father gabrielle-father marry-father)) 
  

Output:

 (game-of-yacht) 
 ;;; Starting a new problem 
 ;;; Amb-Eval value: 
 (colonel-downing sir-barnacle-hood dr-parker mr-hall mr-moore) 
  
 try-again 
 ;;; There are no more values of 
 (game-of-yacht) 

self-documenting code.

 (define (list-ref lst n) 
   (if (= n 0) 
       (car lst) 
       (list-ref (cdr lst) (- n 1)))) 
  
 ;; single let but inefficient 
 (define (Yacht) 
   (define moore 1) 
   (define downing 2) 
   (define hall 3) 
   (define barnacle 4) 
   (define parker 5) 
  
   (define lorna 1) 
   (define mellissa 2) 
   (define rosalind 3) 
   (define gabrille 4) 
   (define mary 5) 
  
   (define (father-name father) 
     (define names (list 'moore 'downing 'hall 'barnacle 'parker)) 
     (list-ref names (- father 1))) 
    
   (define (owned-yacht father) 
     father) 
    
   (define (father-of daughter fathers) 
     (list-ref fathers (- daughter 1))) 
    
   (let ((F-lorna (amb moore downing hall barnacle parker)) 
         (F-mellissa (amb moore downing hall barnacle parker)) 
         (F-rosalind (amb moore downing hall barnacle parker)) 
         (F-gabrille (amb moore downing hall barnacle parker)) 
         (F-mary (amb moore downing hall barnacle parker))) 
     (let ((fathers (list F-lorna F-mellissa F-rosalind F-gabrille F-mary))) 
       (require (not (= F-lorna moore))) 
       (require (not (= F-rosalind hall))) 
       (require (not (= F-gabrille barnacle))) 
       (require (= F-mellissa barnacle)) 
       (require (= F-mary moore)) 
       (require (= (father-of (owned-yacht F-gabrille) fathers) parker)) 
       (require 
        (distinct? fathers)) 
       (list (list 'lorna (father-name F-lorna)) 
             (list 'mellissa (father-name F-mellissa)) 
             (list 'rosalind (father-name F-rosalind)) 
             (list 'gabrille (father-name F-gabrille)) 
             (list 'mary (father-name F-mary)))))) 
  
 ;; nested let but but efficient 
 (define (Yacht) 
   (define moore 1) 
   (define downing 2) 
   (define hall 3) 
   (define barnacle 4) 
   (define parker 5) 
  
   (define lorna 1) 
   (define mellissa 2) 
   (define rosalind 3) 
   (define gabrille 4) 
   (define mary 5) 
  
   (define (father-name father) 
     (define names (list 'moore 'downing 'hall 'barnacle 'parker)) 
     (list-ref names (- father 1))) 
    
   (define (owned-yacht father) 
     father) 
    
   (define (father-of daughter fathers) 
     (list-ref fathers (- daughter 1))) 
    
   (let ([F-mary (amb moore downing hall barnacle parker)]) 
     (require (= F-mary moore)) 
     (let ([F-mellissa (amb moore downing hall barnacle parker)]) 
       (require (= F-mellissa barnacle)) 
       (let ([F-lorna (amb moore downing hall barnacle parker)]) 
         (require (not (= F-lorna moore))) 
         (let ([F-rosalind (amb moore downing hall barnacle parker)]) 
           (require (not (= F-rosalind hall))) 
           (let ([F-gabrille (amb moore downing hall barnacle parker)]) 
             (require (not (= F-gabrille barnacle))) 
             (let ((fathers (list F-lorna F-mellissa F-rosalind F-gabrille F-mary))) 
               (require (= (father-of (owned-yacht F-gabrille) fathers) parker)) 
               (require (distinct? fathers)) 
               (list (list 'lorna (father-name F-lorna)) 
                     (list 'mellissa (father-name F-mellissa)) 
                     (list 'rosalind (father-name F-rosalind)) 
                     (list 'gabrille (father-name F-gabrille)) 
                     (list 'mary (father-name F-mary)))))))))) 

Here's a solutions in normal scheme (had to change the structure to make it readable)

 (define (puzzle) 
   ;;internal helper definition 
   (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))) 
   (let ((all-tripples ;;form: dad yacht daugher - gives a list whos sublists are all tripples with one of the dads (5 sublist- in total 36 tripples) 
            (map (lambda (dad) 
                   (filter (lambda (x) (if (eq? x 'yacht=daughter) false ;;in order to get a shorter list, we filter whats possible directly 
                       (and (if (eq? dad 'B) (if (eq? (cadr x) 'G) true false) true) ;; Barnacles yacht is gabriele 
                              (if (eq? dad 'M) (if (eq? (cadr x) 'L) true false) true) ;;Moores is Lorna 
                               (if (eq? dad 'H) (if (eq? (cadr x) 'R) true false) true) ;;Halls is Rosalinda 
                               (if (eq? dad 'D) (if (eq? (cadr x) 'M) true false)) true))) ;; Downings is Melissa 
                    (flatmap (lambda (yacht) 
                                     (map (lambda (daughter) 
                                           (if (eq? yacht daughter) 'yacht=daughter 
                                               (list dad yacht daughter))) 
                                           (list 'G 'L 'R 'A 'M))) ;;daughter names are 
                                    (list 'G 'L 'R 'A 'M)))) ;;also yacht names 
                 (list 'B 'M 'H 'P 'D)))) ;abbrevations for dad names 
   (let ((all-combinations ;;gives a list with all combinations of tripples (with the incorperated restrictions 44 in total) 
     (let ((all all-tripples)) 
     (let ((tripples-1dad (car all)) 
           (tripples-2dad (cadr all)) 
           (tripples-3dad (caddr all)) 
           (tripples-4dad (cadddr all)) 
           (tripples-5dad (car (cddddr all)))) 
     (flatmap (lambda (1dad) 
           (flatmap (lambda (2dad) 
                   (flatmap (lambda (3dad) 
                          (flatmap (lambda (4dad) 
 ;; we want to filter out all combinations where the dady have same yachts or daughters 
       (filter (lambda (x) (let ((1dady (cadr (car x)))  
       (1dadd (caddr (car x))) ;;we therefor abbreviate (dadd dad-daughter) (dady dad-yacht) 
                            (2dady (cadr (cadr x))) 
                            (2dadd (caddr (cadr x))) 
                            (3dady (cadr (caddr x))) 
                            (3dadd (caddr (caddr x))) 
                            (4dady (cadr (cadddr x))) 
                            (4dadd (caddr (cadddr x))) 
                            (5dady (cadar (cddddr x))) 
                           (5dadd (caddar (cddddr x)))) 
                      (if (or (eq? 1dady 2dady) (eq? 1dady 3dady) (eq? 1dady 4dady) (eq? 1dady 5dady) 
                             (eq? 2dady 3dady) (eq? 2dady 4dady) (eq? 2dady 5dady) 
                              (eq? 3dady 4dady) (eq? 3dady 5dady) (eq? 4dady 5dady) 
                              (eq? 1dadd 2dadd) (eq? 1dadd 3dadd) (eq? 1dadd 4dadd) (eq? 1dadd 5dadd) 
                             (eq? 2dadd 3dadd) (eq? 2dadd 4dadd) (eq? 2dadd 5dadd) 
                            (eq? 3dadd 4dadd) (eq? 3dadd 5dadd) (eq? 4dadd 5dadd)) false true))) 
                    (map (lambda (5dad) (list 1dad 2dad 3dad 4dad 5dad)) tripples-5dad))) 
                               tripples-4dad)) 
                        tripples-3dad)) 
                 tripples-2dad)) 
          tripples-1dad))))) 
   (filter (lambda (combination)  
  ;; finally we filter for the remaining two (+1) restrictions 
      (let ((B-tripple (car combination)) 
                             (M-tripple (cadr combination)) 
                             (H-tripple (caddr combination)) 
                             (P-tripple (cadddr combination)) 
                             (D-tripple (car (cddddr combination)))) 
     (if (and (eq? (cadr D-tripple) (caddr B-tripple)) ;; yacht from Downing is Barnacles daughter 
   (eq? (caddr M-tripple) 'A);; Ann is Moores daughter 
  (cond ((eq? (caddr B-tripple) 'G) (eq? (cadr B-tripple) (caddr P-tripple)));;the one who's Gabrielle's father owns the yacht thats parkers daughter 
                   ((eq? (caddr M-tripple) 'G) (eq? (cadr M-tripple) (caddr P-tripple))) 
                   ((eq? (caddr H-tripple) 'G) (eq? (cadr H-tripple) (caddr P-tripple))) 
                    ((eq? (caddr P-tripple) 'G) (eq? (cadr P-tripple) (caddr P-tripple))) 
                   ((eq? (caddr D-tripple) 'G) (eq? (cadr D-tripple) (caddr P-tripple)) true false))) 
                           true false))) all-combinations)))) 
 ;;result: (((B G M) (M L A) (H R G) (P A R) (D M L))) 
 ;;if we erase the restriction that Ann is Moores daughter, we get two possibilities 
 ;; result: (((B G M) (M L G) (H R A) (P A L) (D M R)) ((B G M) (M L A) (H R G) (P A R) (D M L))) 

To simplify the implementation, define an internal procedure that maps the surname of the yacht owner to the surname of the yacht name. This procedure needs to be redefined each time any of the ambiguous variables' values change. This redefinition occurs automatically if the internal procedure definition occurs in the body of the 'let' expression. Below is the nondeterministic evaluator input and output:

 ; nondeterministic evaluator implementation... 
  
 1 |=> (define the-global-environment (setup-environment)) 
 ;Value: the-global-environment 
  
 1 |=> (driver-loop) 
  
 ;;; Amb-Eval input: 
 (define (require p) 
   (if (not p) (amb))) 
 ;;; Starting a new problem 
 ;;; Amb-Eval value: 
 ok 
  
 ;;; Amb-Eval input: 
 (define (distinct? items) 
   (cond ((null? items) true) 
         ((null? (cdr items)) true) 
         ((member (car items) (cdr items)) false) 
         (else (distinct? (cdr items))))) 
 ;;; Starting a new problem 
 ;;; Amb-Eval value: 
 ok 
  
 ;;; Amb-Eval input: 
 (define (daughters1) 
   (let ((gabrielle (amb 'downing 'hall 'parker)) 
         (lorna (amb 'downing 'hall 'parker)) 
         (mary 'moore) 
         (melissa 'hood) 
         (rosalind (amb 'downing 'hall 'parker))) 
     (define (yacht-of father) 
       (cond ((eq? father 'downing) melissa) 
             ((eq? father 'hall) rosalind) 
             ((eq? father 'hood) gabrielle) 
             ((eq? father 'moore) lorna) 
             (else mary))) 
     (require (eq? 'parker (yacht-of gabrielle))) 
     (require (distinct? (list gabrielle lorna mary melissa rosalind))) 
     (list (list 'gabrielle gabrielle) 
           (list 'lorna lorna) 
           (list 'mary mary) 
           (list 'melissa melissa) 
           (list 'rosalind rosalind)))) 
 ;;; Starting a new problem 
 ;;; Amb-Eval value: 
 ok 
  
 ;;; Amb-Eval input: 
 (daughters1) 
 ;;; Starting a new problem 
 ;;; Amb-Eval value: 
 ((gabrielle hall) (lorna downing) (mary moore) (melissa hood) (rosalind parker)) 
  
 ;;; Amb-Eval input: 
 try-again 
 ;;; There are no more values of 
 (daughters1) 
  
 ;;; Amb-Eval input: 
 (define (daughters2) 
   (let ((gabrielle (amb 'downing 'hall 'moore 'parker)) 
         (lorna (amb 'downing 'hall 'moore 'parker)) 
         (mary (amb 'downing 'hall 'moore 'parker)) 
         (melissa 'hood) 
         (rosalind (amb 'downing 'hall 'moore 'parker))) 
     (define (yacht-of father) 
       (cond ((eq? father 'downing) melissa) 
             ((eq? father 'hall) rosalind) 
             ((eq? father 'hood) gabrielle) 
             ((eq? father 'moore) lorna) 
             (else mary))) 
     (require (eq? 'parker (yacht-of gabrielle))) 
     (require (distinct? (list gabrielle lorna mary melissa rosalind))) 
     (list (list 'gabrielle gabrielle) 
           (list 'lorna lorna) 
           (list 'mary mary) 
           (list 'melissa melissa) 
           (list 'rosalind rosalind)))) 
 ;;; Starting a new problem 
 ;;; Amb-Eval value: 
 ok 
  
 ;;; Amb-Eval input: 
 (daughters2) 
 ;;; Starting a new problem 
 ;;; Amb-Eval value: 
 ((gabrielle hall) (lorna downing) (mary moore) (melissa hood) (rosalind parker)) 
  
 ;;; Amb-Eval input: 
 try-again 
 ;;; Amb-Eval value: 
 ((gabrielle hall) (lorna moore) (mary downing) (melissa hood) (rosalind parker)) 
  
 ;;; Amb-Eval input: 
 try-again 
 ;;; Amb-Eval value: 
 ((gabrielle moore) (lorna parker) (mary downing) (melissa hood) (rosalind hall)) 
  
 ;;; Amb-Eval input: 
 try-again 
 ;;; Amb-Eval value: 
 ((gabrielle moore) (lorna parker) (mary hall) (melissa hood) (rosalind downing)) 
  
 ;;; Amb-Eval input: 
 try-again 
 ;;; There are no more values of 
 (daughters2) 
  
 ;;; Amb-Eval input: 
 End of input stream reached. 
 Fortitudine vincimus.