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

Better solution for fathers and daughters

This commit is contained in:
Oliver Payne 2023-11-08 23:07:54 +00:00
parent a98257368e
commit d6591f3169
2 changed files with 17 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,97 +1,22 @@
;; 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
(define (caar x) (car (car x)))
(define (assoc key records)
(cond ((null? records) false)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(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 (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (caddr x) (car (cdr (cdr x))))
(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 father car)
(define yacht cadr)
(define daughter caddr)
(define (lookup-daughter father fathers)
(daughter (assq father fathers)))
(define (lookup-daughter f fathers)
(daughter (assq f fathers)))
(define (lookup-yacht father fathers)
(yacht (assq father fathers)))
(define (lookup-yacht f fathers)
(yacht (assq f fathers)))
(define (lookup-father daughter fathers)
(define (lookup-father d fathers)
(cond ((null? fathers) false)
((eq? daughter (daughter (car fathers)))
((eq? d (daughter (car fathers)))
(car (car fathers)))
(else (father daughter (cdr fathers)))))
(else (lookup-father d (cdr fathers)))))
;; Optimisation. Put everything we already know in a table. Each
;; row is father, yacht, daughter.
@ -99,7 +24,7 @@
(list
(list 'moore 'lorna 'mary)
(list 'hood 'gabrielle 'melissa)
(list 'downing 'melissa (amb 'lorna 'gabriella 'rosalind))
(list 'downing 'melissa (amb 'lorna 'gabrielle 'rosalind))
(list 'hall 'rosalind (amb 'lorna 'gabrielle))
(list 'parker 'mary (amb 'lorna 'gabrielle 'rosalind))))
@ -109,7 +34,7 @@
(lookup-daughter 'hall fathers)
(lookup-daughter 'parker fathers))))
;; Gabrielle's father owns the yacht named after parker's daughter
(require (eq? (lookup-yacht (lookup-father 'gabrielle fathers))
(require (eq? (lookup-yacht (lookup-father 'gabrielle fathers) fathers)
(lookup-daughter 'parker fathers)))
fathers)

6
mceval/environment.rkt
View File

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