ompayne
/
sicp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Tidy up code and add second part of exercise 4.42

This commit is contained in:
Oliver Payne 2023-11-09 21:57:04 +00:00
parent 1f0a3948b2
commit a1fb98ddad
1 changed files with 91 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

121
mceval/amb-fathers-daughters.rkt
View File

@ -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) false)
((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 'gabrielle '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