415 lines
12 KiB
Scheme
415 lines
12 KiB
Scheme
(load "shared/util.scm")
|
|
(load "shared/sicp-ambeval.scm")
|
|
|
|
(define the-global-environment (setup-environment))
|
|
(define result '())
|
|
|
|
(define (amball exp)
|
|
(set! result '()) ; reset result
|
|
(ambeval exp
|
|
the-global-environment
|
|
(lambda (value next)
|
|
(set! result (cons value result))
|
|
(next))
|
|
(lambda () result))
|
|
(set! result (reverse result))
|
|
result)
|
|
|
|
(define (amb5 exp)
|
|
;; puts the first five amb results into result
|
|
(set! count 0)
|
|
(set! result '())
|
|
(ambeval exp
|
|
the-global-environment
|
|
(lambda (value next)
|
|
(set! result (cons value result))
|
|
(set! count (+ count 1))
|
|
(if (< count 5)
|
|
(next)
|
|
result))
|
|
(lambda () result))
|
|
(set! result (reverse result))
|
|
result)
|
|
|
|
(amball '(begin
|
|
|
|
(define (require p)
|
|
(if (not p) (amb)))
|
|
|
|
(define nouns '(noun student professor cat class))
|
|
(define verbs '(verb studies lectures eats sleeps))
|
|
(define articles '(article the a))
|
|
(define prepositions '(prep for to in by with))
|
|
(define adjectives '(adjective pretty kind mean bad))
|
|
|
|
(define (parse-word word-list)
|
|
(require (not (null? *unparsed*)))
|
|
(require (memq (car *unparsed*) (cdr word-list)))
|
|
(let ((found-word (car *unparsed*)))
|
|
(set! *unparsed* (cdr *unparsed*))
|
|
(list (car word-list) found-word)))
|
|
|
|
(define (parse-prepositional-phrase)
|
|
(list 'prep-phrase
|
|
(parse-word prepositions)
|
|
(parse-noun-phrase)))
|
|
|
|
(define (parse-sentence)
|
|
(list 'sentence
|
|
(parse-noun-phrase)
|
|
(parse-verb-phrase)))
|
|
|
|
(define (parse-noun-phrase)
|
|
(define (maybe-extend noun-phrase)
|
|
(amb noun-phrase
|
|
(maybe-extend (list 'noun-phrase
|
|
noun-phrase
|
|
(parse-prepositional-phrase)))))
|
|
(maybe-extend (parse-simple-noun-phrase)))
|
|
|
|
(define (parse-verb-phrase)
|
|
(define (maybe-extend verb-phrase)
|
|
(amb verb-phrase
|
|
(maybe-extend (list 'verb-phrase
|
|
verb-phrase
|
|
(parse-prepositional-phrase)))))
|
|
(maybe-extend (parse-word verbs)))
|
|
|
|
(define (parse-simple-noun-phrase)
|
|
(list 'simple-noun-phrase
|
|
(parse-word articles)
|
|
(parse-word nouns)))
|
|
|
|
(define *unparsed* '())
|
|
(define (parse input)
|
|
(set! *unparsed* input)
|
|
(let ((sent (parse-sentence)))
|
|
(require (null? *unparsed*))
|
|
sent))
|
|
|
|
(parse '(the professor lectures to the student with the cat))
|
|
))
|
|
|
|
;'The professor lectures to the student in the class with the cat.'
|
|
(assert
|
|
(first result)
|
|
'(sentence
|
|
(simple-noun-phrase (article the) (noun professor))
|
|
(verb-phrase
|
|
(verb-phrase
|
|
(verb lectures)
|
|
(prep-phrase (prep to)
|
|
(simple-noun-phrase
|
|
(article the) (noun student))))
|
|
(prep-phrase (prep with)
|
|
(simple-noun-phrase
|
|
(article the) (noun cat))))))
|
|
(assert
|
|
(second result)
|
|
'(sentence
|
|
(simple-noun-phrase (article the) (noun professor))
|
|
(verb-phrase
|
|
(verb lectures)
|
|
(prep-phrase (prep to)
|
|
(noun-phrase
|
|
(simple-noun-phrase
|
|
(article the) (noun student))
|
|
(prep-phrase (prep with)
|
|
(simple-noun-phrase
|
|
(article the) (noun cat))))))))
|
|
|
|
(display "\nex-4.45 - sentence-meanings\n")
|
|
|
|
(amball '(parse '(The professor lectures to the student in the class with the cat)))
|
|
(assert (length result) 5)
|
|
|
|
'(sentence
|
|
(simple-noun-phrase (article the) (noun professor))
|
|
(verb-phrase
|
|
(verb-phrase
|
|
(verb-phrase
|
|
(verb lectures)
|
|
(prep-phrase
|
|
(prep to) (simple-noun-phrase (article the) (noun student))))
|
|
(prep-phrase
|
|
(prep in) (simple-noun-phrase (article the) (noun class))))
|
|
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))
|
|
|
|
; (The professor lectures (to the student) in the class with the cat).
|
|
|
|
'(sentence
|
|
(simple-noun-phrase (article the) (noun professor))
|
|
(verb-phrase
|
|
(verb-phrase
|
|
(verb lectures)
|
|
(prep-phrase (prep to) (simple-noun-phrase (article the) (noun student))))
|
|
(prep-phrase
|
|
(prep in)
|
|
(noun-phrase
|
|
(simple-noun-phrase (article the) (noun class))
|
|
(prep-phrase (prep with)
|
|
(simple-noun-phrase (article the) (noun cat)))))))
|
|
|
|
; (The professor lectures to the student (in the class with the cat)).
|
|
|
|
'(sentence
|
|
(simple-noun-phrase (article the) (noun professor))
|
|
(verb-phrase
|
|
(verb-phrase
|
|
(verb lectures)
|
|
(prep-phrase
|
|
(prep to)
|
|
(noun-phrase
|
|
(simple-noun-phrase (article the) (noun student))
|
|
(prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))))
|
|
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))
|
|
|
|
; The professor lectures (to the student in the class) with the cat.
|
|
|
|
'(sentence
|
|
(simple-noun-phrase (article the) (noun professor))
|
|
(verb-phrase
|
|
(verb lectures)
|
|
(prep-phrase
|
|
(prep to)
|
|
(noun-phrase
|
|
(noun-phrase
|
|
(simple-noun-phrase (article the) (noun student))
|
|
(prep-phrase (prep in)
|
|
(simple-noun-phrase (article the) (noun class))))
|
|
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))
|
|
|
|
; The professor lectures ((to the student in the class) with the cat).
|
|
|
|
'(sentence
|
|
(simple-noun-phrase (article the) (noun professor))
|
|
(verb-phrase
|
|
(verb lectures)
|
|
(prep-phrase
|
|
(prep to)
|
|
(noun-phrase
|
|
(simple-noun-phrase (article the) (noun student))
|
|
(prep-phrase
|
|
(prep in)
|
|
(noun-phrase
|
|
(simple-noun-phrase (article the) (noun class))
|
|
(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))))
|
|
|
|
; The professor lectures (to the student (in the class with the cat)).
|
|
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-4.46 - evaluation-order\n")
|
|
|
|
; Consider the definition of parse sentence. Grammar defines that the
|
|
; noun-phrase comes before the verb-phrase and that is how we ordered the
|
|
; sub-calls to the parser. If the evaluator would read the arguments from right
|
|
; to left it would attempt to parse a verb-phrase first and fail for most
|
|
; sentences (maybe it would work for questions). We could force the correct
|
|
; order by using nested let-expressions to make the code
|
|
; interpreter-independent.
|
|
|
|
; (define (parse-sentence)
|
|
; (list 'sentence
|
|
; (parse-noun-phrase)
|
|
; (parse-word verbs)))
|
|
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-4.47 - alternative-parse-verb-phrase\n")
|
|
|
|
; Louis's code results in an endless-loop. The reason is that amb evaluates its
|
|
; arguments in applicative order. That means (parse-verb-phrase) executes
|
|
; recursively. By parsing the verb-phrase first we avoid this issue. Changing
|
|
; the order of the arguments does not resolve this issue.
|
|
|
|
; (amball '(begin
|
|
; (define (parse-verb-phrase)
|
|
; (display *unparsed*) (display "\n")
|
|
; (amb (parse-word verbs)
|
|
; (list 'verb-phrase
|
|
; (parse-verb-phrase)
|
|
; (parse-prepositional-phrase))))
|
|
; (parse '(the cat eats) ; endless-loop
|
|
; )))
|
|
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-4.48 - parse-other-phrases\n")
|
|
|
|
; Exercise 4.48. Extend the grammar given above to handle more complex
|
|
; sentences. For example, you could extend noun phrases and verb phrases to
|
|
; include adjectives and adverbs, or you could handle compound sentences.53
|
|
|
|
(amball '(begin
|
|
|
|
(define (parse-simple-noun-phrase)
|
|
(list 'simple-noun-phrase
|
|
(parse-word articles)
|
|
(parse-word nouns)))
|
|
|
|
(define (parse-adjective-noun-phrase adjective)
|
|
(amb (list 'adjective-phrase adjective (parse-word nouns))
|
|
(list
|
|
'adjective-phrase
|
|
adjective
|
|
(parse-adjective-noun-phrase (parse-word adjectives)))))
|
|
|
|
(define (parse-simple-noun-phrase)
|
|
(let ((article (parse-word articles)))
|
|
(amb (list 'simple-noun-phrase article (parse-word nouns))
|
|
(list 'adjective-noun-phrase article
|
|
(parse-adjective-noun-phrase (parse-word adjectives))))))
|
|
|
|
(parse '(the bad cat eats))))
|
|
|
|
(assert (first result)
|
|
'(sentence (adjective-noun-phrase (article the) (adjective-phrase (adjective bad) (noun cat))) (verb eats)))
|
|
|
|
(display "\nex-4.49 - generate-sentence\n")
|
|
|
|
(amb5 '(begin
|
|
(define (list-amb word-list)
|
|
(if (null? word-list)
|
|
(amb)
|
|
(amb (car word-list) (list-amb (cdr word-list)))))
|
|
(define (parse-word word-list)
|
|
(require (not (null? *unparsed*)))
|
|
(require (memq (car *unparsed*) (cdr word-list)))
|
|
(let ((found-word (list-amb (cdr word-list))))
|
|
(set! *unparsed* (cdr *unparsed*))
|
|
(list (car word-list) found-word)))
|
|
|
|
(parse '(the cat eats))
|
|
))
|
|
|
|
(map (lambda (r) (display r) (newline)) result)
|
|
(display "[ok]\n")
|
|
|
|
(display "\nex-4.50 - ramb\n")
|
|
|
|
(define (random-element xs)
|
|
(define (create i n xs current others)
|
|
(if (null? xs)
|
|
(list current others)
|
|
(if (= i n)
|
|
(create (+ i 1) n (cdr xs) (car xs) others)
|
|
(create (+ i 1) n (cdr xs) current (cons (car xs) others)))))
|
|
(create 0 (random (length xs)) xs #f '()))
|
|
|
|
(define (analyze-ramb exp)
|
|
(let ((cprocs (map analyze (amb-choices exp))))
|
|
(lambda (env succeed fail)
|
|
(define (try-next choices)
|
|
(if (null? choices)
|
|
(fail)
|
|
(let* ((pair (random-element choices))
|
|
(current (car pair))
|
|
(others (cadr pair)))
|
|
(current env
|
|
succeed
|
|
(lambda () (try-next others))))))
|
|
(try-next cprocs))))
|
|
|
|
(amball '(ramb 1 2 3 4 5))
|
|
(display result) (newline)
|
|
(display "[ok]\n")
|
|
|
|
; This implementation of ramb cannot directly help us with Alyssa's problem
|
|
; because we used list-amb to get amb behavior. We would need list-ramb which would
|
|
; require shuffling the items inside the evalutor or use something like apply.
|
|
|
|
(display "\nex-4.51 - permanent-set!\n")
|
|
|
|
(amball '(begin
|
|
(define count 0)
|
|
(let ((x (amb 'a 'b 'c))
|
|
(y (amb 'a 'b 'c)))
|
|
(permanent-set! count (+ count 1))
|
|
(require (not (eq? x y)))
|
|
(list x y count))
|
|
))
|
|
|
|
; With set! all counts would be 1. With permanent-set! every tried combination
|
|
; increments the counts. Hence, all counts are unique and count increments up
|
|
; to 9. (c c) would be nine and (b c) is eight.
|
|
|
|
(define (last xs)
|
|
(if (null? (cdr xs))
|
|
(car xs)
|
|
(last (cdr xs))))
|
|
|
|
(assert (first result) '(a b 2))
|
|
(assert (last result) '(c b 8))
|
|
|
|
(display "\nex-4.52 - if-fail\n")
|
|
|
|
; Exercise 4.52. Implement a new construct called if-fail that permits the
|
|
; user to catch the failure of an expression. If-fail takes two expressions. It
|
|
; evaluates the first expression as usual and returns as usual if the
|
|
; evaluation succeeds. If the evaluation fails, however, the value of the
|
|
; second expression is returned, as in the following example:
|
|
|
|
(define (analyze-if-fail exp)
|
|
(let ((a (analyze (if-fail-first exp)))
|
|
(b (analyze (if-fail-second exp))))
|
|
(lambda (env succeed fail)
|
|
(a env
|
|
(lambda (a-value fail2) (succeed a-value fail2))
|
|
(lambda () (b env succeed fail))))))
|
|
|
|
;;; Amb-Eval input:
|
|
(amball '(begin
|
|
|
|
(define (even? n)
|
|
(= (remainder n 2) 0))
|
|
|
|
(if-fail (let ((x (amb 1 3 5)))
|
|
(require (even? x))
|
|
x)
|
|
'all-odd)
|
|
|
|
(if-fail (let ((x (amb 1 3 5 8)))
|
|
(require (even? x))
|
|
x)
|
|
'all-odd)
|
|
|
|
))
|
|
|
|
(assert result '(8 all-odd))
|
|
|
|
(display "\nex-4.53\n")
|
|
|
|
; (let ((pairs '()))
|
|
; (if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
|
|
; (permanent-set! pairs (cons p pairs))
|
|
; (amb))
|
|
; pairs))
|
|
|
|
; The code will yield all prime-sum-pairs as expected.
|
|
|
|
(display "[answered]\n")
|
|
|
|
(display "\nex-4.54\n")
|
|
|
|
; Exercise 4.54. If we had not realized that require could be implemented as
|
|
; an ordinary procedure that uses amb, to be defined by the user as part of a
|
|
; nondeterministic program, we would have had to implement it as a special
|
|
; form. This would require syntax procedures
|
|
|
|
; as well the procedure analyze-require that handles require expressions.
|
|
; Complete the following definition of analyze-require.
|
|
|
|
(define (analyze-require exp)
|
|
(let ((pproc (analyze (require-predicate exp))))
|
|
(lambda (env succeed fail)
|
|
(pproc env
|
|
(lambda (pred-value fail2)
|
|
(if (not (true? pred-value))
|
|
(fail2)
|
|
(succeed 'ok fail2)))
|
|
fail))))
|
|
|
|
(display "[done]\n")
|
|
|