Tidy up code and add second part of exercise 4.42

mceval/amb-fathers-daughters.rkt

@@ -1,115 +1,101 @@
 ;; Exercise 4.42
 
-(define (fathers-daughters)
-  (let ((moore 'mary)
-        (hood 'melissa)
-        (downing (amb 'gabrielle 'lorna 'rosalind))
-        (hall (amb 'gabrielle 'lorna))
-        (parker (amb 'gabrielle 'lorna 'rosalind)))
-    (require (distinct? (list downing hall parker)))
-    ())
-  )
-
-(define (fathers-daughers)
-  (let ((mary 'moore)
-        (melissa 'hood)
-        (gabrielle (amb 'downing 'hall 'parker))
-        (lorna (amb 'downing 'hall 'parker))
-        (rosalind (amb 'downing 'hall 'parker)))
-    (require (distinct? (list gabrielle lorna rosalind)))
-    (require (gabrielle ))))
-
-(define (daughter father) (car father))
-(define (yacht father) (cadr father))
-(define (father daugher yacht) (list daugher yacht))
-
-(define (fathers-daughters)
-  (let ((moore (father 'mary 'lorna))
-        (hood (father 'melissa 'gabrielle))
-        (downing (father (amb 'gabrielle 'lorna 'rosalind) 'melissa))
-        (hall (father (amb 'gabrielle 'lorna) 'rosalind))
-        (parker (father (amb 'gabrielle 'lorna 'rosalind) (amb 'mary 'melissa))))
-    (require (distinct? (list (daughter downing) (daughter hall) (daughter parker))))
-    (require (distinct? (list (yacht downing) (yacht hall) (yacht parker))))
-    (require (= (yacht )(daughter parker)))))  ;; TODO
+;; Optimisation.  Put everything we already know in a table.  Each
+;; row is father, yacht, daughter.
 
 
-(define (caar x) (car (car x)))
+(define (fathers-daughters mary)
 
-(define (assoc key records)
-  (cond ((null? records) false)
-        ((equal? key (caar records)) (car records))
-        (else (assoc key (cdr records)))))
+  (define first-row car)
+  (define rest-rows cdr)
 
-(define (fathers-daughters)
-  (let ((yachts '((moore lorna)
-                  (hood gabrielle)
-                  (downing melissa)
-                  (hall rosalind)
-                  (parker mary)))
-        (moore 'mary)
-        (hood 'melissa)
-        (downing (amb 'lorna 'gabrielle 'rosalind))
-        (hall (amb 'lorna 'gabrielle))
-        (parker (amb 'lorna 'gabrielle 'rosalind))
-        (lorna (amb 'downing 'hall 'parker))
-        (gabrielle (amb 'downing 'hall 'parker))
-        (melissa 'hood)
-        (rosalind (amb 'downing 'parker))
-        (mary 'moore))
-    (require (distinct? (list lorna gabrielle rosalind
-                              downing hall parker)))
-    (require (eq? (car (cdr (assoc gabrielle yachts))) parker))
-    (list (list 'mary mary)
-          (list 'rosalind rosalind)
-          (list 'melissa melissa)
-          (list 'gabrielle gabrielle)
-          (list 'lorna lorna))))
+  (define (daughter father)
+    (caddr (assq father fathers)))
 
+  (define (yacht father)
+    (cadr (assq father fathers)))
 
-(define (caar x) (car (car x)))
-(define (cadr x) (car (cdr x)))
-(define (caddr x) (car (cdr (cdr x))))
+  (define (father daughter)
+    (define (loop f) 
+    (cond ((null? f) false)
+          ((eq? daughter (caddr (first-row f)))
+           (car (first-row f)))
+          (else (loop (rest-rows f)))))
+  (loop fathers))
 
-(define (assq key records)
-  (cond ((null? records) false)
-        ((eq? key (caar records)) (car records))
-        (else (assq key (cdr records)))))
-
-(define (fathers-daughters)
-
-  (define daughter caddr)
-  (define yacht cadr)
-  
-  (define (lookup-daughter father fathers)
-    (daughter (assq father fathers)))
-
-  (define (lookup-yacht father fathers)
-    (yacht (assq father fathers)))
-  
-  (define (lookup-father daughter fathers)
-    (cond ((null? fathers) false)
-          ((eq? daughter (daughter (car fathers)))
-           (car (car fathers)))
-          (else (father daughter (cdr fathers)))))
-
-  ;; Optimisation.  Put everything we already know in a table.  Each
-  ;; row is father, yacht, daughter.
   (define fathers
-    (list
-     (list 'moore 'lorna 'mary)
-     (list 'hood 'gabrielle 'melissa)
-     (list 'downing 'melissa (amb 'lorna 'gabriella 'rosalind))
-     (list 'hall 'rosalind (amb 'lorna 'gabrielle))
-     (list 'parker 'mary (amb 'lorna 'gabrielle 'rosalind))))
+    (if (eq? mary 'moore)
+        ;; Mary's surname is Moore
+        (list
+         (list 'moore 'lorna 'mary)
+         (list 'hood 'gabrielle 'melissa)
+         (list 'downing 'melissa (amb 'lorna 'gabrielle 'rosalind))
+         (list 'hall 'rosalind (amb 'lorna 'gabrielle))
+         (list 'parker 'mary (amb 'lorna 'gabrielle 'rosalind)))
+        ;; Mary's surname is unkonwn
+        (list
+         (list 'moore 'lorna (amb 'mary 'gabrielle 'rosalind))
+         (list 'hood 'gabrielle 'melissa)
+         (list 'downing 'melissa (amb 'mary 'lorna 'gabrielle 'rosalind))
+         (list 'hall 'rosalind (amb 'mary 'lorna 'gabrielle))
+         (list 'parker 'mary (amb 'lorna 'gabrielle 'rosalind)))))
 
-  (require (distinct? (list (lookup-daughter 'moore fathers)
-                            (lookup-daughter 'hood fathers)
-                            (lookup-daughter 'downing fathers)
-                            (lookup-daughter 'hall fathers)
-                            (lookup-daughter 'parker fathers))))
+  (require (distinct? (list (daughter 'moore)
+                            (daughter 'hood)
+                            (daughter 'downing)
+                            (daughter 'hall)
+                            (daughter 'parker))))
   ;; Gabrielle's father owns the yacht named after parker's daughter
-  (require (eq? (lookup-yacht (lookup-father 'gabrielle fathers))
-                (lookup-daughter 'parker fathers)))
+  (require (eq? (yacht (father 'gabrielle))
+                (daughter 'parker)))
   fathers)
 
+
+;; Output
+
+;;; Amb-Eval input:
+(fathers-daughters 'moore)
+
+;;; Starting a new problem 
+
+;;; Amb-Eval value:
+1
+((moore lorna mary) (hood gabrielle melissa) (downing melissa lorna) (hall rosalind gabrielle) (parker mary rosalind))
+
+;;; Amb-Eval input:
+try-again
+
+;;; There are no more values of
+3
+(fathers-daughters (quote moore))
+
+;; Lorna's father must be Colonel Downing.
+
+
+
+;; If we don't assume that Mary's surname is Moore:
+
+(fathers-daughters false)
+
+;;; Starting a new problem 
+
+;;; Amb-Eval value:
+1
+((moore lorna mary) (hood gabrielle melissa) (downing melissa lorna) (hall rosalind gabrielle) (parker mary rosalind))
+
+;;; Amb-Eval input:
+try-again
+
+
+;;; Amb-Eval value:
+5
+((moore lorna gabrielle) (hood gabrielle melissa) (downing melissa rosalind) (hall rosalind mary) (parker mary lorna))
+
+;;; Amb-Eval input:
+try-again
+
+;;; There are no more values of
+10
+(fathers-daughters false)
+
+;; Lorna's father is either Colonel Downing or Dr Parker

mceval/ambeval.rkt

@@ -198,42 +198,42 @@
 
 (define (amb-driver-loop)
   (define env (setup-environment))
-  ;; Need to pass success and failure continuations to ambeval, so
-  ;; will probably need a different eval-program.
   (amb-eval-program-in-env amb-utilities-program env)
   (define start-time 0)
-  (define (internal-loop try-again)
-    (prompt-for-input input-prompt)
-    (let ((input (read)))
-      (if (eq? input 'try-again)
-          (try-again)
-          (begin
-            (newline)
-            (display ";;; Starting a new problem ")
-            (set! start-time (current-process-milliseconds))
-            (ambeval input
-                     env
-                     ;; ambeval success
-                     (lambda (val next-alternative)
-                       (newline)
-                       (announce-output output-prompt)
-                       (display (- (current-process-milliseconds) start-time))
-                       (newline)
-                       (user-print val)
-                       (internal-loop next-alternative))
-                     ;; ambeval failure
-                     (lambda ()
-                       (announce-output
-                        ";;; There are no more values of")
-                       (display (- (current-process-milliseconds) start-time))
-                       (newline)
-                       (user-print input)
-                       (amb-driver-loop)))))))
-  (internal-loop
-   (lambda ()
-     (newline)
-     (display ";;; There is no current problem")
-     (amb-driver-loop))))
+  (define (driver-loop)
+    (define (internal-loop try-again)
+      (prompt-for-input input-prompt)
+      (let ((input (read)))
+        (if (eq? input 'try-again)
+            (try-again)
+            (begin
+              (newline)
+              (display ";;; Starting a new problem ")
+              (set! start-time (current-process-milliseconds))
+              (ambeval input
+                       env
+                       ;; ambeval success
+                       (lambda (val next-alternative)
+                         (newline)
+                         (announce-output output-prompt)
+                         (display (- (current-process-milliseconds) start-time))
+                         (newline)
+                         (user-print val)
+                         (internal-loop next-alternative))
+                       ;; ambeval failure
+                       (lambda ()
+                         (announce-output
+                          ";;; There are no more values of")
+                         (display (- (current-process-milliseconds) start-time))
+                         (newline)
+                         (user-print input)
+                         (driver-loop)))))))
+    (internal-loop
+     (lambda ()
+       (newline)
+       (display ";;; There is no current problem")
+       (driver-loop))))
+  (driver-loop))
 
 
 

mceval/environment.rkt

@@ -1,5 +1,7 @@
 #lang sicp
 
+(#%require racket/trace)
+
 (#%provide lookup-variable-value
            set-variable-value!
            define-variable!
@@ -156,6 +158,8 @@
 (define primitive-procedures
   (list (list 'car car)
         (list 'cdr cdr)
+        (list 'cadr cadr)
+        (list 'caddr caddr)
         (list 'cons cons)
         (list 'null? null?)
         (list 'list list)
@@ -182,6 +186,8 @@
         (list 'integer? integer?)
         (list 'sqrt sqrt)
         (list 'eq? eq?)
+        (list 'assq assq)
+        (list 'equal? equal?)
         (list 'newline newline)
         (list 'display display)
         ))