Compare commits
3 Commits
7c3ffec02c
...
a1fb98ddad
Author | SHA1 | Date |
---|---|---|
Oliver Payne | a1fb98ddad | |
Oliver Payne | 1f0a3948b2 | |
Oliver Payne | d6591f3169 |
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
||||
|
||||
|
|
|
@ -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)
|
||||
))
|
||||
|
|
Loading…
Reference in New Issue