Tidy up code and add second part of exercise 4.42

mceval/amb-fathers-daughters.rkt

@@ -1,40 +1,101 @@
 ;; Exercise 4.42
 
-(define (fathers-daughters)
+;; Optimisation.  Put everything we already know in a table.  Each
+;; row is father, yacht, daughter.
 
-  (define father car)
-  (define yacht cadr)
-  (define daughter caddr)
-  
-  (define (lookup-daughter f fathers)
-    (daughter (assq f fathers)))
 
-  (define (lookup-yacht f fathers)
-    (yacht (assq f fathers)))
-  
-  (define (lookup-father d fathers)
-    (cond ((null? fathers) '())
-          ((eq? d (daughter (car fathers)))
-           (car (car fathers)))
-          (else (lookup-father d (cdr fathers)))))
+(define (fathers-daughters mary)
+
+  (define first-row car)
+  (define rest-rows cdr)
+
+  (define (daughter father)
+    (caddr (assq father fathers)))
+
+  (define (yacht father)
+    (cadr (assq father fathers)))
+
+  (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))
 
-  ;; 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) 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))