The HTML for this page has been automatically generated by parsing the loosely formatted source code & comments included in my solutions repository (https://github.com/zv/SICP-guile), if you encounter any unformatted solutions, you think you’ve spotted an error or you have something you’d like to share about the exercises, don’t hesitate to leave a comment below (or a pull request on the source repo).
Exercises Chapter 4
Notice that we cannot tell whether the metacircular evaluator evaluates operands from left to right or from right to left. Its evaluation order is inherited from the underlying Lisp: If the arguments to cons in list-of-values are evaluated from left to right, then list-of-values will evaluate operands from left to right; and if the arguments to cons are evaluated from right to left, then list-of-values will evaluate operands from right to left.
Write a version of list-of-values that evaluates operands from left to right regardless of the order of evaluation in the underlying Lisp. Also write a version of list-of-values that evaluates operands from right to left.
(define (rtl-list-of-values exps env) (if (no-operands? exps) '() (let* ((left (zeval (first-operand exps) env) ) (right (rtl-list-of-values (rest-operands exps) env) )) (cons left right))))
Louis Reasoner plans to reorder the cond clauses in eval so that the clause for procedure applications appears before the clause for assignments. He argues that this will make the interpreter more efficient: Since programs usually contain more applications than assignments, definitions, and so on, his modified eval will usually check fewer clauses than the original eval before identifying the type of an expression.
- What is wrong with Louis’s plan? (Hint: What will Louis’s evaluator do with the expression (define x 3)?)
- Louis is upset that his plan didn’t work. He is willing to go to any lengths to make his evaluator recognize procedure applications before it checks for most other kinds of expressions. Help him by changing the syntax of the evaluated language so that procedure applications start with call. For example, instead of (factorial 3) we will now have to write (call factorial 3) and instead of (+ 1 2) we will have to write (call + 1 2).
#| Answer: 1: The order of operations will cause some variables to be undefined. As the example suggests, define will be called with 'x' and '3' as arguments. `define' cannot be made into a procedure because the arguments will be evaluated. 2. Only `application' need be changed: (define application? (exp) (tagged-list? exp 'call)) (define operator (exp) (cadr exp)) (define operands (exp) (cddr exp)) |#
Rewrite eval so that the dispatch is done in data-directed style. Compare this with the data-directed differentiation procedure of Exercise 2.73. (You may use the car of a compound expression as the type of the expression, as is appropriate for the syntax implemented in this section.)
(define-class <dispatch-table> () (method-table #:init-value (make-hash-table) #:getter method-table)) (define (table-ordinal op type) (let ([opstr (symbol->string op)] [typestr (symbol->string type)]) (string-append opstr "/" typestr))) (define-method (get (dt <dispatch-table>) op type) (if (and (symbol? op) (symbol? type)) (hash-ref (method-table dt) (table-ordinal op type)) #f)) (define-method (put (dt <dispatch-table>) op type item) (hash-set! (method-table dt) (table-ordinal op type) item)) (define dispatch-tt (make <dispatch-table>)) (define (list-tag expr) "Extract the type of expression" (if (pair? expr) (car expr) #f)) (define (install-procedure p) (put dispatch-tt 'eval (car p) (cadr p))) ;; Install our procedures (map install-procedure `([quote ,(λ (expr env) (text-of-quotation expr))] [set! ,eval-assignment] [define ,eval-definition] [if ,eval-if] [lambda ,(λ (expr env) (make-procedure (lambda-parameters expr) (lambda-body expr) env))] [begin ,(λ (expr env) (eval-sequence (begin-actions expr) env))] [cond ,(λ (expr env) (zeval (cond->if expr) env))])) (define (zeval expr env) (let ([dispatch-fn (get dispatch-tt 'eval (list-tag expr))]) (cond [(self-evaluating? expr) expr] [(variable? expr) (lookup-variable-value expr env)] [(procedure? dispatch-fn) (dispatch-fn expr env)] [(application? expr) (zapply (zeval (operator expr) env) (list-of-values (operands expr) env))] [else (error "Bad Expression" expr)]))) (define (install-driver-loop evaluator fn) (put dispatch-tt 'driver-loop evaluator fn)) (install-driver-loop 'zeval base-driver-loop)
Recall the definitions of the special forms and and or from Chapter 1:
`and’: The expressions are evaluated from left to right. If any expression evaluates to false, false is returned; any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then true is returned. `or’: The expressions are evaluated from left to right. If any expression evaluates to a true value, that value is returned; any remaining expressions are not evaluated. If all expressions evaluate to false, or if there are no expressions, then false is returned.
Install `and’ and `or’ as new special forms for the evaluator by defining appropriate syntax procedures and evaluation procedures eval-and and eval-or. Alternatively, show how to implement and and or as derived expressions.
(define (disjunct exp) (if (null? (cdr exp)) 'false (cadr exp))) (define (rest-disjunctions exp) (if (null? (cdr exp)) '() (cddr exp))) ;; or (define (or? exp) (tagged-list? exp 'or)) (define (eval-or exp env) (eval-connective exp env true?)) (install-procedure `(or ,eval-or)) ;; and (define (and? exp) (tagged-list? exp 'and)) (define (eval-and exp env) (eval-connective exp env false?)) (install-procedure `(and ,eval-and)) (define (eval-connective exp env oper) "eval-connective evaluates the first part of an expression in the given environment. If the result applied to `oper' is false, it continues to evaluate until `(oper exp)' argument returns true or no arguments remain." (let ([disjunction (zeval (disjunct exp) env)] [rest-disjunctions (rest-disjunctions exp)]) (if (or (oper disjunction) (null? rest-disjunctions)) disjunction (eval-connective (cons (operator exp) rest-disjunctions) env oper))))
Scheme allows an additional syntax for cond clauses, (⟨test⟩ => ⟨recipient⟩). If ⟨test⟩ evaluates to a true value, then ⟨recipient⟩ is evaluated. Its value must be a procedure of one argument; this procedure is then invoked on the value of the ⟨test⟩, and the result is returned as the value of the cond expression. For example
(cond ((assoc ’b ’((a 1) (b 2))) => cadr) (else false))
returns 2. Modify the handling of cond so that it supports this extended syntax.
(define (cond-is-pipe? exp) (if (pair? exp) (eq? (cadr exp) '=>) #f)) (define (cond-recipient exp) (caddr exp)) (define (expand-clauses clauses) (if (null? clauses) 'false (let ([first (car clauses)] [rest (cdr clauses)]) ;; check for => (if (cond-is-pipe? first) (let ([test (cond-predicate first)]) (make-if test (list (cond-recipient first) test) (expand-clauses rest))) ;; otherwise a normal cond applies (if (cond-else-clause? first) (if (null? rest) (sequence->exp (cond-actions first)) (error "ELSE clause isn't last: COND->IF" clauses)) (make-if (cond-predicate first) (sequence->exp (cond-actions first)) (expand-clauses rest)))))))
Let expressions are derived expressions, because
(let ((⟨var₁⟩ ⟨exp₁⟩) … (⟨varₙ⟩ ⟨expₙ⟩)) ⟨body⟩)
is equivalent to
((lambda (⟨var₁⟩ … ⟨varₙ⟩) ⟨body⟩) ⟨exp₁⟩ … ⟨expₙ⟩)
Implement a syntactic transformation let->combination that reduces evaluating let expressions to evaluating combinations of the type shown above, and add the appropriate clause to eval to handle let expressions.
(generate-accessors ([let-bindings cadr] [let-body cddr] [let-binding-vars (cut map car <...>)] [let-binding-exprs (cut map cadr <...>)] [let-vars (compose let-binding-vars let-bindings)] [let-exprs (compose let-binding-exprs let-bindings)])) (define (make-let->lambda vars exprs body) "Makes a let expression as ((lambda (vars) body) exprs)" (cons (make-lambda vars body) exprs)) (define (let->combination exp) (if (null? exp) 'false (let ([bindings (let-bindings exp)] [body (let-body exp)]) (make-let->lambda (let-binding-vars bindings) (let-binding-exprs bindings) body)))) (install-procedure `(let ,(λ (exp env) (zeval (let->combination exp) env))))
`let*’ is similar to `let’, except that the bindings of the `let*’ variables are performed sequentially from left to right, and each binding is made in an environment in which all of the preceding bindings are visible. For example
(let* ((x 3) (y (+ x 2)) (z (+ x y 5))) (* x z))
returns 39. Explain how a `let*’ expression can be rewritten as a set of nested let expressions, and write a procedure `let*->nested-lets’ that performs this transformation. If we have already implemented let (Exercise 4.6) and we want to extend the evaluator to handle `let*’, is it sufficient to add a clause to eval whose action is
(eval (let*->nested-lets exp) env)
(let (x 3) (let (y 2) 1))
((lambda (x) (lambda (y) 1) 2) 3)
or must we explicitly expand `let*’ in terms of non-derived expressions?
;;; There is nothing preventing `let*' from being defined in terms of existing ;;; `let' expressions (generate-accessors ([let*-body caddr] [let*-inits cadr])) ;;;; This is a little funky here, I've replaced this with another version copied ;;;; online -- the only thing wrong with this is some monkeying around with the let ;;;; order ;; (define (let*->nested-let exp) ;; (define (next exp) ;; (list (operator exp) (cdadr exp) (caddr exp))) ;; (if (null? exp) 'false ;; (let ([bindings (let-bindings exp)] ;; [body (let-body exp)]) ;; (if (null? bindings) body ;; (make-let->lambda ;; (list (car (let-binding-vars bindings))) ;; (list (car (let-binding-exprs bindings))) ;; (let*->nested-let (next exp))))))) (define (let*->nested-lets expr) (let ([inits (let*-inits expr)] [body (let*-body expr)]) (define (next expr) (if (null? expr) body (list 'let (list (car expr)) (next (cdr expr))))) (next inits))) (install-procedure `(let* ,(λ (exp env) (zeval (let*->nested-lets exp) env))))
“Named let” is a variant of let that has the form
(let ⟨var⟩ ⟨bindings⟩ ⟨body⟩)
The ⟨bindings⟩ and ⟨body⟩ are just as in ordinary let, except that ⟨var⟩ is bound within ⟨body⟩ to a procedure whose body is ⟨body⟩ and whose parameters are the variables in the ⟨bindings⟩. Thus, one can repeatedly execute the ⟨body⟩ by invoking the procedure named ⟨var⟩. For example, the iterative Fibonacci procedure (1.2.2) can be rewritten using named let as follows:
(define (fib n) (let fib-iter ((a 1) (b 0) (count n)) (if (= count 0) b (fib-iter (+ a b) a (- count 1)))))
Modify let->combination of Exercise 4.6 to also support named let.
(define (named-let? exp) (symbol? (cadr exp))) (generate-accessors ([nlet-var cadr] [nlet-bindings caddr] [nlet-body cdddr])) (define (make-named-let exp) ;; get prepped for that long let (let* ([body (nlet-body exp)] [bindings (nlet-bindings exp)] [vars (let-binding-vars bindings)] [exprs (let-binding-exprs bindings)] [fnname (nlet-var exp)] [fn (make-lambda vars body)]) (%as-syntax (let ,bindings (begin (define ,fnname ,fn) ,@body))))) (define (let->combination exp) (if (null? exp) 'false (if (named-let? exp) (make-named-let exp) ;; otherwise we're processing a normal let (make-let->lambda (let-vars exp) (let-exprs exp) (let-body exp)))))
Many languages support a variety of iteration constructs, such as `do’, `for’, `while’, and `until’. In Scheme, iterative processes can be expressed in terms of ordinary procedure calls, so special iteration constructs provide no essential gain in computational power. On the other hand, such constructs are often convenient. Design some iteration constructs, give examples of their use, and show how to implement them as derived expressions.
(generate-accessors ([while-cond cadr] [while-body caddr])) (define (make-while exp) (let ([body (while-body exp)] [cond (while-cond exp)]) (if (null? cond) 'false (%as-syntax (let while-loop () (if ,cond (begin ,body (while-loop)) false)))))) (install-procedure `(while ,(λ (exp env) (zeval (make-while exp) env))))
Exercise 4.11 & Exercise 4.12
4.11: Instead of representing a frame as a pair of lists, we can represent a frame as a list of bindings, where each binding is a name-value pair. Rewrite the environment operations to use this alternative representation.
4.12: The procedures define-variable!, set-variable-value! and lookup-variable-value can be expressed in terms of more abstract procedures for traversing the environment structure. Define abstractions that capture the common patterns and redefine the three procedures in terms of these abstractions.
(define (make-frame variables values) (map cons variables values)) (define (var-process var environment fn) (define (var-search env) (if (eq? env the-empty-environment) (begin ;;(pretty-print environment) (error "Unbound variable" var)) (let* ([frame (first-frame env)] [entry (assoc var frame)]) (if entry (fn frame entry) (var-search (enclosing-environment env)))))) (var-search environment)) (define (lookup-variable-value var env) (var-process var env (λ (_frame entry) (cdr entry)))) (define (set-variable-value! var val env) (var-process var env (λ (frame entry) (set-cdr! entry val)))) (define (define-variable! var val env) (set-car! env (assoc-set! (first-frame env) var val)))
Scheme allows us to create new bindings for variables by means of define, but provides no way to get rid of bindings. Implement for the evaluator a special form make-unbound! that removes the binding of a given symbol from the environment in which the make-unbound! expression is evaluated. This problem is not completely specified. For example, should we remove only the binding in the first frame of the environment? Complete the specification and justify any choices you make.
#| Spec: `undefine' and `unset' are functions that set the name of the binding inside the closest stack-frame to null. |# (define (undefine-variable! var env) (var-process var env (λ (frame entry) (set-car! entry '())))) (define (eval-undefinition exp env) (undefine-variable! (definition-variable exp) env) 'ok) (install-procedure `(undefine ,eval-undefinition))
Eva Lu Ator and Louis Reasoner are each experimenting with the metacircular evaluator. Eva types in the definition of map, and runs some test programs that use it. They work fine. Louis, in contrast, has installed the system version of map as a primitive for the metacircular evaluator. When he tries it, things go terribly wrong. Explain why Louis’s map fails even though Eva’s works.
#| Solution: Louis is trying to use a variable defined inside the *interpreters* stack frame, not the *interpreTED* stack frame |#
Given a one-argument procedure p and an object a, p is said to “halt” on a if evaluating the expression (p a) returns a value (as opposed to terminating with an error message or running forever). Show that it is impossible to write a procedure halts? that correctly determines whether p halts on a for any procedure p and object a. Use the following reasoning: If you had such a procedure halts?, you could implement the following program:
(define (run-forever) (run-forever))
(define (try p) (if (halts? p p) (run-forever) ’halted))
Now consider evaluating the expression (try try) and show that any possible outcome (either halting or running forever) violates the intended behavior of halts?.
#| - - - - - Solution: This problem is an abstract description of a thought experiment Turing conducted in the 1930s which would later be known as the 'halting problem'. The problem has no solution for a similar reason to the 'liar' paradox: Suppose it returns true -- `try' enters an endless loop, so it obviously doesn’t halt, while halts? returned true. The contrawise position is identical Therefore there can be no solution to the problem |#
In this exercise we implement the method just described for interpreting internal definitions. We assume that the evaluator supports let (see Exercise 4.6).
- Change `lookup-variable-value’ (4.1.3) to signal an error if the value it finds
is the symbol unassigned.
- Write a procedure `scan-out-defines’ that takes a procedure body and returns an
equivalent one that has no internal definitions, by making the transformation described above.
- Install `scan-out-defines’ in the interpreter, either in make-procedure or in
procedure-body (see 4.1.3). Which place is better? Why?
;; 1. Solution (define (simultaneous/lookup-variable-value var env) (var-process var env (λ (_f entry) (if (eq? (cdr entry) '*unassigned*) (error "Unassigned var: " var) (cdr entry))))) ;; 2 (define (scan-out-defines expr) "Transform a procedure, returning an equivalent one with no internal definitions" (define has-define (find (λ (e) (and (pair? e) (eq? (car e) 'define))) expr)) (if has-define (fold (λ (elt prev) (let ([bindings (let-bindings prev)] [body (let-body prev)]) ;; merge our (new) bindings & body (match elt [('define var val) `(let ((,var '*unassigned*) ,@bindings) (set! ,var ,val) ;; we use ,@ to prevent recursive lists ,@body)] [_ `(let ,bindings ,@body ,elt)]))) '(let ()) ;; we start with a basic let expression expr) expr)) ;; simulatanous test (assert-equal (scan-out-defines '((define a 1) (make-thing 1) (define b 2) (define c 3) (make-thing a 1))) '(let ((c '*unassigned*) (b '*unassigned*) (a '*unassigned*)) (set! c 3) (set! b 2) (set! a 1) (make-thing 1) (make-thing a 1))) ;; 3 -- I've selected make-procedure so that the conversion is done at ;; interpretation, rather than runtime. (define (simultaneous/make-procedure parameters body env) (list 'procedure parameters (scan-out-defines body) env))
Consider an alternative strategy for scanning out definitions that translates the example in the text to
(lambda ⟨vars⟩ (let ((u ’unassigned) (v ’unassigned)) (let ((a ⟨e1⟩) (b ⟨e2⟩)) (set! u a) (set! v b)) ⟨e3⟩))
Here a and b are meant to represent new variable names, created by the interpreter, that do not appear in the user’s program. Consider the solve procedure from 3.5.4:
(define (solve f y0 dt) (define y (integral (delay dy) y0 dt)) (define dy (stream-map f y)) y)
Will this procedure work if internal definitions are scanned out as shown in this exercise? What if they are scanned out as shown in the text? Explain.
; - - - - - - Solution: ;; This wont work because the proxy-value of `y' (a) cannot be directly ;; referenced upon the definition of `dy'
Ben Bitdiddle, Alyssa P. Hacker, and Eva Lu Ator are arguing about the desired result of evaluating the expression
(let ((a 1)) (define (f x) (define b (+ a x)) (define a 5) (+ a b)) (f 10))
Ben asserts that the result should be obtained using the sequential rule for define: `b’ is defined to be 11, then `a’ is defined to be 5, so the result is
- Alyssa objects that mutual recursion requires the simultaneous scope rule
for internal procedure definitions, and that it is unreasonable to treat procedure names differently from other names. Thus, she argues for the mechanism implemented in Exercise 4.16. This would lead to a being unassigned at the time that the value for `b’ is to be computed. Hence, in Alyssa’s view the procedure should produce an error. Eva has a third opinion. She says that if the definitions of `a’ and `b’ are truly meant to be simultaneous, then the value 5 for `a’ should be used in evaluating b. Hence, in Eva’s view `a’ should be 5, `b’ should be 15, and the result should be 20. Which (if any) of these viewpoints do you support? Can you devise a way to implement internal definitions so that they behave as Eva prefers?
#| Solution I like Alyssas view, although Ben's dominates most thinking. |# ;; Eva's view can be easily supported by swapping the order within the `let' ;; quasiquote of `set!' and `@,body'
Exercise 4.20 (lol)
Because internal definitions look sequential but are actually simultaneous, some people prefer to avoid them entirely, and use the special form letrec instead. Letrec looks like let, so it is not surprising that the variables it binds are bound simultaneously and have the same scope as each other. The sample procedure f above can be written without internal definitions, but with exactly the same meaning, as
(define (f x) (letrec ((even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (odd? (lambda (n) (if (= n 0) false (even? (- n 1)))))) ⟨rest of body of f⟩))
`letrec’ expressions, which have the form
(letrec ((⟨var₁⟩ ⟨exp₁⟩) … (⟨varₙ⟩ ⟨expₙ⟩)) ⟨body⟩)
are a variation on let in which the expressions ⟨expₖ⟩ that provide the initial values for the variables ⟨varₖ⟩ are evaluated in an environment that includes all the letrec bindings. This permits recursion in the bindings, such as the mutual recursion of even? and odd? in the example above, or the evaluation of 10 factorial with
(letrec ((fact (lambda (n) (if (= n 1) 1 (* n (fact (- n 1))))))) (fact 10))
- Implement letrec as a derived expression, by transforming a letrec expression
into a let expression as shown in the text above or in Exercise 4.18. That is, the letrec variables should be created with a let and then be assigned their values with set!.
- Louis Reasoner is confused by all this fuss about internal definitions. The
way he sees it, if you don’t like to use define inside a procedure, you can just use let. Illustrate what is loose about his reasoning by drawing an environment diagram that shows the environment in which the ⟨rest of body of f⟩ is evaluated during evaluation of the expression (f 5), with f defined as in this exercise. Draw an environment diagram for the same evaluation, but with let in place of letrec in the definition of f.
;; 1. (define (letrec->let expr) (%as-syntax (let ,(map ; generate the (binding . '*unassigned) let binds (λ (v) (list v ''*unassigned)) (map car (cadr expr))) ,@(map ; generate the `set!' expressions (λ (bind) `(set! ,(car bind) ,(cadr bind))) (let-bindings expr)) ;; and merge our existing body ,@(let-body expr)))) (assert-equal (letrec->let `(letrec ((a (lambda () (b))) (b (lambda () (a)))) (x a) (x b) (x c))) '(let ((a '*unassigned) (b '*unassigned)) (set! a (lambda () (b))) (set! b (lambda () (a))) (x a) (x b) (x c))) (install-procedure `(letrec ,(λ (exp env) (zeval (letrec->let exp) env)))) ;; 2. ;; The main problem with Louis's reasoning is that the environment that `let' is ;; being evaluating against is actually expressed in the form of a `lambda' whoses ;; actual function bodies are being passed in as arguments (in the case of (f x)), ;; this means that the lexical scope of `even?' cannot see that of `odd?' and ;; versa.
Amazingly, Louis’s intuition in Exercise 4.20 is correct. It is indeed possible to specify recursive procedures without using letrec (or even define), although the method for accomplishing this is much more subtle than Louis imagined. The following expression computes 10 factorial by applying a recursive factorial procedure:231
((lambda (n) ((lambda (fact) (fact fact n)) (lambda (ft k) (if (= k 1) 1 (* k (ft ft (- k 1)))))))
- Check (by evaluating the expression) that this really does compute
factorials. Devise an analogous expression for computing Fibonacci numbers.
Consider the following procedure, which includes mutually recursive internal definitions:
(define (f x) (define (even? n) (if (= n 0) true (odd? (- n 1)))) (define (odd? n) (if (= n 0) false (even? (- n 1)))) (even? x))
- Fill in the missing expressions to complete an alternative definition of f,
which uses neither internal definitions nor letrec:
(define (f x) ((lambda (even? odd?) (even? even? odd? x)) (lambda (ev? od? n) (if (= n 0) true (od? ⟨??⟩ ⟨??⟩ ⟨??⟩))) (lambda (ev? od? n) (if (= n 0) false (ev? ⟨??⟩ ⟨??⟩ ⟨??⟩)))))
;; 1. ;; It does indeed produce Factorials (define funk-fibonacci (λ (n) ;; (it's a fibonacci number) ((λ (fib) (fib fib n)) (λ (fb k) (match k [0 1] [1 1] [_ (+ (fb fb (- k 1)) (fb fb (- k 2)))]))))) ;; 2. (define (feven-4.21 x) ((λ (even? odd?) (even? even? odd? x)) (λ (ev? od? n) (if (= n 0) #t (od? ev? od? (- n 1)))) (λ (ev? od? n) (if (= n 0) #f (ev? ev? od? (- n 1)))))) (assert (= (funk-fibonacci 4) 5)) (assert (feven-4.21 4))
Extend the evaluator in this section to support the special form let. (See Exercise 4.6.)
(install-analyze-procedure `(let ,(λ (exp) (analyze (let->combination exp)))))
Suppose that (in ordinary applicative-order Scheme) we define unless as shown above and then define factorial in terms of unless as
(define (factorial n) (unless (= n 1) (* n (factorial (- n 1))) 1)) What happens if we attempt to evaluate (factorial 5)? Will our definitions work in a normal-order language?
;; Solution: ;; Applicative order languages will cause an infinite loop with the definition ;; of `unless' provided by SICP -- on the other hand a normal-order language will ;; do just fine
Ben Bitdiddle and Alyssa P. Hacker disagree over the importance of lazy evaluation for implementing things such as unless. Ben points out that it’s possible to implement unless in applicative order as a special form. Alyssa counters that, if one did that, unless would be merely syntax, not a procedure that could be used in conjunction with higher-order procedures. Fill in the details on both sides of the argument. Show how to implement unless as a derived expression (like cond or let), and give an example of a situation where it might be useful to have unless available as a procedure, rather than as a special form.
(define (zv-unless condition consequent alternative) (if condition alternative consequent)) (generate-accessors ([unless-predicate cadr] [unless-alternative caddr])) (define (unless-consequent exp) (if (not (null? (cdddr exp))) (cadddr exp) 'false)) (define (unless->if exp) (make-if (unless-predicate exp) (unless-consequent exp) (unless-alternative exp))) (define (analyze-unless exp) (let ([pproc (analyze (unless-predicate exp))] [cproc (analyze (unless-consequent exp))] [aproc (analyze (unless-alternative exp))]) (lambda (env) (if (true? (pproc env)) (cproc env) (aproc env))))) (install-procedure `(unless ,(λ (exp env) (zeval (unless->if exp) env)))) (install-analyze-procedure `(unless ,analyze-unless)) ;; this functions utility is for lazy bums who cant type `not' ;; Various evaluator utils
Suppose we type in the following definitions to the lazy evaluator:
(define count 0) (define (id x) (set! count (+ count 1)) x) (define w (id (id 10)))
Give the missing values in the following sequence of interactions, and explain your answers.
;;; L-Eval input: count
;;; L-Eval value: 1
;;; L-Eval input: w
;;; L-Eval value: 10
;;; L-Eval input: count
;;; L-Eval value: 2
lazy-eval uses actual-value rather than leval to evaluate the operator before passing it to apply, in order to force the value of the operator. Give an example that demonstrates the need for this forcing.
;; Solution ;; Any function using a lambda as an argument will fail -- the operands are ;; not forced and when trying to apply them you will attempt to apply a thunk ;; instead of a "real" value.
Exhibit a program that you would expect to run much more slowly without memoization than with memoization. Also, consider the following interaction, where the id procedure is defined as in Exercise 4.27 and count starts at 0:
(define (square x) (* x x))
;;; L-Eval input: (square (id 10))
;;; L-Eval value: ⟨response⟩
;;; L-Eval input: count
;;; L-Eval value: ⟨response⟩
Give the responses both when the evaluator memoizes and when it does not.
;; Solutions ;; The canonical example of a function sped up by memoization is factorial -- ;; each of the components can be reused n^2 times #| Memoized: ;;; L-Eval input: (square (id 10)) ;;; L-Eval value: 100 ;;; L-Eval input: count ;;; L-Eval value: 1 |# #| Raw: ;;; L-Eval input: (square (id 10)) ;;; L-Eval value: 100 ;;; L-Eval input: count ;;; L-Eval value: 2 |#
Cy D. Fect, a reformed C programmer, is worried that some side effects may never take place, because the lazy evaluator doesn’t force the expressions in a sequence. Since the value of an expression in a sequence other than the last one is not used (the expression is there only for its effect, such as assigning to a variable or printing), there can be no subsequent use of this value (e.g., as an argument to a primitive procedure) that will cause it to be forced. Cy thus thinks that when evaluating sequences, we must force all expressions in the sequence except the final one. He proposes to modify eval-sequence from 4.1.1 to use actual-value rather than eval:
(define (eval-sequence exps env) (cond ((last-exp? exps) (eval (first-exp exps) env)) (else (actual-value (first-exp exps) env) (eval-sequence (rest-exps exps) env))))
- Ben Bitdiddle thinks Cy is wrong. He shows Cy the for-each procedure
described in Exercise 2.23, which gives an important example of a sequence with side effects:
(define (for-each proc items) (if (null? items) ’done (begin (proc (car items)) (for-each proc (cdr items)))))
He claims that the evaluator in the text (with the original eval-sequence) handles this correctly:
;;; L-Eval input: (for-each (lambda (x) (newline) (display x)) ’(57 321 88)) 57 321 88
;;; L-Eval value: done
Explain why Ben is right about the behavior of for-each.
- Cy agrees that Ben is right about the for-each example, but says that that’s
not the kind of program he was thinking about when he proposed his change to eval-sequence. He defines the following two procedures in the lazy evaluator:
(define (p1 x) (set! x (cons x ’(2))) x)
(define (p2 x) (define (p e) e x) (p (set! x (cons x ’(2)))))
What are the values of (p1 1) and (p2 1) with the original eval-sequence? What would the values be with Cy’s proposed change to eval-sequence?
- Cy also points out that changing eval-sequence as he proposes does not affect
the behavior of the example in part a. Explain why this is true.
- How do you think sequences ought to be treated in the lazy evaluator? Do you
like Cy’s approach, the approach in the text, or some other approach?
#| Solutions 1. In `for-each's case, the procedure is called every time, all primitive procedures are called -- even if they are the last. 2. leval: (p1 1) => (1 2); (p2 1) => 1 (`e' is never evaluated -- it's a compound procedure) actual-value: (p1 1) => (1 2); (p2 1) => (1 2) 3. There is no difference -- primitive procedures are called either way 4. Side effects are a critical aspect of computer programming -- a lazy computer system needs to execute them in a manner consistent with our expectations of a basic interpreter -- Cy's approach is the winner. |#
The approach taken in this section is somewhat unpleasant, because it makes an incompatible change to Scheme. It might be nicer to implement lazy evaluation as an upward-compatible extension, that is, so that ordinary Scheme programs will work as before. We can do this by extending the syntax of procedure declarations to let the user control whether or not arguments are to be delayed. While we’re at it, we may as well also give the user the choice between delaying with and without memoization. For example, the definition
(define (f a (b lazy) c (d lazy-memo)) …)
would define f to be a procedure of four arguments, where the first and third arguments are evaluated when the procedure is called, the second argument is delayed, and the fourth argument is both delayed and memoized. Thus, ordinary procedure definitions will produce the same behavior as ordinary Scheme, while adding the lazy-memo declaration to each parameter of every compound procedure will produce the behavior of the lazy evaluator defined in this section. Design and implement the changes required to produce such an extension to Scheme. You will have to implement new syntax procedures to handle the new syntax for define. You must also arrange for eval or apply to determine when arguments are to be delayed, and to force or delay arguments accordingly, and you must arrange for forcing to memoize or not, as appropriate.
(define (perpetual-thunk? obj) (tagged-list? obj 'always-thunk)) (define (delay-it-perpetually exp env) (list 'always-thunk exp env)) (define (list-of-resolved-args parameters arguments env) (map (λ (p a) (match p [(_ 'lazy) (delay-it-perpetually a env)] [(_ 'lazy-memo) (delay-it a env)] [_ a])) parameters arguments)) (define (force-it obj) "This is just a memoizing version of `force-it'" (define (fetch-result e) (actual-value (thunk-exp e) (thunk-env e))) (match obj [thunk? (let ([result (fetch-result obj)]) (set! obj `(evaluated-thunk ,result)) result)] [evaluated-thunk? (thunk-value obj)] [perpetual-thunk? (fetch-result obj)] [_ obj])) (define (fetch-parameter p) (if (pair? p) (car p) p)) (define (extract-parameters fn) (map fetch-parameter (procedure-parameters fn))) (define (capply procedure arguments env) "capply is a combined `apply' function -- determining which parameters are lazy, memoized or raw and supplying them to the function at hand" ;;(format #t "procedure: ~a\narguments: ~a\nenv: ~a" procedure arguments env) (cond ((primitive-procedure? procedure) (apply-primitive-procedure procedure (list-of-arg-values arguments env))) ; changed ((compound-procedure? procedure) (leval-sequence (procedure-body procedure) (extend-environment (extract-parameters procedure) (list-of-resolved-args (procedure-parameters procedure) arguments env) ; changed (procedure-environment procedure)))) (else (error "Unknown procedure type: APPLY" procedure)))) ;; Install our new driver-loop (define (combined-driver-loop) (prompt-for-input ";; Strict/Lazy (ceval) input: ") (let* ((input (read)) (output (actual-value input the-global-environment))) (announce-output output-prompt) (user-print output)) (combined-driver-loop)) (install-driver-loop 'ceval combined-driver-loop)
Write a procedure an-integer-between that returns an integer between two given bounds. This can be used to implement a procedure that finds Pythagorean triples, i.e., triples of integers ( i , j , k ) between the given bounds such that i ≤ j and i 2 + j 2 = k 2 , as follows:
(define (a-pythagorean-triple-between low high) (let ((i (an-integer-between low high))) (let ((j (an-integer-between i high))) (let ((k (an-integer-between j high))) (require (= (+ (* i i) (* j j)) (* k k))) (list i j k)))))
(amb/infuse '(define (an-integer-between low high) (require (< low high)) (amb low (an-integer-between (+ 1 low) high))))
Exercise 3.69 discussed how to generate the stream of all Pythagorean triples, with no upper bound on the size of the integers to be searched. Explain why simply replacing an-integer-between by an-integer-starting-from in the procedure in Exercise 4.35 is not an adequate way to generate arbitrary Pythagorean triples. Write a procedure that actually will accomplish this. (That is, write a procedure for which repeatedly typing try-again would in principle eventually generate all Pythagorean triples.)
(append! primitive-procedures `((sqrt ,sqrt))) (amb/infuse '(define (pyth-triple) (define k (an-integer-starting-from 1)) (define j (an-integer-between 1 k)) (define i (an-integer-between 1 j)) (require (= (+ (* i i) (* j j)) (* k k))) (list i j k))) #| Solution Explanation: Depth first search means that an infinite `amb' loop will never progress past the first 'amb' |#
Ben Bitdiddle claims that the following method for generating Pythagorean triples is more efficient than the one in Exercise 4.35. Is he correct? (Hint: Consider the number of possibilities that must be explored.)
(define (a-pythagorean-triple-between low high) (let ((i (an-integer-between low high)) (hsq (* high high))) (let ((j (an-integer-between i high))) (let ((ksq (+ (* i i) (* j j)))) (require (>= hsq ksq)) (let ((k (sqrt ksq))) (require (integer? k)) (list i j k))))))
;; It seems to be -- Ben's method only uses N^2 space, while the .35 method uses ;; N^3 space, while also throwing away tons of 'impossible' results.
Modify the multiple-dwelling procedure to omit the requirement that Smith and Fletcher do not live on adjacent floors. How many solutions are there to this modified puzzle?
#| Solution ;; There are 5 distinct solutions |# (amb/infuse '(define (multiple-dwelling) (define baker (amb 1 2 3 4 5)) (define cooper (amb 1 2 3 4 5)) (define fletcher (amb 1 2 3 4 5)) (define miller (amb 1 2 3 4 5)) (define smith (amb 1 2 3 4 5)) (require (distinct? (list baker cooper fletcher miller smith))) (require (not (= baker 5))) (require (not (= cooper 1))) (require (not (= fletcher 5))) (require (not (= fletcher 1))) (require (> miller cooper)) (require (not (= (abs (- fletcher cooper)) 1))) (list (list 'baker baker) (list 'cooper cooper) (list 'fletcher fletcher) (list 'miller miller) (list 'smith smith))))
Does the order of the restrictions in the multiple-dwelling procedure affect the answer? Does it affect the time to find an answer? If you think it matters, demonstrate a faster program obtained from the given one by reordering the restrictions. If you think it does not matter, argue your case.
#| Solution: The order of the restrictions can matter regarding runtime invoking the 'failure' continuation through a `require' statement or otherwise can prevent a great deal of work from being performed. |#
TODO: Exercise 4.40
In the multiple dwelling problem, how many sets of assignments are there of people to floors, both before and after the requirement that floor assignments be distinct? It is very inefficient to generate all possible assignments of people to floors and then leave it to backtracking to eliminate them. For example, most of the restrictions depend on only one or two of the person-floor variables, and can thus be imposed before floors have been selected for all the people. Write and demonstrate a much more efficient nondeterministic procedure that solves this problem based upon generating only those possibilities that are not already ruled out by previous restrictions. (Hint: This will require a nest of `let’ expressions.)
Write an ordinary Scheme program to solve the multiple dwelling puzzle.
(define possible-floors '([baker (1 2 3 4)] [cooper (2 3 4 5)] [fletcher (2 3 4)] [miller (3 4 5)] [smith (1 2 3 4 5)])) (define (solve-it floors) (define (valid? lst) (define (distinct? lst) (cond ((null? lst) #t) ((null? (cdr lst)) #t) (else (and (not (member (car lst) (cdr lst))) (distinct? (cdr lst)))))) (and (distinct? (map cdr lst)) (> (assoc-ref lst 'miller) (assoc-ref lst 'cooper)) ;; check that smith and fletcher are not adjacent (not (= 1 (abs (- (assoc-ref lst 'smith) (assoc-ref lst 'fletcher))))) (not (= 1 (abs (- (assoc-ref lst 'cooper) (assoc-ref lst 'fletcher))))))) (define (recursive-level lst acc) (if (null? lst) (if (valid? acc) (display acc)) (let* ((top (car lst)) (name (car top)) (pfloors (cadr top))) (map (λ (elt) (recursive-level (cdr lst) (cons (cons name elt) acc))) pfloors)))) (recursive-level floors '()))
Solve the following “Liars” puzzle (from Phillips 1934):
Five schoolgirls sat for an examination. Their parents–so they thought–showed an undue degree of interest in the result. They therefore agreed that, in writing home about the examination, each girl should make one true statement and one untrue one. The following are the relevant passages from their letters:
- Betty: “Kitty was second in the examination. I was only third.”
- Ethel: “You’ll be glad to hear that I was on top. Joan was second.”
- Joan: “I was third, and poor old Ethel was bottom.”
- Kitty: “I came out second. Mary was only fourth.”
- Mary: “I was fourth. Top place was taken by Betty.”
What in fact was the order in which the five girls were placed?
(append! primitive-procedures `((and ,(λ (a b) (and a b))))) ;;(append! primitive-procedures `((or ,(λ (a b) (or a b))))) (define (amb/eval-or expr) "Both `or' and `and' can be implemented as primitive procedures without significant issue, `amb/eval-or' exists to advance my knowledge of the evaluator" (let ([disjunction (amb/analyze (disjunct expr))] [rest-disjunctions (rest-disjunctions expr)]) (λ (env succeed fail) (disjunction env (λ (value fail2) (if (true? value) (succeed value fail2) (if (null? rest-disjunctions) (succeed #f fail2) ((amb/eval-or (cons 'or rest-disjunctions)) env succeed fail)))) fail)))) (amb/install-procedure `(or ,amb/eval-or)) (amb/infuse '(define (xor a b) (and (or a b) (not (and a b))))) (amb/infuse '(define (require-or p1 p2) (require (xor p1 p2)))) (amb/infuse '(define (solve-liars) (define betty (amb 1 2 3 4 5)) (define ethel (amb 1 2 3 4 5)) (define joan (amb 1 2 3 4 5)) (define kitty (amb 1 2 3 4 5)) (define mary (amb 1 2 3 4 5)) (require (distinct? (list betty ethel joan kitty mary))) ;; betty (require-or (= kitty 2) (= betty 3)) ;; ethel (require-or (= ethel 1) (= joan 2)) ;; joan (require-or (= joan 3) (= ethel 5)) ;; kitty (require-or (= kitty 2) (= mary 4)) ;; mary (require-or (= mary 4) (= 1 betty)) (list (list 'betty betty) (list 'ethel ethel) (list 'joan joan) (list 'kitty kitty) (list 'mary mary))))
Use the `amb’ evaluator to solve the following puzzle
Mary Ann Moore’s father has a yacht and so has each of his four friends: Colonel Downing, Mr. Hall, Sir Barnacle Hood, and Dr. Parker. Each of the five also has one daughter and each has named his yacht after a daughter of one of the others. Sir Barnacle’s yacht is the Gabrielle, Mr. Moore owns the Lorna; Mr. Hall the Rosalind. The Melissa, owned by Colonel Downing, is named after Sir Barnacle’s daughter. Gabrielle’s father owns the yacht that is named after Dr. Parker’s daughter. Who is Lorna’s father?
Try to write the program so that it runs efficiently. Also determine how many solutions there are if we are not told that Mary Ann’s last name is Moore.
#| ╔═════════════╦════════════╗ ║ Individual ║ Yacht ║ ╠═════════════╬════════════╣ ║ Downing ║ Melissa ║ ╠═════════════╬════════════╣ ║ Hall ║ Rosalind ║ ╠═════════════╬════════════╣ ║ Moore ║ Lorna ║ ╠═════════════╬════════════╣ ║ Hood ║ Gabrielle ║ ╚═════════════╩════════════╝ Gabrielle's father owns the yacht that is named after Dr. Parker's daughter ╔════════════════════════╦═══════════════════════════╗ ║ Parker's Daughter ║ Gabrielle's Father's Ship ║ ╚════════════════════════╩═══════════════════════════╝ The Melissa, owned by Colonel Downing, is named after Sir Barnacle's daughter. ╔═════════════╦═══════════════════════════╗ ║ Barnacle ║ (Daughter: Melissa) ║ ╚═════════════╩═══════════════════════════╝ |# (append! primitive-procedures `((eq? ,eq?))) (append! primitive-procedures `((cadr ,cadr))) (append! primitive-procedures `((caddr ,caddr))) (amb/infuse '(define (sailors) (define father car) (define daughter cadr) (define yacht caddr) (define (different-names father) (not (eq? (daughter father) (yacht father)))) (let ((moore (list 'moore 'mary-ann 'lorna)) (hood (list 'hood 'melissa 'gabrielle)) (hall (list 'hall (amb 'gabrielle 'lorna) 'rosalind)) (downing (list 'downing (amb 'gabrielle 'lorna 'rosalind) 'melissa)) (parker (list 'parker (amb 'gabrielle 'lorna 'rosalind) 'mary-anne))) (let ((gabrielle-father (amb hall downing parker)) (lorna-father (amb hall downing parker))) (require (eq? (daughter gabrielle-father) 'gabrielle)) (require (eq? (daughter lorna-father) 'lorna)) (require (different-names lorna-father)) (require (different-names gabrielle-father)) (require (eq? (daughter parker) (yacht gabrielle-father))) lorna-father))))
TODO: Exercise 4.44
Exercise 2.42 described the “eight-queens puzzle” of placing queens on a chessboard so that no two attack each other. Write a nondeterministic program to solve this puzzle.
Programs designed to accept natural language as input usually start by attempting to “parse” the input, that is, to match the input against some grammatical structure. For example, we might try to recognize simple sentences consisting of an article followed by a noun followed by a verb, such as “The cat eats.” To accomplish such an analysis, we must be able to identify the parts of speech of individual words. We could start with some lists that classify various words: (append! primitive-procedures `((set! ,(λ (x y) (set! x y))))) (append! primitive-procedures `((memq ,memq))) (map amb/infuse ’((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 unparsed ’()) (define (parse-sentence) (list ’sentence (parse-noun-phrase) (parse-verb-phrase))) (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 input) (set! unparsed input) (let ((sent (parse-sentence))) (require (null? unparsed)) sent)) (define (parse-prepositional-phrase) (list ’prep-phrase (parse-word prepositions) (parse-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 (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))))) With the grammar given above, the following sentence can be parsed in five different ways: “the professor lectures to the student in the class with the cat.” Give the five parses and explain the differences in shades of meaning among them.
#| (parse '(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-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))))) (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))))))) (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))))) (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))))))) (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 evaluators in sections *Note and do not determine what order operands are evaluated in. We will see that the `amb’ evaluator evaluates them from left to right. Explain why our parsing program wouldn’t work if the operands were evaluated in some other order.
#| parse-word advances the *unparsed* list from left to right, because it knows that the parser works this way. Without being sure of the order, we couldn’t implement parse-word. |#
Alyssa P. Hacker is more interested in generating interesting sentences than in parsing them. She reasons that by simply changing the procedure `parse-word’ so that it ignores the “input sentence” and instead always succeeds and generates an appropriate word, we can use the programs we had built for parsing to do generation instead. Implement Alyssa’s idea, and show the first half-dozen or so sentences generated.
(map amb/infuse '( (define (generate) (generate-sentence)) (define (generate-sentence) (list 'sentence (generate-noun-phrase) (generate-verb-phrase))) (define (generate-word word-list) (list (car word-list) (amb word-list))) (define (generate-prepositional-phrase) (list 'prep-phrase (generate-word prepositions) (generate-noun-phrase))) (define (generate-verb-phrase) (define (maybe-extend verb-phrase) (amb verb-phrase (maybe-extend (list 'verb-phrase verb-phrase (generate-prepositional-phrase))))) (maybe-extend (generate-word verbs))) (define (generate-simple-noun-phrase) (list 'simple-noun-phrase (generate-word articles) (generate-word nouns))) (define (generate-noun-phrase) (define (maybe-extend noun-phrase) (amb noun-phrase (maybe-extend (list 'noun-phrase noun-phrase (generate-prepositional-phrase))))) (maybe-extend (generate-simple-noun-phrase)))))
Implement a new special form ramb that is like amb except that it searches alternatives in a random order, rather than from left to right. Show how this can help with Alyssa’s problem in Exercise 4.49.
(define (shuffle lst) "Returns a randomly re-ordered copy of `lst'" (if (< (length lst) 1) lst (let ([item (list-ref lst (random (length lst)))]) (cons item (shuffle (delete item lst)))))) (define (amb/analyze-ramb exp) (amb/analyze-amb (cons (car exp) (shuffle (amb/choices exp)))))
Implement a new kind of assignment called permanent-set! that is not undone upon failure. For example, we can choose two distinct elements from a list and count the number of trials required to make a successful choice as follows:
(define count 0) (let ((x (an-element-of ’(a b c))) (y (an-element-of ’(a b c)))) (permanent-set! count (+ count 1)) (require (not (eq? x y))) (list x y count))
;;; Starting a new problem ;;; Amb-Eval value: (a b 2)
;;; Amb-Eval input: try-again
;;; Amb-Eval value: (a c 3)
What values would have been displayed if we had used set! here rather than permanent-set!?
(append! primitive-procedures `((shuffle ,shuffle))) (define (amb/analyze-permanent-assignment exp) "The execution procedure for permanent assignment is essentially a redaction of the components of `analyze-assignment' that restore the value of the old variable proceeding from a failed assignment" (let ([var (definition-variable exp)] (vproc (amb/analyze (definition-value exp)))) (lambda (env succeed fail) (vproc env (λ (val fail2) (set-variable-value! var val env) (succeed 'ok ;; a failure continues without restoring the old value (λ () (fail2)))) fail)))) (amb/install-procedure `(permanent-set! ,amb/analyze-permanent-assignment)) (amb/infuse '(define (cps) (define count 0) (let ((x (car (amb '(a b c)))) (y (car (amb '(z b c))))) (permanent-set! count (+ count 1)) (require (not (eq? x y))) (list x y count))))
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:
;;; Amb-Eval input: (if-fail (let ((x (an-element-of ’(1 3 5)))) (require (even? x)) x) ’all-odd)
;;; Starting a new problem ;;; Amb-Eval value: all-odd
;;; Amb-Eval input: (if-fail (let ((x (an-element-of ’(1 3 5 8)))) (require (even? x)) x) ’all-odd)
;;; Starting a new problem ;;; Amb-Eval value: 8
(define (amb/analyze-if-fail exp) (let ((clause (amb/analyze (cadr exp))) (alternative (caddr exp))) (λ (env succeed fail) (clause env ;; success, just suplly the result (λ (value fail2) (succeed value fail2)) ;; fail, send our alternative (λ () (succeed alternative fail)))))) (amb/install-procedure `(if-fail ,amb/analyze-if-fail))
With `permanent-set!’ as described in *Note4.51 and `if-fail’ as in *Note Exercise 4.52, what will be the result of evaluating
(let ((pairs ’())) (if-fail (let ((p (prime-sum-pair ’(1 3 5 8) ’(20 35 110)))) (permanent-set! pairs (cons p pairs)) (amb)) pairs))
#| Solution: It prints: ((8 35) (3 110) (3 20)) Although the let form always fails (it calls (amb) as its last statement), the pairs get added into pairs, because permanent-set! doesn’t roll assignments back from failed paths. |#
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
(define (require? exp) (tagged-list? exp ’require))
(define (require-predicate exp) (cadr exp))
and a new clause in the dispatch in analyze
((require? exp) (analyze-require exp))
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 ⟨??⟩ ⟨??⟩ (succeed ’ok fail2))) fail))))
(define (require-predicate exp) (cadr exp)) (define (amb/analyze-require exp) (let ([pproc (analyze (require-predicate exp))]) (λ (env succeed fail) (pproc env (λ (value fail2) (if (not (true? value)) (fail) (succeed 'ok fail2)))) fail)))
Give simple queries that retrieve the following information from the data base:
- all people supervised by Ben Bitdiddle;
- the names and jobs of all people in the accounting division;
- the names and addresses of all people who live in Slumerville.
#| Solution: Respectively: - (supervisor ?x (Bitdiddle Ben)) - (job ?name (accounting . ?other)) - (address ?name (Slumerville . ?rest)) |#
Formulate compound queries that retrieve the following information:
a. the names of all people who are supervised by Ben Bitdiddle, together with their addresses;
b. all people whose salary is less than Ben Bitdiddle’s, together with their salary and Ben Bitdiddle’s salary;
c. all people who are supervised by someone who is not in the computer division, together with the supervisor’s name and job.
#| Solutions: a. (and (supervisor ?name (Bitdiddle Ben)) (address ?name . ?rest)) b. (and (salary ?person ?salary) (salary (Bitdiddle Ben) ?ben-salary) (lisp-value > ?salary ?ben-salary)) c. (and (supervisor ?supervisor ?supervisee) (job ?supervisor ?job)) |#
Define a rule that says that person 1 can replace person 2 if either person 1 does the same job as person 2 or someone who does person 1’s job can also do person 2’s job, and if person 1 and person 2 are not the same person. Using your rule, give queries that find the following:
- all people who can replace Cy D. Fect;
- all people who can replace someone who is being paid more than they are, together with the two salaries.
(query/infuse '(rule (replaceable ?p1 ?p2) (and (or (and (job ?p1 ?p1post) (job ?p2 ?p1post)) (and (job ?p1 ?p1post) (job ?p2 ?p2post) (can-do-job ?p1post ?p2post))) (not (same ?p1 ?p2))))) #| Solution: - all people who can replace Cy D. Fect => (replaceable ?t (Fect Cy D)) - all people who can replace someone who is being paid more than they are, together with the two salaries. => (and (replaceable ?p1 ?p2) (salary ?p1 ?s1) (salary ?p2 ?s2) (lisp-value > ?s2 ?s1)) |#
Define a rule that says that a person is a “big shot” in a division if the person works in the division but does not have a supervisor who works in the division.
(query/infuse '(rule (big-shot ?p1) (and (job ?p1 (?dept . ?job)) (or (not (supervisor ?p1 ?p2)) (and (supervisor ?p1 ?p2) (not (job ?p2 (?dept . ?job2))))))))
Ben Bitdiddle has missed one meeting too many. Fearing that his habit of forgetting meetings could cost him his job, Ben decides to do something about it. He adds all the weekly meetings of the firm to the Microshaft data base by asserting the following:
(map query/infuse '((meeting accounting (Monday 9am)) (meeting administration (Monday 10am)) (meeting computer (Wednesday 3pm)) (meeting administration (Friday 1pm)))) #| Each of the above assertions is for a meeting of an entire division. Ben also adds an entry for the company-wide meeting that spans all the divisions. All of the company's employees attend this meeting. |# (query/infuse '(meeting whole-company (Wednesday 4pm))) #| a. On Friday morning, Ben wants to query the data base for all the meetings that occur that day. What query should he use? b. Alyssa P. Hacker is unimpressed. She thinks it would be much more useful to be able to ask for her meetings by specifying her name. So she designs a rule that says that a person's meetings include all `whole-company' meetings plus all meetings of that person's division. Fill in the body of Alyssa's rule. (rule (meeting-time ?person ?day-and-time) <RULE-BODY>) c. Alyssa arrives at work on Wednesday morning and wonders what meetings she has to attend that day. Having defined the above rule, what query should she make to find this out? |# ;; Solutions: ;; a. (meeting ?meeting (Friday ?time)) ;; b. (query/infuse '(rule (meeting-time ?person ?day-and-time) (or (meeting whole-company ?day-and-time) (and (meeting ?division ?day-and-time) (job ?person (?division . ?job)))))) ;; c. (meeting-time (Hacker Alyssa P) (Wednesday . ?x))
By giving the query
(lives-near ?person (Hacker Alyssa P))
Alyssa P. Hacker is able to find people who live near her, with whom she can ride to work. On the other hand, when she tries to find all pairs of people who live near each other by querying
(lives-near ?person-1 ?person-2)
she notices that each pair of people who live near each other is listed twice; for example,
(lives-near (Hacker Alyssa P) (Fect Cy D)) (lives-near (Fect Cy D) (Hacker Alyssa P))
Why does this happen? Is there a way to find a list of people who live near each other, in which each pair appears only once? Explain.
#| Solution: The reason this occurs it that there is no 'ordering' on the results returned, e.g (Dewitt) (Louis) is equally valid to (Louis) (Dewitt) when the query analyzer searches through valid responses. |# (query/infuse '(rule (lives-near-only ?person-1 ?person-2) (and (address ?person-1 (?town . ?rest-1)) (address ?person-2 (?town . ?rest-2)) (not (same ?person-1 ?person-2)) (lisp-value (lambda (x y) (string<=? (symbol->string (car x)) (symbol->string (car y)))) ?person-1 ?person-2))))
The following rules implement a `next-to’ relation that finds adjacent elements of a list:
(rule (?x next-to ?y in (?x ?y . ?u)))
(rule (?x next-to ?y in (?v . ?z)) (?x next-to ?y in ?z))
What will the response be to the following queries?
(?x next-to ?y in (1 (2 3) 4))
(?x next-to 1 in (2 1 3 1))
;; Solution: ;; The rules written as-is are incompatible with the existing system, a s, I've resolved them in the following way: (query/infuse '(rule (next-to ?x ?y in (?x ?y . ?u)))) (query/infuse '(rule (next-to ?x ?y in (?v . ?z)) (next-to ?x ?y in ?z))) ;; (next-to ?x ?y in (1 (2 3) 4)) => ((1 (2 3) 4) ((2 3) 4)) ;; (next-to ?x 1 in (2 1 3 1)) => ((3 1) (2 1))
Define rules to implement the `last-pair’ operation of *Note Exercise 2-17, which returns a list containing the last element of a nonempty list. Check your rules on queries such as `(last-pair (3) ?x)’, `(last-pair (1 2 3) ?x)’, and `(last-pair (2 ?x) (3))’. Do your rules work correctly on queries such as `(last-pair ?x (3))’ ?
;; Solution, it does not work correctly on results that yield an infinite ;; nubmer of answers; (map query/infuse '((rule (last-pair (?h) (?h))) (rule (last-pair (?h . ?t) ?last) (last-pair ?t ?last))))
The following data base (see Genesis 4) traces the genealogy of the descendants of Ada back to Adam, by way of Cain:
(map query/infuse '((son Adam Cain) (son Cain Enoch) (son Enoch Irad) (son Irad Mehujael) (son Mehujael Methushael) (son Methushael Lamech) (wife Lamech Ada) (son Ada Jabal) (son Ada Jubal))) #| Formulate rules such as "If S is the son of f, and f is the son of G, then S is the grandson of G" and "If W is the wife of M, and S is the son of W, then S is the son of M" (which was supposedly more true in biblical times than today) that will enable the query system to find the grandson of Cain; the sons of Lamech; the grandsons of Methushael. (See *Note Exercise 4-69 for some rules to deduce more complicated relationships.) |# (query/infuse '(rule (grandparent ?g ?f ?s) (and (son ?g ?f) (son ?f ?s)))) (query/infuse '(rule (son-of ?w ?m ?s) (and (wife ?m ?w) (son ?w ?s))))
Louis Reasoner mistakenly deletes the `outranked-by’ rule (section *Note 4.4.1) from the data base. When he realizes this, he quickly reinstalls it. Unfortunately, he makes a slight change in the rule, and types it in as
#+beginquestion (query/infuse ’(rule (loop-outranked-by ?staff-person ?boss) (or (supervisor ?staff-person ?boss) (and (outranked-by ?middle-manager ?boss) (supervisor ?staff-person ?middle-manager)))))
Just after Louis types this information into the system, DeWitt Aull comes by to find out who outranks Ben Bitdiddle. He issues the query
(outranked-by (Bitdiddle Ben) ?who)
After answering, the system goes into an infinite loop. Explain why.
The problem with this query is the order in which applicable rules are specified.
After finding the previous `supervisor' rule applied; that is, the rule conclusion `(supervisor (Bitdiddle Ben) ?boss)' successfully unifies with the query pattern `(supervisor ?staff-person ?boss)' to produce a frame in which `?boss' is bound to `?who'. The interpreter proceeds to evaluate the next rule: `(outranked-by ?middle-manager ?boss)' in the same frame. One answer appears in the database. The `outranked-by' rule is also applicable, so the evaluator again evaluators the `outranked-by' rule body which is equivalent to `(outranked-by ?middle-manager ?who)' |# #+endsrc
Cy D. Fect, looking forward to the day when he will rise in the organization, gives a query to find all the wheels (using the `wheel’ rule of section *Note 4-4-1)
To his surprise, the system responds
;;; Query results: (wheel (Warbucks Oliver)) (wheel (Bitdiddle Ben)) (wheel (Warbucks Oliver)) (wheel (Warbucks Oliver)) (wheel (Warbucks Oliver))
Why is Oliver Warbucks listed four times?
#| Solution: The body of `wheel' contains a query pattern `(supervisor ?x ?middle-manager)' that can be satisfied by a variety of different values, each of those values contributes a match to the rule |#
Ben has been generalizing the query system to provide statistics about the company. For example, to find the total salaries of all the computer programmers one will be able to say
(sum ?amount (and (job ?x (computer programmer)) (salary ?x ?amount)))
In general, Ben’s new system allows expressions of the form
(accumulation-function <VARIABLE> <QUERY PATTERN>)
where `accumulation-function’ can be things like `sum’, `average’, or `maximum’. Ben reasons that it should be a cinch to implement this. He will simply feed the query pattern to `qeval’. This will produce a stream of frames. He will then pass this stream through a mapping function that extracts the value of the designated variable from each frame in the stream and feed the resulting stream of values to the accumulation function. Just as Ben completes the implementation and is about to try it out, Cy walks by, still puzzling over the `wheel’ query result in exercise *Note Exercise 4-65. When Cy shows Ben the system’s response, Ben groans, “Oh, no, my simple accumulation scheme won’t work!”
What has Ben just realized? Outline a method he can use to salvage the situation.
#| Solution Although the query supplied doesn't demonstrate it, it is possible to have multiple frames returns. |#
Devise a way to install a loop detector in the query system so as to avoid the kinds of simple loops illustrated in the text and in *NoteExercise 4.64.
The general idea is that the system should maintain some sort of history of its current chain of deductions and should not begin processing a query that it is already working on. Describe what kind of information (patterns and frames) is included in this history, and how the check should be made. (After you study the details of the query-system implementation in section *Note 4.4.4, you may want to modify the system to include your loop detector.)
;; Because the rule variable contains the execution information, we can ;; lookup if a rule with the exact same parameters has been called before. (define executed-rules '()) (define (previously-executed? rule) (member rule executed-rules)) (define (add-executed-rule! rule) (set! executed-rules (cons rule executed-rules))) (define (noloop/apply-a-rule rule query-pattern query-frame) (if (previously-executed? rule) stream-null (let* ([clean-rule (rename-variables-in rule)] ; alpha-conversion [unify-result (unify-match query-pattern (conclusion clean-rule) query-frame)]) (if (eq? unify-result 'failed) stream-null (begin (add-executed-rule! rule) (qeval (rule-body clean-rule) (singleton-stream unify-result))))))) ;; The following are just driver extensions to permit for `noloop' to work (define (noloop/query-driver-loop) (set! executed-rules '()) (set! apply-a-rule noloop/apply-a-rule) (query-driver-loop)) (define (noloop/query/eval expr) (set! executed-rules '()) (set! apply-a-rule noloop/apply-a-rule) (let ((q (query-syntax-process expr))) (stream->list (stream-map (λ (frame) (instantiate q frame (λ (v f) (contract-question-mark v)))) (qeval q (singleton-stream '())))))) (install-driver-loop 'qeval-noloop noloop/query-driver-loop)
Define rules to implement the `reverse’ operation of *Note Exercise 2-18, which returns a list containing the same elements as a given list in reverse order. (Hint: Use `append-to-form’.) Can your rules answer both `(reverse (1 2 3) ?x)’ and `(reverse ?x (1 2 3))’ ?
;; This is one solution that doesn't use append-to-form, but doesn't ;; generate proper lists (map query/infuse '((rule (bad-reverse () ())) (rule (bad-reverse (?car . ?cdr) (?cdr1 . ?car)) (bad-reverse ?cdr ?cdr1)))) (map query/infuse '((rule (reverse () ())) (rule (reverse ?x ?y) (and (append-to-form (?car) ?rest ?x) (append-to-form ?rev (?car) ?y) (reverse ?rest ?rev)))))
Beginning with the data base and the rules you formulated in Exercise 4.63, devise a rule for adding “greats” to a grandson relationship. This should enable the system to deduce that Irad is the great-grandson of Adam, or that Jabal and Jubal are the great-great-great-great-great-grandsons of Adam. (Hint: Represent the fact about Irad, for example, as ((great grandson) Adam Irad). Write rules that determine if a list ends in the word grandson. Use this to express a rule that allows one to derive the relationship ((great . ?rel) ?x ?y), where ?rel is a list ending in grandson.) Check your rules on queries such as ((great grandson) ?g ?ggs) and (?relationship Adam Irad).
#| I cannot find a solution to this |#
What is the purpose of the `let’ bindings in the procedures `add-assertion!’ and `add-rule!’ ? What would be wrong with the following implementation of `add-assertion!’ ? Hint: Recall the definition of the infinite stream of ones in section *Note 3.5.2: `(define ones (cons-stream 1 ones))’.
(define (add-assertion! assertion) (store-assertion-in-index assertion) (set! THE-ASSERTIONS (cons-stream assertion THE-ASSERTIONS)) ’ok)
#| Solution is non-indexable |#
Louis Reasoner wonders why the simple-query and disjoin procedures (184.108.40.206) are implemented using explicit delay operations, rather than being defined as follows:
(define (simple-query query-pattern frame-stream) (stream-flatmap (lambda (frame) (stream-append (find-assertions query-pattern frame) (apply-rules query-pattern frame))) frame-stream))
(define (disjoin disjuncts frame-stream) (if (empty-disjunction? disjuncts) the-empty-stream (interleave (qeval (first-disjunct disjuncts) frame-stream) (disjoin (rest-disjuncts disjuncts) frame-stream))))
Can you give examples of queries where these simpler definitions would lead to undesirable behavior?
Why do disjoin and stream-flatmap interleave the streams rather than simply append them? Give examples that illustrate why interleaving works better. (Hint: Why did we use interleave in 3.5.3?)
#| Solution: `interleave' provides a way to achieve 'diagonalization', that is to say so that every element in an infinite list can be reached, rather than focusing on either an input stream or a database |#
Why does flatten-stream use delay explicitly? What would be wrong with defining it as follows:
(define (flatten-stream stream) (if (stream-null? stream) the-empty-stream (interleave (stream-car stream) (flatten-stream (stream-cdr stream)))))
#| Solution: Because it would loop forever - the evaluation strategy of a scheme interpreter dictates that arguments are passed in their 'fully evaluated' form. |#
TODO Exercise 4.74
Alyssa P. Hacker proposes to use a simpler version of stream-flatmap in negate, lisp-value, and find-assertions. She observes that the procedure that is mapped over the frame stream in these cases always produces either
TODO Exercise 4.75
Implement for the query language a new special form called `unique’. `Unique’ should succeed if there is precisely one item in the data base satisfying a specified query. For example,
(unique (job ?x (computer wizard)))
should print the one-item stream
(unique (job (Bitdiddle Ben) (computer wizard)))
since Ben is the only computer wizard, and
(unique (job ?x (computer programmer)))
should print the empty stream, since there is more than one computer programmer. Moreover,
(and (job ?x ?j) (unique (job ?anyone ?j)))
should list all the jobs that are filled by only one person, and the people who fill them.
There are two parts to implementing `unique’. The first is to write a procedure that handles this special form, and the second is to make `qeval’ dispatch to that procedure. The second part is trivial, since `qeval’ does its dispatching in a data-directed way. If your procedure is called `uniquely-asserted’, all you need to do is
(put ’unique ’qeval uniquely-asserted)
and `qeval’ will dispatch to this procedure for every query whose `type’ (`car’) is the symbol `unique’.
The real problem is to write the procedure `uniquely-asserted’. This should take as input the `contents’ (`cdr’) of the `unique’ query, together with a stream of frames. For each frame in the stream, it should use `qeval’ to find the stream of all extensions to the frame that satisfy the given query. Any stream that does not have exactly one item in it should be eliminated. The remaining streams should be passed back to be accumulated into one big stream that is the result of the `unique’ query. This is similar to the implementation of the `not’ special form.
Test your implementation by forming a query that lists all people who supervise precisely one person.
TODO Exercise 4.76
Our implementation of `and’ as a series combination of queries is elegant, but it is inefficient because in processing the second query of the `and’ we must scan the data base for each frame produced by the first query. If the data base has n elements, and a typical query produces a number of output frames proportional to n (say n/k), then scanning the data base for each frame produced by the first query will require n2/k calls to the pattern matcher. Another approach would be to process the two clauses of the `and’ separately, then look for all pairs of output frames that are compatible. If each query produces n/k output frames, then this means that we must perform n2/k2 compatibility checks–a factor of k fewer than the number of matches required in our current method.
Devise an implementation of `and’ that uses this strategy. You must implement a procedure that takes two frames as inputs, checks whether the bindings in the frames are compatible, and, if so, produces a frame that merges the two sets of bindings. This operation is similar to unification.
TODO Exercise 4.77
In section *Note 4-4-3:: we saw that `not’ and `lisp-value’ can cause the query language to give “wrong” answers if these filtering operations are applied to frames in which variables are unbound. Devise a way to fix this shortcoming. One idea is to perform the filtering in a “delayed” manner by appending to the frame a “promise” to filter that is fulfilled only when enough variables have been bound to make the operation possible. We could wait to perform filtering until all other operations have been performed. However, for efficiency’s sake, we would like to perform filtering as soon as possible so as to cut down on the number of intermediate frames generated.
TODO Exercise 4.78
Redesign the query language as a nondeterministic program to be implemented using the evaluator of section *Note 4-3::, rather than as a stream process. In this approach, each query will produce a single answer (rather than the stream of all answers) and the user can type `try-again’ to see more answers. You should find that much of the mechanism we built in this section is subsumed by nondeterministic search and backtracking. You will probably also find, however, that your new query language has subtle differences in behavior from the one implemented here. Can you find examples that illustrate this difference?
TODO Exercise 4.79
When we implemented the Lisp evaluator in section *Note 4-1, we saw how to use local environments to avoid name conflicts between the parameters of procedures. For example, in evaluating
(define (square x) (* x x))
(define (sum-of-squares x y) (+ (square x) (square y)))
(sum-of-squares 3 4)
there is no confusion between the `x’ in `square’ and the `x’ in `sum-of-squares’, because we evaluate the body of each procedure in an environment that is specially constructed to contain bindings for the local variables. In the query system, we used a different strategy to avoid name conflicts in applying rules. Each time we apply a rule we rename the variables with new names that are guaranteed to be unique. The analogous strategy for the Lisp evaluator would be to do away with local environments and simply rename the variables in the body of a procedure each time we apply the procedure.
Implement for the query language a rule-application method that uses environments rather than renaming. See if you can build on your environment structure to create constructs in the query language for dealing with large systems, such as the rule analog of block-structured procedures. Can you relate any of this to the problem of making deductions in a context (e.g., “If I supposed that P were true, then I would be able to deduce A and B.”) as a method of problem solving? (This problem is open-ended. A good answer is probably worth a Ph.D.)