Reading Notes #2: Passing functions as arguments to higher order functions

Does Erlang allow you to pass functions (not "funs" or anonymous functions) as arguments to higher order functions? I was under the impression that it doesn't. To find out I tweeted a question about the same. After looking at the answers I decided to rephrase the question with the help of a concrete example. Here it goes:

Step 1: Define a function add_one in a module named test.

view plainprint?

1. % test.erl  
2. -module(test).  
3. -export([add_one/1]).  
4.   
5. add_one(X) -> X + 1.  

% test.erl -module(test). -export([add_one/1]). add_one(X) -> X + 1.
Step 2: Start the erlang shell and try to use this function.

view plainprint?

1. 1> c(test).  
2. {ok,test}  
3. 2> test:add_one(2).  
4. 3  
5. 3> lists:map(test:add_one, [1, 2, 3]).  
6. * 1: illegal expression  
7. 4> lists:map(fun(X) -> test:add_one(X) end, [1, 2, 3]).  
8. [2,3,4]  
9. 5> lists:map(fun(X) -> X + 1 end, [1, 2, 3]).  
10. [2,3,4]  
11. 6>   

1> c(test). {ok,test} 2> test:add_one(2). 3 3> lists:map(test:add_one, [1, 2, 3]). * 1: illegal expression 4> lists:map(fun(X) -> test:add_one(X) end, [1, 2, 3]). [2,3,4] 5> lists:map(fun(X) -> X + 1 end, [1, 2, 3]). [2,3,4] 6>
As you can see I have tried three different combinations. Line #3 shows a call to the higher order function lists:map passing in the qualified name of the add_one function as first argument. The shell throws an error.

In Line #4 I wrap test:add_one inside a fun and it works.

In Line #5 I replicate the code of add_one inside an anonymous fun and everything works fine.

Contrast this with say, Python.

Definition:

view plainprint?

1. def add_one(x): return x + 1  

def add_one(x): return x + 1
Usage:

view plainprint?

1. >>> from test import add_one  
2. >>> map(add_one, [1, 2, 3])  
3. [2, 3, 4]  
4. >>>   

>>> from test import add_one >>> map(add_one, [1, 2, 3]) [2, 3, 4] >>>
Now I'll repeat the question: Does Erlang allow you to pass functions (not "funs" or anonymous functions) as arguments to higher order functions? Or am I missing something?

Please share your thoughts in the comments.

Update #1:
Got an answer. There is a way to do it. It still involves using the fun keyword.

view plainprint?

1. 1> c(test).  
2. {ok,test}  
3. 2> lists:map(fun test:add_one/1, [1, 2, 3]).  
4. [2,3,4]  
5. 3>   

1> c(test). {ok,test} 2> lists:map(fun test:add_one/1, [1, 2, 3]). [2,3,4] 3>
Update #2:
Got another answer which does *not* use fun. The syntax is just a little different. Thanks to Justin Sheehy.

view plainprint?

1. 1> c(test).  
2. {ok,test}  
3. 2> lists:map({test,add_one}, [1, 2, 3]).  
4. [2,3,4]  
5. 3>   

1> c(test). {ok,test} 2> lists:map({test,add_one}, [1, 2, 3]). [2,3,4] 3>

Reading Notes #1

I have been reading Joe Armstrong's paper "Making reliable distributed systems in the presence of software errors" and making notes as I go. In chapter 3 the author gives examples of how Erlang handles higher order functions. One of them is a "generator" function.

view plainprint?

1. 1> Adder = fun(X) -> fun(Y) -> X + Y end end.  
2. #Fun<erl_eval.5.123085357>  
3. 2> Adder10 = Adder(10).  
4. #Fun<erl_eval.5.123085357>  
5. 3> Adder(10).  
6. 15  

1> Adder = fun(X) -> fun(Y) -> X + Y end end. #Fun<erl_eval.5.123085357> 2> Adder10 = Adder(10). #Fun<erl_eval.5.123085357> 3> Adder(10). 15
Line 1 defines an Adder that returns another function with X bound to the input to Adder. In line 2 we create a specific adder - in this case a function that adds 10 to its input. I think line 3 was meant to show how the specific adder created in line 2 could be invoked. If Adder10 were to be called with 5 as argument it would return 15. Instead Adder is invoked again and the result shown is not correct as Adder(10) would return a generator, not 15. I think the snippet can be modified thus:

view plainprint?

1. 1> Adder = fun(X) -> fun(Y) -> X + Y end end.  
2. #Fun<erl_eval.6.49591080>  
3. 2> Adder10 = Adder(10).  
4. #Fun<erl_eval.6.49591080>  
5. 3> Adder10(5).  
6. 15  

1> Adder = fun(X) -> fun(Y) -> X + Y end end. #Fun<erl_eval.6.49591080> 2> Adder10 = Adder(10). #Fun<erl_eval.6.49591080> 3> Adder10(5). 15

Ticket #11627

Logged another Django ticket related to test client. I find that most of my Django pet peeves are related to two areas: the ORM and testing framework.

DRY Logging in Django

I have found custom logging a very useful tool for dealing with production issues. Especially when the users are not easily reachable. I recently configured custom logging messages for a Django project I have been working on. As logging is usually only initiated once per application I chose to do it in my settings.py. The code looked something like this:

view plainprint?

1. import logging     
2. import logging.handlers  
3. logger = logging.getLogger('project_logger')  
4. logger.setLevel(logging.INFO)  
5.   
6. LOG_FILENAME = '/path/to/log/file/in/development'  
7. handler = logging.handlers.TimedRotatingFileHandler(LOG_FILENAME, when = 'midnight')  
8. formatter = logging.Formatter(LOG_MSG_FORMAT)  
9. handler.setFormatter(formatter)  
10. logger.addHandler(handler)  

import logging import logging.handlers logger = logging.getLogger('project_logger') logger.setLevel(logging.INFO) LOG_FILENAME = '/path/to/log/file/in/development' handler = logging.handlers.TimedRotatingFileHandler(LOG_FILENAME, when = 'midnight') formatter = logging.Formatter(LOG_MSG_FORMAT) handler.setFormatter(formatter) logger.addHandler(handler)
This configuration worked out well in development. However I maintain a separate settings file for production, production.py. Production.py merely imports everything from settings.py and selectively overrides some of the attributes (set DEBUG = False, for instance).

My problem was that I wanted the production logs to be written to a different location and perhaps even use a different handler. I could not think of a good way to do this without calling the logging code fragment again in production.py. I wrote a utility function to do this (configure_logging(filename)). This reduced code repetition but revealed another problem. When production.py imports everything from settings.py it triggers logging to be configured once using the LOG_FILENAME attribute used in development and then *again* using the LOG_FILENAME attribute used in production.

This was ugly. For one there is no need to configure logging twice; for another the initial configuration throws an error if the path described by LOG_FILENAME in development is not present in the production machine.

I wasn't sure how to proceed and I posed this question at Stack Overflow. I got an answer suggesting to switch LOG_FILENAME based on the DEBUG attribute. Something like this:

view plainprint?

1. # Inside settings.py  
2.   
3. if DEBUG:  
4.     LOG_FILENAME = '/path/to/log/file/in/development'  
5. else:  
6.     LOG_FILENAME = '/path/to/log/file/in/production'  
7.   
8. # Configure logging here.  

# Inside settings.py if DEBUG: LOG_FILENAME = '/path/to/log/file/in/development' else: LOG_FILENAME = '/path/to/log/file/in/production' # Configure logging here.
This looked good, but almost immediately revealed a problem. DEBUG is overridden *inside* production.py whereas this code snippet is inside settings.py. Consequently when the above given snippet gets executed DEBUG is still True and LOG_FILENAME will be pointed at the development environment.

I eventually found a solution from an answer to a different question. User Bluebird75 suggested using the 'module singleton' pattern to ensure that logging is only configured once. I extended his(?) suggestion to come up with the following solution:

view plainprint?

1. # Inside settings.py  
2. LOG_FILENAME = '/path/to/log/file/in/development'  
3.   
4. # Inside production.py  
5. from settings import *  
6. LOG_FILENAME = '/path/to/log/file/in/production'  
7.   
8. # Singleton module log.py   
9. import logging, logging.handlers  
10. from django.conf import settings  
11.   
12. LOGGING_INITIATED = False  
13.   
14. def init_logging():  
15.     logger = logging.getLogger('project_logger')  
16.     logger.setLevel(logging.INFO)  
17.   
18.     handler = logging.handlers.TimedRotatingFileHandler(settings.LOG_FILENAME, when = 'midnight')  
19.     formatter = logging.Formatter(LOG_MSG_FORMAT)  
20.     handler.setFormatter(formatter)  
21.     logger.addHandler(handler)  
22.   
23. if not LOGGING_INITIATED:  
24.     LOGGING_INITIATED = True  
25.     init_logging()  

# Inside settings.py LOG_FILENAME = '/path/to/log/file/in/development' # Inside production.py from settings import * LOG_FILENAME = '/path/to/log/file/in/production' # Singleton module log.py import logging, logging.handlers from django.conf import settings LOGGING_INITIATED = False def init_logging(): logger = logging.getLogger('project_logger') logger.setLevel(logging.INFO) handler = logging.handlers.TimedRotatingFileHandler(settings.LOG_FILENAME, when = 'midnight') formatter = logging.Formatter(LOG_MSG_FORMAT) handler.setFormatter(formatter) logger.addHandler(handler) if not LOGGING_INITIATED: LOGGING_INITIATED = True init_logging()
The singleton module ensures that logging is only configured once. As this module resides within the app directory Django would already have loaded settings before this module is loaded, thereby ensuring the presence of settings.LOG_FILENAME. I can add as many settings files as I want and all I have to do is override the LOG_FILENAME attribute in each file.

Ticket #11475

Logged a Django bug related to test client. Part of my continuing series of adventures in Django.

Learning to write smaller sentences

I have started to use Twitter. There are many things I'd like to write about that do not merit a blog post. Twitter is the right place to scribble in such cases. I hope to be a more regular writer using the new medium :)

Quick and dirty serial numbers across pages in Django templates

Update:

Scratch that. I just learned that this can be done in a much simpler way:

1. {% for object in object_list %}  
2.     {{ page_obj.start_index|add:forloop.counter0 }}  
3. {% endfor %}  

{% for object in object_list %} {{ page_obj.start_index|add:forloop.counter0 }} {% endfor %}
I recently had to write a template for a paginated view which displayed a serial number for each object in the object_list. I normally use forloop.counter for general purpose serial numbers. However this did not work with paginated views as the counter gets reset in each page. This caused the serial numbers to go from 1 to #-of-results-in-the-page and then repeat. I wrote a filter to tackle this problem.

The code (add to your filters file under ./templatetags/):

view plainprint?

1. from django import template  
2. from django.conf import settings  
3.   
4. register = template.Library()  
5.   
6. @register.filter  
7. def adjust_for_pagination(value, page):  
8.     value, page = int(value), int(page)  
9.     adjusted_value = value + ((page - 1) * settings.RESULTS_PER_PAGE)  
10.     return adjusted_value  

from django import template from django.conf import settings register = template.Library() @register.filter def adjust_for_pagination(value, page): value, page = int(value), int(page) adjusted_value = value + ((page - 1) * settings.RESULTS_PER_PAGE) return adjusted_value
And the template snippet:

view plainprint?

1. {% for object in object_list %}  
2. <div class="serial-no">  
3.     {% if is_paginated %}  
4.         {{ forloop.counter|adjust_for_pagination:page }}  
5.     {% else %}  
6.        {{ forloop.counter }}  
7.     {% endif %}  
8. </div>  
9. ...  
10. {% endfor %}  

{% for object in object_list %} <div class="serial-no"> {% if is_paginated %} {{ forloop.counter|adjust_for_pagination:page }} {% else %} {{ forloop.counter }} {% endif %} </div> ... {% endfor %}
The adjust_for_pagination filter adjusts the value of forloop.counter based on the current page. Page and is_paginated variables are expected to be present in the context. These should respectively denote the current page number (1 based) and if the results are paginated. RESULTS_PER_PAGE is currently taken from the settings file. I couldn't think of a way to pass this value also from the template.

SICP Section 5.2 A Register-Machine Simulator

Exercise 5.7. Use the simulator to test the machines you designed in exercise 5.4.

Answer:
1. Recursive Version

view plainprint?

1. (define expt-machine  
2.   (make-machine  
3.    '(n b val continue)  
4.    (list (list '= =) (list '- -) (list '* *))  
5.    '(controller  
6.      (assign continue (label expt-done))  
7.      expt-loop  
8.      (test (op =) (reg n) (const 0)) ;; Test for (= n 0)  
9.      (branch (label base-case))  
10.      ;; We only need to save continue as b is constant throughout   
11.      ;; and the successive values of n are not used for calculation.  
12.      (save continue)  
13.      (assign n (op -) (reg n) (const 1))  
14.      (assign continue (label after-expt))  
15.      (goto (label expt-loop))  
16.      after-expt  
17.      (restore continue)  
18.      (assign val (op *) (reg b) (reg val))  
19.      (goto (reg continue))  
20.      base-case  
21.      (assign val (const 1))  
22.      (goto (reg continue))  
23.      expt-done)))  
24.   
25. (set-register-contents! expt-machine 'n 2)  
26. done  
27. (set-register-contents! expt-machine 'b 4)  
28. done  
29. (start expt-machine)  
30. done  
31. (get-register-contents expt-machine 'val)  
32. 16  

(define expt-machine (make-machine '(n b val continue) (list (list '= =) (list '- -) (list '* *)) '(controller (assign continue (label expt-done)) expt-loop (test (op =) (reg n) (const 0)) ;; Test for (= n 0) (branch (label base-case)) ;; We only need to save continue as b is constant throughout ;; and the successive values of n are not used for calculation. (save continue) (assign n (op -) (reg n) (const 1)) (assign continue (label after-expt)) (goto (label expt-loop)) after-expt (restore continue) (assign val (op *) (reg b) (reg val)) (goto (reg continue)) base-case (assign val (const 1)) (goto (reg continue)) expt-done))) (set-register-contents! expt-machine 'n 2) done (set-register-contents! expt-machine 'b 4) done (start expt-machine) done (get-register-contents expt-machine 'val) 16
2. Iterative Version

view plainprint?

1. (define expt-machine  
2.   (make-machine  
3.    '(n b counter product)  
4.    (list (list '= =) (list '- -) (list '* *))  
5.    '(controller   
6.      (assign counter (reg n))  
7.      (assign product (const 1))  
8.      expt-loop  
9.      (test (op =) (reg counter) (const 0))  
10.      (branch (label expt-done))  
11.      ;; We don't have to save any value in the stack.  
12.      ;; The result of exponentiation will be available in register product at the end of calculation.  
13.      (assign counter (op -) (reg counter) (const 1))  
14.      (assign product (op *) (reg b) (reg product))  
15.      (goto (label expt-loop))  
16.      expt-done)))  
17.      
18. (set-register-contents! expt-machine 'n 2)  
19. done  
20. (set-register-contents! expt-machine 'b 4)  
21. done  
22. (start expt-machine)  
23. done  
24. (get-register-contents expt-machine 'product)  
25. 16  

(define expt-machine (make-machine '(n b counter product) (list (list '= =) (list '- -) (list '* *)) '(controller (assign counter (reg n)) (assign product (const 1)) expt-loop (test (op =) (reg counter) (const 0)) (branch (label expt-done)) ;; We don't have to save any value in the stack. ;; The result of exponentiation will be available in register product at the end of calculation. (assign counter (op -) (reg counter) (const 1)) (assign product (op *) (reg b) (reg product)) (goto (label expt-loop)) expt-done))) (set-register-contents! expt-machine 'n 2) done (set-register-contents! expt-machine 'b 4) done (start expt-machine) done (get-register-contents expt-machine 'product) 16
Exercise 5.8. The following register-machine code is ambiguous, because the label here is defined more than once:

1. start  
2.   (goto (label here))  
3. here  
4.   (assign a (const 3))  
5.   (goto (label there))  
6. here  
7.   (assign a (const 4))  
8.   (goto (label there))  
9. there  

start (goto (label here)) here (assign a (const 3)) (goto (label there)) here (assign a (const 4)) (goto (label there)) there
With the simulator as written, what will the contents of register a be when control reaches there? Modify the extract-labels procedure so that the assembler will signal an error if the same label name is used to indicate two different locations.

Answer: Using the current implementation goto will direct control to the first occurrence of the label here in the sequence of instructions. This means that (assign a (const 3)) will get executed before control proceeds to the label there. Therefore register a will contain the value 3 at the end of execution.

This version of extract-labels checks if a given label is already present in the labels processed so far. If so it raises an error.

view plainprint?

1. (define (extract-labels text receive)  
2.   (if (null? text)  
3.       (receive '() '())  
4.       (extract-labels (cdr text)  
5.        (lambda (insts labels)  
6.          (let ((next-inst (car text)))  
7.            (if (symbol? next-inst)  
8.                (begin  
9.                  (if (assoc next-inst labels)  
10.                      (error "Multiple declarations of label -- EXTRACT-LABELS" next-inst))  
11.                  (receive insts  
12.                           (cons (make-label-entry next-inst  
13.                                                 insts)  
14.                                 labels)))  
15.                (receive (cons (make-instruction next-inst)  
16.                               insts)  
17.                         labels)))))))  

(define (extract-labels text receive) (if (null? text) (receive '() '()) (extract-labels (cdr text) (lambda (insts labels) (let ((next-inst (car text))) (if (symbol? next-inst) (begin (if (assoc next-inst labels) (error "Multiple declarations of label -- EXTRACT-LABELS" next-inst)) (receive insts (cons (make-label-entry next-inst insts) labels))) (receive (cons (make-instruction next-inst) insts) labels)))))))
Exercise 5.9. The treatment of machine operations above permits them to operate on labels as well as on constants and the contents of registers. Modify the expression-processing procedures to enforce the condition that operations can be used only with registers and constants.

Answer: I have moved the code that generates aprocs for an operation expression to a helper procedure. This procedure will raise and error if any of the operands of the expression is not a register or a constant.

view plainprint?

1. (define (generate-operation-aprocs exp machine labels)  
2.   (map (lambda (e)  
3.          (if (or (register-exp? e) (constant-exp? e))  
4.              (make-primitive-exp e machine labels)  
5.              (error "Operations can only be used with registers and constants -- ASSEMBLE" e)))  
6.        (operation-exp-operands exp)))  
7.   
8. (define (make-operation-exp exp machine labels operations)  
9.   (let ((op (lookup-prim (operation-exp-op exp) operations))  
10.         (aprocs (generate-operation-aprocs exp machine labels)))  
11.     (lambda ()  
12.       (apply op (map (lambda (p) (p)) aprocs)))))  

(define (generate-operation-aprocs exp machine labels) (map (lambda (e) (if (or (register-exp? e) (constant-exp? e)) (make-primitive-exp e machine labels) (error "Operations can only be used with registers and constants -- ASSEMBLE" e))) (operation-exp-operands exp))) (define (make-operation-exp exp machine labels operations) (let ((op (lookup-prim (operation-exp-op exp) operations)) (aprocs (generate-operation-aprocs exp machine labels))) (lambda () (apply op (map (lambda (p) (p)) aprocs)))))
Exercise 5.10. Design a new syntax for register-machine instructions and modify the simulator to use your new syntax. Can you implement your new syntax without changing any part of the simulator except the syntax procedures in this section?

Skipping.

Exercise 5.11. When we introduced save and restore in section 5.1.4, we didn't specify what would happen if you tried to restore a register that was not the last one saved, as in the sequence

1. (save y)  
2. (save x)  
3. (restore y)  

(save y) (save x) (restore y)
There are several reasonable possibilities for the meaning of restore:

a. (restore y) puts into y the last value saved on the stack, regardless of what register that value came from. This is the way our simulator behaves. Show how to take advantage of this behavior to eliminate one instruction from the Fibonacci machine of section 5.1.4 (figure 5.12).

b. (restore y) puts into y the last value saved on the stack, but only if that value was saved from y; otherwise, it signals an error. Modify the simulator to behave this way. You will have to change save to put the register name on the stack along with the value.

c. (restore y) puts into y the last value saved from y regardless of what other registers were saved after y and not restored. Modify the simulator to behave this way. You will have to associate a separate stack with each register. You should make the initialize-stack operation initialize all the register stacks.

Answer:
a. The first two statements under the label afterfib-n-2 perform the following actions:
1) Transfer the value of val to n. This means copying fib(n - 2) to n.
2) Restore previously saved fib(n - 1) to val.
N and val are subsequently added to yield fib(n).

These two statements can be replaced with a single restore statement. Consider executing (restore n) instead of these two statements. As fib(n - 1) was the last value restored on the stack n will be assigned the value fib(n - 1). Val already contains fib(n - 2). We can proceed to add them together and still get fib(n).

b. Save instruction has been changed to pass the register name to the stack along with its value. The stack will maintain a list of register-name/value tuples. Pop has been changed to pass the target register name as a parameter. Stack will raise an error if the target register name is not the same as the name associated with the top value in the stack.

view plainprint?

1. (define (make-save inst machine stack pc)  
2.   (let ((reg (get-register machine  
3.                            (stack-inst-reg-name inst)))  
4.         (reg-name (stack-inst-reg-name inst)))  
5.     (lambda ()  
6.       (push stack reg-name (get-contents reg))  
7.       (advance-pc pc))))  
8.   
9. (define (push stack reg-name value)  
10.   ((stack 'push) reg-name value))  
11.   
12. (define (make-restore inst machine stack pc)  
13.   (let ((reg (get-register machine  
14.                            (stack-inst-reg-name inst)))  
15.         (reg-name (stack-inst-reg-name inst)))  
16.     (lambda ()  
17.       (set-contents! reg (pop stack reg-name))  
18.       (advance-pc pc))))  
19.   
20. (define (pop stack reg-name)  
21.   ((stack 'pop) reg-name))  
22.   
23. (define (make-stack)  
24.   (let ((s '()))  
25.     (define (push reg x)  
26.       (set! s (cons (list reg x) s)))  
27.     (define (pop reg)  
28.       (if (null? s)  
29.           (error "Empty stack -- POP")  
30.           (let ((top (car s)))  
31.             (cond ((eq? (car top) reg)  
32.                    (set! s (cdr s))  
33.                    (cadr top))  
34.                   (else   
35.                    (error "Register mismatch -- POP" reg (car top)))))))  
36.     (define (initialize)  
37.       (set! s '())  
38.       'done)  
39.     (define (dispatch message)  
40.       (cond ((eq? message 'push) push)  
41.             ((eq? message 'pop) pop)  
42.             ((eq? message 'initialize) (initialize))  
43.             (else (error "Unknown request -- STACK"  
44.                          message))))  
45.     dispatch))  

(define (make-save inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst))) (reg-name (stack-inst-reg-name inst))) (lambda () (push stack reg-name (get-contents reg)) (advance-pc pc)))) (define (push stack reg-name value) ((stack 'push) reg-name value)) (define (make-restore inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst))) (reg-name (stack-inst-reg-name inst))) (lambda () (set-contents! reg (pop stack reg-name)) (advance-pc pc)))) (define (pop stack reg-name) ((stack 'pop) reg-name)) (define (make-stack) (let ((s '())) (define (push reg x) (set! s (cons (list reg x) s))) (define (pop reg) (if (null? s) (error "Empty stack -- POP") (let ((top (car s))) (cond ((eq? (car top) reg) (set! s (cdr s)) (cadr top)) (else (error "Register mismatch -- POP" reg (car top))))))) (define (initialize) (set! s '()) 'done) (define (dispatch message) (cond ((eq? message 'push) push) ((eq? message 'pop) pop) ((eq? message 'initialize) (initialize)) (else (error "Unknown request -- STACK" message)))) dispatch))
c. A new table named stack-table will maintain a list of register names and associated stacks. Allocate-register will create a new entry in this table each time a new register is allocated. Make-save will first get the appropriate stack from the machine before pushing the value in. Similarly make-restore will first retrieve the appropriate stack before popping the value.

view plainprint?

1. (define (make-new-machine)  
2.   (let ((pc (make-register 'pc))  
3.         (flag (make-register 'flag))  
4.         (stack (make-stack))  
5.         (the-instruction-sequence '())  
6.         (stack-table '()))  
7.     (define (initialize-stack-table)  
8.       (for-each (lambda (stack)  
9.                   (stack 'initialize))  
10.                 (map cadr stack-table)))  
11.     (let ((the-ops  
12.            (list (list 'initialize-stack initialize-stack-table)))  
13.           (register-table  
14.            (list (list 'pc pc) (list 'flag flag))))  
15.       (define (allocate-register name)  
16.         (if (assoc name register-table)  
17.             (error "Multiply defined register: " name)  
18.             (begin                
19.               (set! register-table  
20.                     (cons (list name (make-register name))  
21.                           register-table))  
22.               (allocate-stack-for-register name)))  
23.         'register-allocated)  
24.       (define (allocate-stack-for-register name)  
25.         (set! stack-table  
26.               (cons (list name (make-stack)) stack-table)))  
27.       (define (get-register-stack name)  
28.         (let ((record (assoc name stack-table)))  
29.           (if record  
30.               (cadr record)  
31.               (error "No stack found for register" name))))  
32.       (define (lookup-register name)  
33.         (let ((val (assoc name register-table)))  
34.           (if val  
35.               (cadr val)  
36.               (error "Unknown register:" name))))  
37.       (define (execute)  
38.         (let ((insts (get-contents pc)))  
39.           (if (null? insts)  
40.               'done  
41.               (begin  
42.                 ((instruction-execution-proc (car insts)))  
43.                 (execute)))))  
44.       (define (dispatch message)  
45.         (cond ((eq? message 'start)  
46.                (set-contents! pc the-instruction-sequence)  
47.                (execute))  
48.               ((eq? message 'install-instruction-sequence)  
49.                (lambda (seq) (set! the-instruction-sequence seq)))  
50.               ((eq? message 'allocate-register) allocate-register)  
51.               ((eq? message 'get-register) lookup-register)  
52.               ((eq? message 'install-operations)  
53.                (lambda (ops) (set! the-ops (append the-ops ops))))  
54.               ((eq? message 'stack) stack)  
55.               ((eq? message 'operations) the-ops)  
56.               ((eq? message 'get-register-stack) get-register-stack)  
57.               (else (error "Unknown request -- MACHINE" message))))  
58.       dispatch)))  
59.   
60. (define (get-register-stack machine register-name)  
61.   ((machine 'get-register-stack) register-name))  
62.   
63. (define (make-save inst machine stack pc)  
64.   (let ((reg (get-register machine (stack-inst-reg-name inst)))  
65.         (stack (get-register-stack machine (stack-inst-reg-name inst))))  
66.     (lambda ()  
67.       (push stack (get-contents reg))  
68.       (advance-pc pc))))  
69.   
70. (define (make-restore inst machine stack pc)  
71.   (let ((reg (get-register machine (stack-inst-reg-name inst)))  
72.         (stack (get-register-stack machine (stack-inst-reg-name inst))))  
73.     (lambda ()  
74.       (set-contents! reg (pop stack))  
75.       (advance-pc pc))))  

(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (stack-table '())) (define (initialize-stack-table) (for-each (lambda (stack) (stack 'initialize)) (map cadr stack-table))) (let ((the-ops (list (list 'initialize-stack initialize-stack-table))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (begin (set! register-table (cons (list name (make-register name)) register-table)) (allocate-stack-for-register name))) 'register-allocated) (define (allocate-stack-for-register name) (set! stack-table (cons (list name (make-stack)) stack-table))) (define (get-register-stack name) (let ((record (assoc name stack-table))) (if record (cadr record) (error "No stack found for register" name)))) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin ((instruction-execution-proc (car insts))) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'get-register-stack) get-register-stack) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (get-register-stack machine register-name) ((machine 'get-register-stack) register-name)) (define (make-save inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst))) (stack (get-register-stack machine (stack-inst-reg-name inst)))) (lambda () (push stack (get-contents reg)) (advance-pc pc)))) (define (make-restore inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst))) (stack (get-register-stack machine (stack-inst-reg-name inst)))) (lambda () (set-contents! reg (pop stack)) (advance-pc pc))))
Exercise 5.12. The simulator can be used to help determine the data paths required for implementing a machine with a given controller. Extend the assembler to store the following information in the machine model:

* a list of all instructions, with duplicates removed, sorted by instruction type (assign, goto, and so on);

* a list (without duplicates) of the registers used to hold entry points (these are the registers referenced by goto instructions);

* a list (without duplicates) of the registers that are saved or restored;

* for each register, a list (without duplicates) of the sources from which it is assigned (for example, the sources for register val in the factorial machine of figure 5.11 are (const 1) and ((op *) (reg n) (reg val))).

Extend the message-passing interface to the machine to provide access to this new information. To test your analyzer, define the Fibonacci machine from figure 5.12 and examine the lists you constructed.

Answer: I am not quite satisfied with the way I have answered this question. The solution looks flaky and involved too many set! operations in my opinion. If you have any suggestions about how to improve the answer let me know.

view plainprint?

1. (define (contains? x items)  
2.   (if (null? items)  
3.       false  
4.       (if (equal? x (car items))  
5.           true  
6.           (contains? x (cdr items)))))  
7.   
8. ;; Machine will store   
9. ;; 1. A list of instructions sorted by type.  
10. ;; 2. A list of registers used to hold entry points.  
11. ;; 3. A list of registers that are saved or restored.  
12. (define (make-new-machine)  
13.   (let ((pc (make-register 'pc))  
14.         (flag (make-register 'flag))  
15.         (stack (make-stack))  
16.         (the-instruction-sequence '())  
17.         (all-instructions '())  
18.         (entry-points '())  
19.         (saved-or-restored '())  
20.         (register-sources '()))          
21.     (let ((the-ops  
22.            (list (list 'initialize-stack  
23.                        (lambda () (stack 'initialize)))))  
24.           (register-table  
25.            (list (list 'pc pc) (list 'flag flag))))  
26.       (define (allocate-register name)  
27.         (if (assoc name register-table)  
28.             (error "Multiply defined register: " name)  
29.             (set! register-table  
30.                   (cons (list name (make-register name))  
31.                         register-table)))  
32.         'register-allocated)  
33.       (define (lookup-register name)  
34.         (let ((val (assoc name register-table)))  
35.           (if val  
36.               (cadr val)  
37.               (error "Unknown register:" name))))  
38.       (define (execute)  
39.         (let ((insts (get-contents pc)))  
40.           (if (null? insts)  
41.               'done  
42.               (begin  
43.                 ((instruction-execution-proc (car insts)))  
44.                 (execute)))))  
45.       (define (dispatch message)  
46.         (cond ((eq? message 'start)  
47.                (set-contents! pc the-instruction-sequence)  
48.                (execute))  
49.               ((eq? message 'install-instruction-sequence)  
50.                (lambda (seq) (set! the-instruction-sequence seq)))  
51.               ((eq? message 'allocate-register) allocate-register)  
52.               ((eq? message 'get-register) lookup-register)  
53.               ((eq? message 'install-operations)  
54.                (lambda (ops) (set! the-ops (append the-ops ops))))  
55.               ((eq? message 'stack) stack)  
56.               ((eq? message 'operations) the-ops)  
57.               ((eq? message 'get-all-instructions)  
58.                (for-each (lambda (record)  
59.                            (printf "~a\n" (car record))  
60.                            (for-each (lambda (item)  
61.                                        (printf "\t~a\n" item))  
62.                                      (cdr record)))  
63.                          all-instructions))  
64.               ((eq? message 'store-all-instructions)  
65.                (lambda (instructions) (set! all-instructions instructions)))  
66.               ((eq? message 'get-entry-points)   
67.                (printf "Entry point registers:\n")  
68.                (for-each (lambda (e) (printf "\t~a\n" e)) entry-points))  
69.               ((eq? message 'store-entry-points)  
70.                (lambda (items) (set! entry-points items)))  
71.               ((eq? message 'get-saved-or-restored-registers)   
72.                (printf "Saved or restored registers:\n")  
73.                (for-each (lambda (r) (printf "\t~a\n" r)) saved-or-restored))  
74.               ((eq? message 'store-saved-or-restored-registers)  
75.                (lambda (items) (set! saved-or-restored items)))  
76.               ((eq? message 'get-register-sources)  
77.                (for-each (lambda (record)  
78.                            (printf "Register: ~a\n" (car record))  
79.                            (for-each (lambda (item)  
80.                                        (printf "\t~a\n" item))  
81.                                      (cdr record)))  
82.                          register-sources))  
83.               ((eq? message 'store-register-sources)  
84.                (lambda (sources) (set! register-sources sources)))  
85.               (else (error "Unknown request -- MACHINE" message))))  
86.       dispatch)))  
87.   
88. (define (store-unique-instructions machine insts)  
89.   ((machine 'store-all-instructions) insts))  
90.   
91. (define (get-unique-instructions machine)  
92.   (machine 'get-all-instructions))  
93.   
94. (define (store-entry-points machine items)  
95.   ((machine 'store-entry-points) items))  
96.   
97. (define (get-entry-points machine)  
98.   (machine 'get-entry-points))  
99.   
100. (define (store-saved-or-restored-registers machine items)  
101.   ((machine 'store-saved-or-restored-registers) items))  
102.   
103. (define (get-saved-or-restored-registers machine)  
104.   (machine 'get-saved-or-restored-registers))  
105.   
106. (define (store-register-sources machine items)  
107.   ((machine 'store-register-sources) items))  
108.   
109. (define (get-register-sources machine)  
110.   (machine 'get-register-sources))  
111.   
112. ;; Assemble will call a procedure to return a unique set of instructions sorted by type.  
113. (define (assemble controller-text machine)  
114.   (extract-labels controller-text  
115.     (lambda (insts labels)  
116.       (update-insts! insts labels machine)  
117.       (store-useful-information machine insts)  
118.       insts)))  
119.   
120. (define (store-useful-information machine insts)  
121.   (let ((unique-instructions '((assign) (branch) (goto) (perform) (restore) (save) (test)))  
122.         (entry-points '())  
123.         (saved-or-restored-registers '())  
124.         (register-sources '())  
125.         (inst-text (map instruction-text insts)))  
126.     (define (gather-unique-instructions inst)  
127.       (let ((record (assoc (car inst) unique-instructions)))  
128.         (let ((items (cdr record)))  
129.           (cond ((not (contains? inst items))  
130.                  (set-cdr! record (cons inst items)))))))      
131.     (define (gather-entry-points inst)  
132.       (let ((inst-type (car inst))  
133.             (inst-target (cadr inst)))  
134.         (if (and (eq? inst-type 'goto)           ; GOTO instruction.  
135.                  (register-exp? inst-target)     ; Target is a register.  
136.                  (not (memq (register-exp-reg inst-target) entry-points)))  
137.             (set! entry-points (cons (register-exp-reg inst-target) entry-points)))))  
138.     (define (gather-saved-or-restored-registers inst)  
139.       (let ((inst-type (car inst))  
140.             (inst-target (cadr inst)))  
141.         (if (and (or (eq? inst-type 'save)       ; Save or Restore instruction.  
142.                      (eq? inst-type 'restore))  
143.                  (not (memq inst-target saved-or-restored-registers)))  
144.             (set! saved-or-restored-registers (cons inst-target saved-or-restored-registers)))))      
145.     (define (gather-regigster-sources inst)  
146.       (if (eq? (car inst) 'assign)               ; Assign instruction.  
147.           (let ((register (assign-reg-name inst))  
148.                 (source (assign-value-exp inst)))  
149.             (let ((record (assoc register register-sources)))  
150.               (if (and record (not (contains? source (cdr record))))  
151.                   (let ((items (cdr record)))  
152.                     (set-cdr! record (cons source items)))  
153.                   (set! register-sources (cons (list register source) register-sources)))))))        
154.     (for-each (lambda (inst)  
155.                 (gather-unique-instructions inst)  
156.                 (gather-entry-points inst)  
157.                 (gather-saved-or-restored-registers inst)  
158.                 (gather-regigster-sources inst))  
159.               inst-text)     
160.     (store-unique-instructions machine unique-instructions)  
161.     (store-entry-points machine entry-points)  
162.     (store-saved-or-restored-registers machine saved-or-restored-registers)  
163.     (store-register-sources machine register-sources)))  

(define (contains? x items) (if (null? items) false (if (equal? x (car items)) true (contains? x (cdr items))))) ;; Machine will store ;; 1. A list of instructions sorted by type. ;; 2. A list of registers used to hold entry points. ;; 3. A list of registers that are saved or restored. (define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (all-instructions '()) (entry-points '()) (saved-or-restored '()) (register-sources '())) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin ((instruction-execution-proc (car insts))) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'get-all-instructions) (for-each (lambda (record) (printf "~a\n" (car record)) (for-each (lambda (item) (printf "\t~a\n" item)) (cdr record))) all-instructions)) ((eq? message 'store-all-instructions) (lambda (instructions) (set! all-instructions instructions))) ((eq? message 'get-entry-points) (printf "Entry point registers:\n") (for-each (lambda (e) (printf "\t~a\n" e)) entry-points)) ((eq? message 'store-entry-points) (lambda (items) (set! entry-points items))) ((eq? message 'get-saved-or-restored-registers) (printf "Saved or restored registers:\n") (for-each (lambda (r) (printf "\t~a\n" r)) saved-or-restored)) ((eq? message 'store-saved-or-restored-registers) (lambda (items) (set! saved-or-restored items))) ((eq? message 'get-register-sources) (for-each (lambda (record) (printf "Register: ~a\n" (car record)) (for-each (lambda (item) (printf "\t~a\n" item)) (cdr record))) register-sources)) ((eq? message 'store-register-sources) (lambda (sources) (set! register-sources sources))) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (store-unique-instructions machine insts) ((machine 'store-all-instructions) insts)) (define (get-unique-instructions machine) (machine 'get-all-instructions)) (define (store-entry-points machine items) ((machine 'store-entry-points) items)) (define (get-entry-points machine) (machine 'get-entry-points)) (define (store-saved-or-restored-registers machine items) ((machine 'store-saved-or-restored-registers) items)) (define (get-saved-or-restored-registers machine) (machine 'get-saved-or-restored-registers)) (define (store-register-sources machine items) ((machine 'store-register-sources) items)) (define (get-register-sources machine) (machine 'get-register-sources)) ;; Assemble will call a procedure to return a unique set of instructions sorted by type. (define (assemble controller-text machine) (extract-labels controller-text (lambda (insts labels) (update-insts! insts labels machine) (store-useful-information machine insts) insts))) (define (store-useful-information machine insts) (let ((unique-instructions '((assign) (branch) (goto) (perform) (restore) (save) (test))) (entry-points '()) (saved-or-restored-registers '()) (register-sources '()) (inst-text (map instruction-text insts))) (define (gather-unique-instructions inst) (let ((record (assoc (car inst) unique-instructions))) (let ((items (cdr record))) (cond ((not (contains? inst items)) (set-cdr! record (cons inst items))))))) (define (gather-entry-points inst) (let ((inst-type (car inst)) (inst-target (cadr inst))) (if (and (eq? inst-type 'goto) ; GOTO instruction. (register-exp? inst-target) ; Target is a register. (not (memq (register-exp-reg inst-target) entry-points))) (set! entry-points (cons (register-exp-reg inst-target) entry-points))))) (define (gather-saved-or-restored-registers inst) (let ((inst-type (car inst)) (inst-target (cadr inst))) (if (and (or (eq? inst-type 'save) ; Save or Restore instruction. (eq? inst-type 'restore)) (not (memq inst-target saved-or-restored-registers))) (set! saved-or-restored-registers (cons inst-target saved-or-restored-registers))))) (define (gather-regigster-sources inst) (if (eq? (car inst) 'assign) ; Assign instruction. (let ((register (assign-reg-name inst)) (source (assign-value-exp inst))) (let ((record (assoc register register-sources))) (if (and record (not (contains? source (cdr record)))) (let ((items (cdr record))) (set-cdr! record (cons source items))) (set! register-sources (cons (list register source) register-sources))))))) (for-each (lambda (inst) (gather-unique-instructions inst) (gather-entry-points inst) (gather-saved-or-restored-registers inst) (gather-regigster-sources inst)) inst-text) (store-unique-instructions machine unique-instructions) (store-entry-points machine entry-points) (store-saved-or-restored-registers machine saved-or-restored-registers) (store-register-sources machine register-sources)))
Exercise 5.13. Modify the simulator so that it uses the controller sequence to determine what registers the machine has rather than requiring a list of registers as an argument to make-machine. Instead of pre-allocating the registers in make-machine, you can allocate them one at a time when they are first seen during assembly of the instructions.

Answer:Make-machine does not require the list of registers to be explicitly passed.

view plainprint?

1. (define (make-machine ops controller-text)  
2.   (let ((machine (make-new-machine)))  
3.     ((machine 'install-operations) ops)      
4.     ((machine 'install-instruction-sequence)  
5.      (assemble controller-text machine))  
6.     machine))  

(define (make-machine ops controller-text) (let ((machine (make-new-machine))) ((machine 'install-operations) ops) ((machine 'install-instruction-sequence) (assemble controller-text machine)) machine))
Update-insts will scan each instruction to find the registers used by that instruction. If that register has not already been installed update-insts will install it. Registers have to be allocated *before* installing the instruction execution procedures.

view plainprint?

1. (define (update-insts! insts labels machine)  
2.   (let ((pc (get-register machine 'pc))  
3.         (flag (get-register machine 'flag))  
4.         (stack (machine 'stack))  
5.         (ops (machine 'operations))  
6.         (installed-registers '()))  
7.     (for-each  
8.      (lambda (inst)  
9.        (for-each (lambda (register)  
10.                    (if (not (memq register installed-registers))  
11.                        (begin  
12.                          ((machine 'allocate-register) register)  
13.                          (set! installed-registers (cons register installed-registers)))))  
14.                  (find-registers-used (instruction-text inst)))  
15.        (set-instruction-execution-proc!   
16.         inst  
17.         (make-execution-procedure  
18.          (instruction-text inst) labels machine  
19.          pc flag stack ops)))  
20.      insts)))  

(define (update-insts! insts labels machine) (let ((pc (get-register machine 'pc)) (flag (get-register machine 'flag)) (stack (machine 'stack)) (ops (machine 'operations)) (installed-registers '())) (for-each (lambda (inst) (for-each (lambda (register) (if (not (memq register installed-registers)) (begin ((machine 'allocate-register) register) (set! installed-registers (cons register installed-registers))))) (find-registers-used (instruction-text inst))) (set-instruction-execution-proc! inst (make-execution-procedure (instruction-text inst) labels machine pc flag stack ops))) insts)))
Find-registers-used will scan the given instruction to find the registers used.

view plainprint?

1. (define (find-registers-used inst)  
2.   (define (iter inst-text registers)  
3.     (if (null? inst-text)  
4.         registers  
5.         (let ((first (car inst-text))  
6.               (rest (cdr inst-text)))  
7.           (if (and (register-exp? first) (not (memq (register-exp-reg first) registers)))  
8.               (iter rest (cons (register-exp-reg first) registers))  
9.               (iter rest registers)))))  
10.   (cond ((eq? (car inst) 'assign)  
11.          (iter (cdr inst) (list (assign-reg-name inst))))  
12.         ((or (eq? (car inst) 'save) (eq? (car inst) 'restore))  
13.          (list (stack-inst-reg-name inst)))  
14.         (else  
15.          (iter (cdr inst) '()))))  

(define (find-registers-used inst) (define (iter inst-text registers) (if (null? inst-text) registers (let ((first (car inst-text)) (rest (cdr inst-text))) (if (and (register-exp? first) (not (memq (register-exp-reg first) registers))) (iter rest (cons (register-exp-reg first) registers)) (iter rest registers))))) (cond ((eq? (car inst) 'assign) (iter (cdr inst) (list (assign-reg-name inst)))) ((or (eq? (car inst) 'save) (eq? (car inst) 'restore)) (list (stack-inst-reg-name inst))) (else (iter (cdr inst) '()))))
Exercise 5.14. Measure the number of pushes and the maximum stack depth required to compute n! for various small values of n using the factorial machine shown in figure 5.11. From your data determine formulas in terms of n for the total number of push operations and the maximum stack depth used in computing n! for any n > 1. Note that each of these is a linear function of n and is thus determined by two constants. In order to get the statistics printed, you will have to augment the factorial machine with instructions to initialize the stack and print the statistics. You may want to also modify the machine so that it repeatedly reads a value for n, computes the factorial, and prints the result (as we did for the GCD machine in figure 5.4), so that you will not have to repeatedly invoke get-register-contents, set-register-contents!, and start.

Answer:

view plainprint?

1. ;; Test setup  
2. (define fact-machine  
3.   (make-machine  
4.    '(n val continue)  
5.    (list (list 'read read) (list '- -) (list '* *) (list '= =) (list 'print printf))  
6.    '(controller  
7.      init  
8.        (assign continue (label fact-done))     ; set up final return address  
9.        (assign n (op read))  
10.      fact-loop  
11.        (test (op =) (reg n) (const 1))  
12.        (branch (label base-case))  
13.        ;; Set up for the recursive call by saving n and continue.  
14.        ;; Set up continue so that the computation will continue  
15.        ;; at after-fact when the subroutine returns.  
16.        (save continue)  
17.        (save n)  
18.        (assign n (op -) (reg n) (const 1))  
19.        (assign continue (label after-fact))  
20.        (goto (label fact-loop))  
21.      after-fact  
22.        (restore n)  
23.        (restore continue)  
24.        (assign val (op *) (reg n) (reg val))   ; val now contains n(n - 1)!  
25.        (goto (reg continue))                   ; return to caller  
26.      base-case  
27.        (assign val (const 1))                  ; base case: 1! = 1  
28.        (goto (reg continue))                   ; return to caller  
29.      fact-done  
30.        (perform (op print) (const "Factorial:~a\n") (reg val))  
31.        (perform (op print-stack-statistics))  
32.        (perform (op initialize-stack))  
33.        (goto (label init)))))  
34.   
35. (start fact-machine)  
36.   
37. ;; Results  
38. ;; n  - total pushes - max depth  
39. ;; 2  - 2            - 2    
40. ;; 3  - 4            - 4  
41. ;; 4  - 6            - 6  
42. ;; 5  - 8            - 8  
43. ;; 6  - 10           - 10  
44. ;; 7  - 12           - 12  
45. ;; 8  - 14           - 14  
46. ;; 9  - 16           - 16  
47. ;; 10 - 18           - 18  

;; Test setup (define fact-machine (make-machine '(n val continue) (list (list 'read read) (list '- -) (list '* *) (list '= =) (list 'print printf)) '(controller init (assign continue (label fact-done)) ; set up final return address (assign n (op read)) fact-loop (test (op =) (reg n) (const 1)) (branch (label base-case)) ;; Set up for the recursive call by saving n and continue. ;; Set up continue so that the computation will continue ;; at after-fact when the subroutine returns. (save continue) (save n) (assign n (op -) (reg n) (const 1)) (assign continue (label after-fact)) (goto (label fact-loop)) after-fact (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)! (goto (reg continue)) ; return to caller base-case (assign val (const 1)) ; base case: 1! = 1 (goto (reg continue)) ; return to caller fact-done (perform (op print) (const "Factorial:~a\n") (reg val)) (perform (op print-stack-statistics)) (perform (op initialize-stack)) (goto (label init))))) (start fact-machine) ;; Results ;; n - total pushes - max depth ;; 2 - 2 - 2 ;; 3 - 4 - 4 ;; 4 - 6 - 6 ;; 5 - 8 - 8 ;; 6 - 10 - 10 ;; 7 - 12 - 12 ;; 8 - 14 - 14 ;; 9 - 16 - 16 ;; 10 - 18 - 18
The total number of pushes and max depth of the stack for calculating n! is given by the formula 2(n - 1).

Exercise 5.15. Add instruction counting to the register machine simulation. That is, have the machine model keep track of the number of instructions executed. Extend the machine model's interface to accept a new message that prints the value of the instruction count and resets the count to zero.

Answer:

view plainprint?

1. (define (make-new-machine)  
2.   (let ((pc (make-register 'pc))  
3.         (flag (make-register 'flag))  
4.         (stack (make-stack))  
5.         (the-instruction-sequence '())  
6.         (instruction-count 0))  
7.     (let ((the-ops  
8.            (list (list 'initialize-stack  
9.                        (lambda () (stack 'initialize)))))  
10.           (register-table  
11.            (list (list 'pc pc) (list 'flag flag))))  
12.       (define (allocate-register name)  
13.         (if (assoc name register-table)  
14.             (error "Multiply defined register: " name)  
15.             (set! register-table  
16.                   (cons (list name (make-register name))  
17.                         register-table)))  
18.         'register-allocated)  
19.       (define (lookup-register name)  
20.         (let ((val (assoc name register-table)))  
21.           (if val  
22.               (cadr val)  
23.               (error "Unknown register:" name))))  
24.       (define (execute)  
25.         (let ((insts (get-contents pc)))  
26.           (if (null? insts)  
27.               'done  
28.               (begin  
29.                 ((instruction-execution-proc (car insts)))  
30.                 (set! instruction-count (+ instruction-count 1))  
31.                 (execute)))))  
32.       (define (dispatch message)  
33.         (cond ((eq? message 'start)  
34.                (set-contents! pc the-instruction-sequence)  
35.                (execute))  
36.               ((eq? message 'install-instruction-sequence)  
37.                (lambda (seq) (set! the-instruction-sequence seq)))  
38.               ((eq? message 'allocate-register) allocate-register)  
39.               ((eq? message 'get-register) lookup-register)  
40.               ((eq? message 'install-operations)  
41.                (lambda (ops) (set! the-ops (append the-ops ops))))  
42.               ((eq? message 'stack) stack)  
43.               ((eq? message 'operations) the-ops)  
44.               ((eq? message 'instruction-count) instruction-count)  
45.               ((eq? message 'reset-instruction-count)  
46.                (set! instruction-count 0))  
47.               (else (error "Unknown request -- MACHINE" message))))  
48.       dispatch)))  
49.   
50. (define (get-instruction-count machine)  
51.   (machine 'instruction-count))  
52.   
53. (define (reset-instruction-count machine)  
54.   (machine 'reset-instruction-count))  

(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-count 0)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin ((instruction-execution-proc (car insts))) (set! instruction-count (+ instruction-count 1)) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'instruction-count) instruction-count) ((eq? message 'reset-instruction-count) (set! instruction-count 0)) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (get-instruction-count machine) (machine 'instruction-count)) (define (reset-instruction-count machine) (machine 'reset-instruction-count))
Exercise 5.16. Augment the simulator to provide for instruction tracing. That is, before each instruction is executed, the simulator should print the text of the instruction. Make the machine model accept trace-on and trace-off messages to turn tracing on and off.

Answer:

view plainprint?

1. (define (make-new-machine)  
2.   (let ((pc (make-register 'pc))  
3.         (flag (make-register 'flag))  
4.         (stack (make-stack))  
5.         (the-instruction-sequence '())  
6.         (instruction-count 0)  
7.         (tracing false))  
8.     (let ((the-ops  
9.            (list (list 'initialize-stack  
10.                        (lambda () (stack 'initialize)))))  
11.           (register-table  
12.            (list (list 'pc pc) (list 'flag flag))))  
13.       (define (allocate-register name)  
14.         (if (assoc name register-table)  
15.             (error "Multiply defined register: " name)  
16.             (set! register-table  
17.                   (cons (list name (make-register name))  
18.                         register-table)))  
19.         'register-allocated)  
20.       (define (lookup-register name)  
21.         (let ((val (assoc name register-table)))  
22.           (if val  
23.               (cadr val)  
24.               (error "Unknown register:" name))))  
25.       (define (execute)  
26.         (let ((insts (get-contents pc)))  
27.           (if (null? insts)  
28.               'done  
29.               (let ((inst (car insts)))  
30.                 (if tracing  
31.                     (begin (display (instruction-text inst))  
32.                            (newline)))  
33.                 (set! instruction-count (+ instruction-count 1))  
34.                 ((instruction-execution-proc inst))  
35.                 (execute)))))  
36.       (define (dispatch message)  
37.         (cond ((eq? message 'start)  
38.                (set-contents! pc the-instruction-sequence)  
39.                (execute))  
40.               ((eq? message 'install-instruction-sequence)  
41.                (lambda (seq) (set! the-instruction-sequence seq)))  
42.               ((eq? message 'allocate-register) allocate-register)  
43.               ((eq? message 'get-register) lookup-register)  
44.               ((eq? message 'install-operations)  
45.                (lambda (ops) (set! the-ops (append the-ops ops))))  
46.               ((eq? message 'stack) stack)  
47.               ((eq? message 'operations) the-ops)  
48.               ((eq? message 'instruction-count) instruction-count)  
49.               ((eq? message 'reset-instruction-count) (set! instruction-count 0))  
50.               ((eq? message 'trace-on) (set! tracing true))  
51.               ((eq? message 'trace-off) (set! tracing false))                
52.               (else (error "Unknown request -- MACHINE" message))))  
53.       dispatch)))  
54.   
55. (define (set-trace-on machine)  
56.   (machine 'trace-on))  
57.   
58. (define (set-trace-off machine)  
59.   (machine 'trace-off))  

(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-count 0) (tracing false)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (let ((inst (car insts))) (if tracing (begin (display (instruction-text inst)) (newline))) (set! instruction-count (+ instruction-count 1)) ((instruction-execution-proc inst)) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'instruction-count) instruction-count) ((eq? message 'reset-instruction-count) (set! instruction-count 0)) ((eq? message 'trace-on) (set! tracing true)) ((eq? message 'trace-off) (set! tracing false)) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (set-trace-on machine) (machine 'trace-on)) (define (set-trace-off machine) (machine 'trace-off))
Exercise 5.17. Extend the instruction tracing of exercise 5.16 so that before printing an instruction, the simulator prints any labels that immediately precede that instruction in the controller sequence. Be careful to do this in a way that does not interfere with instruction counting (exercise 5.15). You will have to make the simulator retain the necessary label information.

Answer: Extract-labels will include labels as part of instructions.

view plainprint?

1. (define (extract-labels text receive)  
2.   (if (null? text)  
3.       (receive '() '())  
4.       (extract-labels (cdr text)  
5.        (lambda (insts labels)  
6.          (let ((next-inst (car text)))  
7.            (if (symbol? next-inst)  
8.                (let ((new-insts (cons (cons next-inst '()) insts)))  
9.                  (receive new-insts  
10.                           (cons (make-label-entry next-inst  
11.                                                   new-insts)  
12.                                 labels)))  
13.                (receive (cons (make-instruction next-inst)  
14.                               insts)  
15.                         labels)))))))  

(define (extract-labels text receive) (if (null? text) (receive '() '()) (extract-labels (cdr text) (lambda (insts labels) (let ((next-inst (car text))) (if (symbol? next-inst) (let ((new-insts (cons (cons next-inst '()) insts))) (receive new-insts (cons (make-label-entry next-inst new-insts) labels))) (receive (cons (make-instruction next-inst) insts) labels)))))))
Make-execution-procedure will create a special execution procedure for labels. These procedures will advance the program counter (pc) and return the name of the label.

view plainprint?

1. (define (make-execution-procedure inst labels machine  
2.                                   pc flag stack ops)  
3.   (cond ((not (pair? inst))   
4.          (make-label-exec-proc inst pc))  
5.         ((eq? (car inst) 'assign)  
6.          (make-assign inst machine labels ops pc))  
7.         ((eq? (car inst) 'test)  
8.          (make-test inst machine labels ops flag pc))  
9.         ((eq? (car inst) 'branch)  
10.          (make-branch inst machine labels flag pc))  
11.         ((eq? (car inst) 'goto)  
12.          (make-goto inst machine labels pc))  
13.         ((eq? (car inst) 'save)  
14.          (make-save inst machine stack pc))  
15.         ((eq? (car inst) 'restore)  
16.          (make-restore inst machine stack pc))  
17.         ((eq? (car inst) 'perform)  
18.          (make-perform inst machine labels ops pc))  
19.         (else (error "Unknown instruction type -- ASSEMBLE"  
20.                      inst))))  
21.   
22. (define (make-label-exec-proc inst pc)  
23.   (lambda ()  
24.     (advance-pc pc)  
25.     inst))  

(define (make-execution-procedure inst labels machine pc flag stack ops) (cond ((not (pair? inst)) (make-label-exec-proc inst pc)) ((eq? (car inst) 'assign) (make-assign inst machine labels ops pc)) ((eq? (car inst) 'test) (make-test inst machine labels ops flag pc)) ((eq? (car inst) 'branch) (make-branch inst machine labels flag pc)) ((eq? (car inst) 'goto) (make-goto inst machine labels pc)) ((eq? (car inst) 'save) (make-save inst machine stack pc)) ((eq? (car inst) 'restore) (make-restore inst machine stack pc)) ((eq? (car inst) 'perform) (make-perform inst machine labels ops pc)) (else (error "Unknown instruction type -- ASSEMBLE" inst)))) (define (make-label-exec-proc inst pc) (lambda () (advance-pc pc) inst))
Machine with tracing and counting. Count is not incremented if the instruction being executed is a label.

view plainprint?

1. (define (make-new-machine)  
2.   (let ((pc (make-register 'pc))  
3.         (flag (make-register 'flag))  
4.         (stack (make-stack))  
5.         (the-instruction-sequence '())  
6.         (instruction-count 0)  
7.         (tracing false))  
8.     (let ((the-ops  
9.            (list (list 'initialize-stack  
10.                        (lambda () (stack 'initialize)))))  
11.           (register-table  
12.            (list (list 'pc pc) (list 'flag flag))))  
13.       (define (allocate-register name)  
14.         (if (assoc name register-table)  
15.             (error "Multiply defined register: " name)  
16.             (set! register-table  
17.                   (cons (list name (make-register name))  
18.                         register-table)))  
19.         'register-allocated)  
20.       (define (lookup-register name)  
21.         (let ((val (assoc name register-table)))  
22.           (if val  
23.               (cadr val)  
24.               (error "Unknown register:" name))))  
25.       (define (execute)  
26.         (let ((insts (get-contents pc)))  
27.           (if (null? insts)  
28.               'done  
29.               (let ((inst (car insts)))  
30.                 (if tracing  
31.                     (begin (display (instruction-text inst))  
32.                            (newline)))  
33.                 (if (pair? (car inst)) ;; Not a label.  
34.                     (set! instruction-count (+ instruction-count 1)))  
35.                 ((instruction-execution-proc inst))  
36.                 (execute)))))  
37.       (define (dispatch message)  
38.         (cond ((eq? message 'start)  
39.                (set-contents! pc the-instruction-sequence)  
40.                (execute))  
41.               ((eq? message 'install-instruction-sequence)  
42.                (lambda (seq) (set! the-instruction-sequence seq)))  
43.               ((eq? message 'allocate-register) allocate-register)  
44.               ((eq? message 'get-register) lookup-register)  
45.               ((eq? message 'install-operations)  
46.                (lambda (ops) (set! the-ops (append the-ops ops))))  
47.               ((eq? message 'stack) stack)  
48.               ((eq? message 'operations) the-ops)  
49.               ((eq? message 'instruction-count) instruction-count)  
50.               ((eq? message 'reset-instruction-count) (set! instruction-count 0))  
51.               ((eq? message 'trace-on) (set! tracing true))  
52.               ((eq? message 'trace-off) (set! tracing false))                
53.               (else (error "Unknown request -- MACHINE" message))))  
54.       dispatch)))  
55.   
56. (define (get-instruction-count machine)  
57.   (machine 'instruction-count))  
58.   
59. (define (reset-instruction-count machine)  
60.   (machine 'reset-instruction-count))  
61.   
62. (define (set-trace-on machine)  
63.   (machine 'trace-on))  
64.   
65. (define (set-trace-off machine)  
66.   (machine 'trace-off))  

(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-count 0) (tracing false)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (let ((inst (car insts))) (if tracing (begin (display (instruction-text inst)) (newline))) (if (pair? (car inst)) ;; Not a label. (set! instruction-count (+ instruction-count 1))) ((instruction-execution-proc inst)) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'instruction-count) instruction-count) ((eq? message 'reset-instruction-count) (set! instruction-count 0)) ((eq? message 'trace-on) (set! tracing true)) ((eq? message 'trace-off) (set! tracing false)) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (get-instruction-count machine) (machine 'instruction-count)) (define (reset-instruction-count machine) (machine 'reset-instruction-count)) (define (set-trace-on machine) (machine 'trace-on)) (define (set-trace-off machine) (machine 'trace-off))
Exercise 5.18. Modify the make-register procedure of section 5.2.1 so that registers can be traced. Registers should accept messages that turn tracing on and off. When a register is traced, assigning a value to the register should print the name of the register, the old contents of the register, and the new contents being assigned. Extend the interface to the machine model to permit you to turn tracing on and off for designated machine registers.

Answer:

view plainprint?

1. (define (make-register name)  
2.   (let ((contents '*unassigned*)  
3.         (tracing false))  
4.     (define (set value)  
5.       (if tracing   
6.           (printf "~a ~a ~a\n" name contents value))  
7.       (set! contents value))        
8.     (define (dispatch message)  
9.       (cond ((eq? message 'get) contents)  
10.             ((eq? message 'set) set)  
11.             ((eq? message 'trace-on) (set! tracing true))  
12.             ((eq? message 'trace-off) (set! tracing false))  
13.             (else  
14.              (error "Unknown request -- REGISTER" message))))  
15.     dispatch))  
16.   
17. (define (make-new-machine)  
18.   (let ((pc (make-register 'pc))  
19.         (flag (make-register 'flag))  
20.         (stack (make-stack))  
21.         (the-instruction-sequence '())  
22.         (instruction-count 0)  
23.         (tracing false))  
24.     (let ((the-ops  
25.            (list (list 'initialize-stack  
26.                        (lambda () (stack 'initialize)))))  
27.           (register-table  
28.            (list (list 'pc pc) (list 'flag flag))))  
29.       (define (allocate-register name)  
30.         (if (assoc name register-table)  
31.             (error "Multiply defined register: " name)  
32.             (set! register-table  
33.                   (cons (list name (make-register name))  
34.                         register-table)))  
35.         'register-allocated)  
36.       (define (lookup-register name)  
37.         (let ((val (assoc name register-table)))  
38.           (if val  
39.               (cadr val)  
40.               (error "Unknown register:" name))))  
41.       (define (execute)  
42.         (let ((insts (get-contents pc)))  
43.           (if (null? insts)  
44.               'done  
45.               (let ((inst (car insts)))  
46.                 (if tracing  
47.                     (begin (display (instruction-text inst))  
48.                            (newline)))  
49.                 (if (pair? (car inst)) ;; Not a label.  
50.                     (set! instruction-count (+ instruction-count 1)))  
51.                 ((instruction-execution-proc inst))  
52.                 (execute)))))  
53.       (define (dispatch message)  
54.         (cond ((eq? message 'start)  
55.                (set-contents! pc the-instruction-sequence)  
56.                (execute))  
57.               ((eq? message 'install-instruction-sequence)  
58.                (lambda (seq) (set! the-instruction-sequence seq)))  
59.               ((eq? message 'allocate-register) allocate-register)  
60.               ((eq? message 'get-register) lookup-register)  
61.               ((eq? message 'install-operations)  
62.                (lambda (ops) (set! the-ops (append the-ops ops))))  
63.               ((eq? message 'stack) stack)  
64.               ((eq? message 'operations) the-ops)  
65.               ((eq? message 'instruction-count) instruction-count)  
66.               ((eq? message 'reset-instruction-count) (set! instruction-count 0))  
67.               ((eq? message 'trace-on) (set! tracing true))  
68.               ((eq? message 'trace-off) (set! tracing false))                
69.               ((eq? message 'reg-trace-on)  
70.                (lambda (reg-name) ((lookup-register reg-name) 'trace-on)))  
71.               ((eq? message 'reg-trace-off)  
72.                (lambda (reg-name) ((lookup-register reg-name) 'trace-off)))  
73.               (else (error "Unknown request -- MACHINE" message))))  
74.       dispatch)))  
75.   
76. (define (set-reg-trace-on machine reg-name)  
77.   ((machine 'reg-trace-on) reg-name))  
78.   
79. (define (set-reg-trace-off machine reg-name)  
80.   ((machine 'reg-trace-off) reg-name))  

(define (make-register name) (let ((contents '*unassigned*) (tracing false)) (define (set value) (if tracing (printf "~a ~a ~a\n" name contents value)) (set! contents value)) (define (dispatch message) (cond ((eq? message 'get) contents) ((eq? message 'set) set) ((eq? message 'trace-on) (set! tracing true)) ((eq? message 'trace-off) (set! tracing false)) (else (error "Unknown request -- REGISTER" message)))) dispatch)) (define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-count 0) (tracing false)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (let ((inst (car insts))) (if tracing (begin (display (instruction-text inst)) (newline))) (if (pair? (car inst)) ;; Not a label. (set! instruction-count (+ instruction-count 1))) ((instruction-execution-proc inst)) (execute))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'instruction-count) instruction-count) ((eq? message 'reset-instruction-count) (set! instruction-count 0)) ((eq? message 'trace-on) (set! tracing true)) ((eq? message 'trace-off) (set! tracing false)) ((eq? message 'reg-trace-on) (lambda (reg-name) ((lookup-register reg-name) 'trace-on))) ((eq? message 'reg-trace-off) (lambda (reg-name) ((lookup-register reg-name) 'trace-off))) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (set-reg-trace-on machine reg-name) ((machine 'reg-trace-on) reg-name)) (define (set-reg-trace-off machine reg-name) ((machine 'reg-trace-off) reg-name))
Exercise 5.19. Alyssa P. Hacker wants a breakpoint feature in the simulator to help her debug her machine designs. You have been hired to install this feature for her. She wants to be able to specify a place in the controller sequence where the simulator will stop and allow her to examine the state of the machine. You are to implement a procedure

view plainprint?

1. (set-breakpoint <machine> <label> <n>)  

(set-breakpoint <machine> <label> <n>)
that sets a breakpoint just before the nth instruction after the given label. For example,

view plainprint?

1. (set-breakpoint gcd-machine 'test-b 4)  

(set-breakpoint gcd-machine 'test-b 4)
installs a breakpoint in gcd-machine just before the assignment to register a. When the simulator reaches the breakpoint it should print the label and the offset of the breakpoint and stop executing instructions. Alyssa can then use get-register-contents and set-register-contents! to manipulate the state of the simulated machine. She should then be able to continue execution by saying

1. (proceed-machine <machine>)  

(proceed-machine <machine>)
She should also be able to remove a specific breakpoint by means of

1. (cancel-breakpoint <machine> <label> <n>)  

(cancel-breakpoint <machine> <label> <n>)
or to remove all breakpoints by means of

1. (cancel-all-breakpoints <machine>)  

(cancel-all-breakpoints <machine>)

Answer: I had a LOT of fun doing this exercise. Sure it took time and I messed up in between. But in the end it was worth the time and energy spent. I present, my first "debugger" :)

view plainprint?

1. (define (remove-from-list element items)  
2.     (filter (lambda (x) (not (eq? x element))) items))  
3.   
4. (define (make-new-machine)  
5.   (let ((pc (make-register 'pc))  
6.         (flag (make-register 'flag))  
7.         (stack (make-stack))  
8.         (the-instruction-sequence '())  
9.         (instruction-count 0)  
10.         (tracing false)  
11.         (breakpoints '())  
12.         (current-label '*unassigned*)  
13.         (line-number 0))  
14.     (let ((the-ops  
15.            (list (list 'initialize-stack  
16.                        (lambda () (stack 'initialize)))))  
17.           (register-table  
18.            (list (list 'pc pc) (list 'flag flag))))  
19.       (define (allocate-register name)  
20.         (if (assoc name register-table)  
21.             (error "Multiply defined register: " name)  
22.             (set! register-table  
23.                   (cons (list name (make-register name))  
24.                         register-table)))  
25.         'register-allocated)  
26.       (define (lookup-register name)  
27.         (let ((val (assoc name register-table)))  
28.           (if val  
29.               (cadr val)  
30.               (error "Unknown register:" name))))  
31.       (define (execute)  
32.         (let ((insts (get-contents pc)))  
33.           (if (null? insts)  
34.               'done  
35.               (let ((inst (car insts)))  
36.                 (if tracing  
37.                     (printf "~a\n" (instruction-text inst)))  
38.                   
39.                 (cond ((pair? (car inst))                    ; Not a label inst.  
40.                        (set! line-number (+ line-number 1))) ; Increment line number                  
41.                       (else                                  ; Is a label inst.  
42.                        (set! current-label (car inst))       ; Store the current label name  
43.                        (set! line-number 0)))                ; Reset the line number  
44.                   
45.                 ; Check if there is a breakpoint matching the current label name and line number.  
46.                 (let ((bp (assoc current-label breakpoints)))  
47.                   (cond ((and bp (memq line-number (cdr bp)))  
48.                          (printf "Breakpoint reached ~a ~a About to execute: ~a\n"   
49.                                  current-label line-number (instruction-text inst)))  
50.                         (else  
51.                          (if (pair? (car inst))  
52.                              (set! instruction-count (+ instruction-count 1)))  
53.                          ((instruction-execution-proc inst))  
54.                          (execute))))))))  
55.       (define (dispatch message)  
56.         (cond ((eq? message 'start)  
57.                (set-contents! pc the-instruction-sequence)  
58.                (execute))  
59.               ((eq? message 'install-instruction-sequence)  
60.                (lambda (seq) (set! the-instruction-sequence seq)))  
61.               ((eq? message 'allocate-register) allocate-register)  
62.               ((eq? message 'get-register) lookup-register)  
63.               ((eq? message 'install-operations)  
64.                (lambda (ops) (set! the-ops (append the-ops ops))))  
65.               ((eq? message 'stack) stack)  
66.               ((eq? message 'operations) the-ops)  
67.               ((eq? message 'instruction-count) instruction-count)  
68.               ((eq? message 'reset-instruction-count) (set! instruction-count 0))  
69.               ((eq? message 'trace-on) (set! tracing true))  
70.               ((eq? message 'trace-off) (set! tracing false))                
71.               ((eq? message 'reg-trace-on)  
72.                (lambda (reg-name) ((lookup-register reg-name) 'trace-on)))  
73.               ((eq? message 'reg-trace-off)  
74.                (lambda (reg-name) ((lookup-register reg-name) 'trace-off)))  
75.               ((eq? message 'set-breakpoint)  
76.                (lambda (label n)  
77.                  (let ((bp (assoc label breakpoints)))  
78.                    (cond (bp  ; Label is already present in breakpoints. Add line number to list.  
79.                           (let ((line-numbers (cdr bp)))  
80.                             (if (memq n line-numbers)  
81.                                 (error "Breakpoint exists -- MACHINE" label n)  
82.                                 (set-cdr! bp (cons n line-numbers)))))  
83.                          (else  
84.                           (set! breakpoints (cons (list label n) breakpoints)))))))               
85.               ((eq? message 'cancel-breakpoint)  
86.                (lambda (label n)  
87.                  (let ((bp (assoc label breakpoints)))  
88.                    (cond (bp   
89.                           (let ((line-numbers (cdr bp)))  
90.                             (if (memq n line-numbers)  
91.                                 (set-cdr! bp (remove-from-list n line-numbers))  
92.                                 (error "Missing breakpoint -- MACHINE" label n))))  
93.                          (else  
94.                           (error "Missing breakpoint -- MACHINE" label n))))))  
95.               ((eq? message 'cancel-all-breakpoints)  
96.                (set! breakpoints '()))  
97.               ((eq? message 'proceed-machine)  
98.                (execute))  
99.               (else (error "Unknown request -- MACHINE" message))))  
100.       dispatch)))  
101.   
102. (define (set-breakpoint machine label n)  
103.   ((machine 'set-breakpoint) label n))  
104.   
105. (define (cancel-breakpoint machine label n)  
106.   ((machine 'cancel-breakpoint) label n))  
107.   
108. (define (cancel-all-breakpoints machine)  
109.   (machine 'cancel-all-breakpoints))  
110.   
111. (define (proceed-machine machine)  
112.   (machine 'proceed-machine))  

(define (remove-from-list element items) (filter (lambda (x) (not (eq? x element))) items)) (define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-count 0) (tracing false) (breakpoints '()) (current-label '*unassigned*) (line-number 0)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register:" name)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (let ((inst (car insts))) (if tracing (printf "~a\n" (instruction-text inst))) (cond ((pair? (car inst)) ; Not a label inst. (set! line-number (+ line-number 1))) ; Increment line number (else ; Is a label inst. (set! current-label (car inst)) ; Store the current label name (set! line-number 0))) ; Reset the line number ; Check if there is a breakpoint matching the current label name and line number. (let ((bp (assoc current-label breakpoints))) (cond ((and bp (memq line-number (cdr bp))) (printf "Breakpoint reached ~a ~a About to execute: ~a\n" current-label line-number (instruction-text inst))) (else (if (pair? (car inst)) (set! instruction-count (+ instruction-count 1))) ((instruction-execution-proc inst)) (execute)))))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'instruction-count) instruction-count) ((eq? message 'reset-instruction-count) (set! instruction-count 0)) ((eq? message 'trace-on) (set! tracing true)) ((eq? message 'trace-off) (set! tracing false)) ((eq? message 'reg-trace-on) (lambda (reg-name) ((lookup-register reg-name) 'trace-on))) ((eq? message 'reg-trace-off) (lambda (reg-name) ((lookup-register reg-name) 'trace-off))) ((eq? message 'set-breakpoint) (lambda (label n) (let ((bp (assoc label breakpoints))) (cond (bp ; Label is already present in breakpoints. Add line number to list. (let ((line-numbers (cdr bp))) (if (memq n line-numbers) (error "Breakpoint exists -- MACHINE" label n) (set-cdr! bp (cons n line-numbers))))) (else (set! breakpoints (cons (list label n) breakpoints))))))) ((eq? message 'cancel-breakpoint) (lambda (label n) (let ((bp (assoc label breakpoints))) (cond (bp (let ((line-numbers (cdr bp))) (if (memq n line-numbers) (set-cdr! bp (remove-from-list n line-numbers)) (error "Missing breakpoint -- MACHINE" label n)))) (else (error "Missing breakpoint -- MACHINE" label n)))))) ((eq? message 'cancel-all-breakpoints) (set! breakpoints '())) ((eq? message 'proceed-machine) (execute)) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (set-breakpoint machine label n) ((machine 'set-breakpoint) label n)) (define (cancel-breakpoint machine label n) ((machine 'cancel-breakpoint) label n)) (define (cancel-all-breakpoints machine) (machine 'cancel-all-breakpoints)) (define (proceed-machine machine) (machine 'proceed-machine))

SICP Section 5.1 Designing Register Machines

Exercise 5.2. (and 5.1) Use the register-machine language to describe the iterative factorial machine of exercise 5.1.

Answer:

1. (controller  
2.  (assign p (const 1))  
3.  (assign c (const 1))  
4.  test-c  
5.    (test (op >) (reg c) (reg n))  
6.    (branch (label factorial-done))  
7.    (assign t (op *) (reg p) (reg c))  
8.    (assign p (reg t))  
9.    (assign t (op +) (reg c) (const 1))  
10.    (assign c (reg t))  
11.    (goto (label test-c))  
12.  factorial-done)  

(controller (assign p (const 1)) (assign c (const 1)) test-c (test (op >) (reg c) (reg n)) (branch (label factorial-done)) (assign t (op *) (reg p) (reg c)) (assign p (reg t)) (assign t (op +) (reg c) (const 1)) (assign c (reg t)) (goto (label test-c)) factorial-done)
Exercise 5.3. Design a machine to compute square roots using Newton's method, as described in section 1.1.7:

view plainprint?

1. (define (sqrt x)  
2.   (define (good-enough? guess)  
3.     (< (abs (- (square guess) x)) 0.001))  
4.   (define (improve guess)  
5.     (average guess (/ x guess)))  
6.   (define (sqrt-iter guess)  
7.     (if (good-enough? guess)  
8.         guess  
9.         (sqrt-iter (improve guess))))  
10.   (sqrt-iter 1.0))  

(define (sqrt x) (define (good-enough? guess) (< (abs (- (square guess) x)) 0.001)) (define (improve guess) (average guess (/ x guess))) (define (sqrt-iter guess) (if (good-enough? guess) guess (sqrt-iter (improve guess)))) (sqrt-iter 1.0))
Begin by assuming that good-enough? and improve operations are available as primitives. Then show how to expand these in terms of arithmetic operations. Describe each version of the sqrt machine design by drawing a data-path diagram and writing a controller definition in the register-machine language.

Answer: I am skipping the data-path diagrams for the three different versions of sqrt. Controller definitions of the three versions in the register-machine language follow. All three versions assume that abs, square and average are available as primitive operations along with - and /.

Version 1.

1. (controller  
2.  (assign guess (const 1.0))  
3.  sqrt-iter  
4.    (test (op good-enough?) (reg guess))  
5.    (branch (label sqrt-done))  
6.    (assign guess (op improve) (reg guess))  
7.    (goto (label sqrt-iter))  
8.  sqrt-done)  

(controller (assign guess (const 1.0)) sqrt-iter (test (op good-enough?) (reg guess)) (branch (label sqrt-done)) (assign guess (op improve) (reg guess)) (goto (label sqrt-iter)) sqrt-done)
Version 2. In this version good-enough? is expanded using arithmetic operations.

1. (controller   
2.  (assign guess (const 1.0))  
3.  sqrt-iter  
4.    (assign t (op square) (reg guess))  
5.    (assign t (op -) (reg t) (reg x))  
6.    (assign t (op abs) (reg t))  
7.    (test (op <) (reg t) (const 0.001))  
8.    (branch (label sqrt-done))  
9.    (assign guess (op improve) (reg guess))  
10.    (goto (label sqrt-iter))  
11.  sqrt-done)  

(controller (assign guess (const 1.0)) sqrt-iter (assign t (op square) (reg guess)) (assign t (op -) (reg t) (reg x)) (assign t (op abs) (reg t)) (test (op <) (reg t) (const 0.001)) (branch (label sqrt-done)) (assign guess (op improve) (reg guess)) (goto (label sqrt-iter)) sqrt-done)
Version 3. Improve is also expanded using arithmetic operations.

1. (controller  
2.  (assign guess (const 1.0))  
3.  sqrt-iter  
4.    (assign t (op square) (reg guess))  
5.    (assign t (op -) (reg t) (reg x))  
6.    (assign t (op abs) (reg t))  
7.    (test (op <) (reg t) (const 0.001))  
8.    (branch (label sqrt-done))  
9.    (assign t (op /) (reg x) (reg guess))  
10.    (assign guess (op average) (reg t) (reg guess))  
11.    (goto (label sqrt-iter))  
12.  sqrt-done)  

(controller (assign guess (const 1.0)) sqrt-iter (assign t (op square) (reg guess)) (assign t (op -) (reg t) (reg x)) (assign t (op abs) (reg t)) (test (op <) (reg t) (const 0.001)) (branch (label sqrt-done)) (assign t (op /) (reg x) (reg guess)) (assign guess (op average) (reg t) (reg guess)) (goto (label sqrt-iter)) sqrt-done)
Exercise 5.4. Specify register machines that implement each of the following procedures. For each machine, write a controller instruction sequence and draw a diagram showing the data paths.

a. Recursive exponentiation:

view plainprint?

1. (define (expt b n)  
2.   (if (= n 0)  
3.       1  
4.       (* b (expt b (- n 1)))))  

(define (expt b n) (if (= n 0) 1 (* b (expt b (- n 1)))))
b. Iterative exponentiation:

view plainprint?

1. (define (expt b n)  
2.   (define (expt-iter counter product)  
3.     (if (= counter 0)  
4.         product  
5.         (expt-iter (- counter 1) (* b product))))  
6.   (expt-iter n 1))  

(define (expt b n) (define (expt-iter counter product) (if (= counter 0) product (expt-iter (- counter 1) (* b product)))) (expt-iter n 1))

Answer:
a. Recursive exponentiation.

view plainprint?

1. (controller  
2.  (assign continue (label expt-done))  
3.  expt-loop  
4.    (test (op =) (reg n) (const 0)) ;; Test for (= n 0)  
5.    (branch (label base-case))  
6.    ;; We only need to save continue as b is constant throughout   
7.    ;; and the successive values of n are not used for calculation.  
8.    (save continue)  
9.    (assign n (op -) (reg n) (const 1))  
10.    (assign continue (label after-expt))  
11.    (goto (label expt-loop))  
12.  after-expt  
13.    (restore continue)  
14.    (assign val (op *) (reg b) (reg val))  
15.    (goto (reg continue))  
16.  base-case  
17.    (assign val (const 1))  
18.    (goto (reg continue))  
19.  expt-done)  

(controller (assign continue (label expt-done)) expt-loop (test (op =) (reg n) (const 0)) ;; Test for (= n 0) (branch (label base-case)) ;; We only need to save continue as b is constant throughout ;; and the successive values of n are not used for calculation. (save continue) (assign n (op -) (reg n) (const 1)) (assign continue (label after-expt)) (goto (label expt-loop)) after-expt (restore continue) (assign val (op *) (reg b) (reg val)) (goto (reg continue)) base-case (assign val (const 1)) (goto (reg continue)) expt-done)
b. Iterative exponentiation.

view plainprint?

1. (controller   
2.  (assign counter (reg n))  
3.  (assign product (const 1))  
4.  expt-loop  
5.    (test (op =) (reg counter) (const 0))  
6.    (branch (label expt-done))  
7.    ;; We don't have to save any value in the stack.  
8.    ;; The result of exponentiation will be available in register product at the end of calculation.  
9.    (assign counter (op -) (reg counter) (const 1))  
10.    (assign product (op *) (reg b) (reg product))  
11.    (goto (label expt-loop))  
12.  expt-done)  

(controller (assign counter (reg n)) (assign product (const 1)) expt-loop (test (op =) (reg counter) (const 0)) (branch (label expt-done)) ;; We don't have to save any value in the stack. ;; The result of exponentiation will be available in register product at the end of calculation. (assign counter (op -) (reg counter) (const 1)) (assign product (op *) (reg b) (reg product)) (goto (label expt-loop)) expt-done)
Exercise 5.5. Hand-simulate the factorial and Fibonacci machines, using some nontrivial input (requiring execution of at least one recursive call). Show the contents of the stack at each significant point in the execution.

Answer: (factorial 3)
Init:
continue = fact-done; n = 3;


Iteration round 1.
Test (= n 1) fails.
Stack: continue => fact-done; n=> 3.
n = 2; continue = after-fact.


Iteration round 2.
Test (= n 1) fails.
Stack: continue => after-fact, fact-done; n=> 2, 3.
n = 1; continue = after-fact.


Iteration round 3.
Test (= n 1) succeeds. Proceed to base-case
val = 1; proceed to after-fact


After-fact round 1.
n <= 2. continue <= after-fact.
Stack: continue => fact-done; n=> 3.
val = 2 * 1 = 2


After-fact round 2.
n <= 3. continue <= fact-done.
Stack: empty
val = 3 * 2 = 6
Proceed to fact-done


Exercise 5.6. Ben Bitdiddle observes that the Fibonacci machine's controller sequence has an extra save and an extra restore, which can be removed to make a faster machine. Where are these instructions?

Answer: The redundant save and restore statements occur in the set of instructions labeled afterfib-n-1. The (restore continue) and (save continue) statements that occur at the top can be removed as the value of continue will never change between restore and save calls. The machine can be now re-written as follows:

view plainprint?

1. (controller  
2.    (assign continue (label fib-done))  
3.  fib-loop  
4.    (test (op <) (reg n) (const 2))  
5.    (branch (label immediate-answer))  
6.    ;; set up to compute Fib(n - 1)  
7.    (save continue)  
8.    (assign continue (label afterfib-n-1))  
9.    (save n)                           ; save old value of n  
10.    (assign n (op -) (reg n) (const 1)); clobber n to n - 1  
11.    (goto (label fib-loop))            ; perform recursive call  
12.  afterfib-n-1                         ; upon return, val contains Fib(n - 1)  
13.    (restore n)  
14.    ;; (restore continue) ;; **REDUNDANT**  
15.    ;; set up to compute Fib(n - 2)  
16.    (assign n (op -) (reg n) (const 2))  
17.    ;; (save continue)    ;; **REDUNDANT**  
18.    (assign continue (label afterfib-n-2))  
19.    (save val)                         ; save Fib(n - 1)  
20.    (goto (label fib-loop))  
21.  afterfib-n-2                         ; upon return, val contains Fib(n - 2)  
22.    (assign n (reg val))               ; n now contains Fib(n - 2)  
23.    (restore val)                      ; val now contains Fib(n - 1)  
24.    (restore continue)  
25.    (assign val                        ;  Fib(n - 1) +  Fib(n - 2)  
26.            (op +) (reg val) (reg n))   
27.    (goto (reg continue))              ; return to caller, answer is in val  
28.  immediate-answer  
29.    (assign val (reg n))               ; base case:  Fib(n) = n  
30.    (goto (reg continue))  
31.  fib-done)  

(controller (assign continue (label fib-done)) fib-loop (test (op <) (reg n) (const 2)) (branch (label immediate-answer)) ;; set up to compute Fib(n - 1) (save continue) (assign continue (label afterfib-n-1)) (save n) ; save old value of n (assign n (op -) (reg n) (const 1)); clobber n to n - 1 (goto (label fib-loop)) ; perform recursive call afterfib-n-1 ; upon return, val contains Fib(n - 1) (restore n) ;; (restore continue) ;; **REDUNDANT** ;; set up to compute Fib(n - 2) (assign n (op -) (reg n) (const 2)) ;; (save continue) ;; **REDUNDANT** (assign continue (label afterfib-n-2)) (save val) ; save Fib(n - 1) (goto (label fib-loop)) afterfib-n-2 ; upon return, val contains Fib(n - 2) (assign n (reg val)) ; n now contains Fib(n - 2) (restore val) ; val now contains Fib(n - 1) (restore continue) (assign val ; Fib(n - 1) + Fib(n - 2) (op +) (reg val) (reg n)) (goto (reg continue)) ; return to caller, answer is in val immediate-answer (assign val (reg n)) ; base case: Fib(n) = n (goto (reg continue)) fib-done)

SICP Section 4.4 Logic Programming

Exercise 4.55. Give simple queries that retrieve the following information from the data base: a. all people supervised by Ben Bitdiddle;

b. the names and jobs of all people in the accounting division;

c. the names and addresses of all people who live in Slumerville.

Answer: a. All people supervised by Ben Bitdiddle.

1. (supervisor ?name (Bitdiddle Ben))  

(supervisor ?name (Bitdiddle Ben))
b. The names and jobs of all people in the accounting division.

1. (job ?name (accounting . ?type))  

(job ?name (accounting . ?type))
c. The names and addresses of all people who line in Slumerville.

1. (address ?name (Slumerville . ?home-address))  

(address ?name (Slumerville . ?home-address))
Exercise 4.56. 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.

Answer: a.

1. (and (supervisor ?person (Bitdiddle Ben))  
2.      (address ?person ?details))  

(and (supervisor ?person (Bitdiddle Ben)) (address ?person ?details))
b.

1. (and (salary (Bitdiddle Ben) ?bens-salary)  
2.      (salary ?person ?amount)  
3.      (lisp-value < ?amount ?bens-salary))  

(and (salary (Bitdiddle Ben) ?bens-salary) (salary ?person ?amount) (lisp-value < ?amount ?bens-salary))
c.

1. (and (supervisor ?person ?boss)  
2.      (not (job ?boss (computer . ?details)))  
3.      (job ?boss ?boss-job-details))  

(and (supervisor ?person ?boss) (not (job ?boss (computer . ?details))) (job ?boss ?boss-job-details))
Exercise 4.57. 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:

a. all people who can replace Cy D. Fect;

b. all people who can replace someone who is being paid more than they are, together with the two salaries.

Answer:

1. (rule (can-replace ?person1 ?person2)  
2.       (and (or (and (job ?person1 ?details)  
3.                     (job ?person2 ?details))  
4.                (and (job ?person1 ?person1-job)  
5.                     (job ?person2 ?person2-job)  
6.                     (can-do ?person1-job ?person2-job)))  
7.            (not (same ?person1 ?person2))))  

(rule (can-replace ?person1 ?person2) (and (or (and (job ?person1 ?details) (job ?person2 ?details)) (and (job ?person1 ?person1-job) (job ?person2 ?person2-job) (can-do ?person1-job ?person2-job))) (not (same ?person1 ?person2))))
a.

1. (can-replace ?person (Fect Cy D))  

(can-replace ?person (Fect Cy D))
b.

1. (and (salary ?person1 ?amount1)  
2.      (salary ?person2 ?amount2)  
3.      (lisp-value > ?amount2 ?amount1)  
4.      (can-replace ?person1 ?person2))  

(and (salary ?person1 ?amount1) (salary ?person2 ?amount2) (lisp-value > ?amount2 ?amount1) (can-replace ?person1 ?person2))
Exercise 4.58. 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.

Answer:

view plainprint?

1. (rule (bigshot ?person ?division)  
2.       (and (job ?person (?division . ?details1))  
3.            (or   
4.             ;; person does not have a supervisor  
5.             (not (supervisor ?person ?boss))  
6.              
7.             ;; person's supervisor is from another division  
8.             (and (supervisor ?person ?boss)  
9.                  (job ?boss (?another-division . ?details2))  
10.                  (not (same ?division ?another-division))))))  

(rule (bigshot ?person ?division) (and (job ?person (?division . ?details1)) (or ;; person does not have a supervisor (not (supervisor ?person ?boss)) ;; person's supervisor is from another division (and (supervisor ?person ?boss) (job ?boss (?another-division . ?details2)) (not (same ?division ?another-division))))))
Exercise 4.59. 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:

1. (meeting accounting (Monday 9am))  
2. (meeting administration (Monday 10am))  
3. (meeting computer (Wednesday 3pm))  
4. (meeting administration (Friday 1pm))  

(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.

1. (meeting whole-company (Wednesday 4pm))  

(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.

1. (rule (meeting-time ?person ?day-and-time)  
2.       <rule-body>)  

(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?

Answer: a.

1. (meeting ?department (Friday ?time))  

(meeting ?department (Friday ?time))
b.

1. (rule (meeting-time ?person ?day-and-time)  
2.       (or (and (job ?person (?division . ?title))  
3.                (meeting ?division ?day-and-time))  
4.           (meeting whole-company ?day-and-time)))  

(rule (meeting-time ?person ?day-and-time) (or (and (job ?person (?division . ?title)) (meeting ?division ?day-and-time)) (meeting whole-company ?day-and-time)))
c.

1. (meeting-time (Hacker Alyssa P) (Wednesday . ?time))  

(meeting-time (Hacker Alyssa P) (Wednesday . ?time))
Exercise 4.60. By giving the query

1. (lives-near ?person (Hacker Alyssa P))  

(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

1. (lives-near ?person-1 ?person-2)  

(lives-near ?person-1 ?person-2)
she notices that each pair of people who live near each other is listed twice; for example,

1. (lives-near (Hacker Alyssa P) (Fect Cy D))  
2. (lives-near (Fect Cy D) (Hacker Alyssa P))  

(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.

Answer: Lives-near works by showing all entries in the database that matches a certain pattern. If person1 and person2 match the pattern by virtue of being neighbors then the reverse is also true and therefore person2 and person1 also meet the pattern. There is no way to prevent this given the current definition of the rule.

The rule can be changed to add an artificial constraint to avoid the names being printed twice. For instance we can compare the lengths of the names of the people and print only those results where the name of person1 is longer than the name of person2.

1. (rule (lives-near ?person-1 ?person-2)  
2.       (and (address ?person-1 (?town . ?rest-1))  
3.            (address ?person-2 (?town . ?rest-2))  
4.            (not (same ?person-1 ?person-2))  
5.            (lisp-value string>? ?person-1 ?person-2)))  

(rule (lives-near ?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 string>? ?person-1 ?person-2)))
String>? is a built in operator which compares strings according to the order of the characters they contain.

Exercise 4.61. The following rules implement a next-to relation that finds adjacent elements of a list:

1. (rule (?x next-to ?y in (?x ?y . ?u)))  
2.   
3. (rule (?x next-to ?y in (?v . ?z))  
4.       (?x next-to ?y in ?z))  

(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?

1. (?x next-to ?y in (1 (2 3) 4))  
2.   
3. (?x next-to 1 in (2 1 3 1))  

(?x next-to ?y in (1 (2 3) 4)) (?x next-to 1 in (2 1 3 1))

Answer:

view plainprint?

1. ;; (?x next-to ?y in (1 (2 3) 4))  
2. (1 (2 3))  
3. ((2 3) 4)  
4.   
5. ;; (?x next-to 1 in (2 1 3 1))  
6. (2 1)  
7. (3 1)  
8. (1 3)  

;; (?x next-to ?y in (1 (2 3) 4)) (1 (2 3)) ((2 3) 4) ;; (?x next-to 1 in (2 1 3 1)) (2 1) (3 1) (1 3)
Exercise 4.62. Define rules to implement the last-pair operation of 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)) ?

Answer:

view plainprint?

1. (rule (last-pair (?x) (?x)))  
2.   
3. (rule (last-pair (?y . ?rest) ?x)  
4.       (last-pair ?rest ?x))  
5.   
6. ;; (last-pair (3) ?x) => (last-pair (3) (3))  
7. ;; (last-pair (1 2 3) ?x) => (last-pair (1 2 3) (3))  
8. ;; (last-pair (2 ?x) (3)) => (last-pair (2 3) (3))  
9.   
10. ;; (last-pair ?x (3)) does not return. The system goes into an infinite loop.  

(rule (last-pair (?x) (?x))) (rule (last-pair (?y . ?rest) ?x) (last-pair ?rest ?x)) ;; (last-pair (3) ?x) => (last-pair (3) (3)) ;; (last-pair (1 2 3) ?x) => (last-pair (1 2 3) (3)) ;; (last-pair (2 ?x) (3)) => (last-pair (2 3) (3)) ;; (last-pair ?x (3)) does not return. The system goes into an infinite loop.
Exercise 4.63. The following data base (see Genesis 4) traces the genealogy of the descendants of Ada back to Adam, by way of Cain:

1. (son Adam Cain)  
2. (son Cain Enoch)  
3. (son Enoch Irad)  
4. (son Irad Mehujael)  
5. (son Mehujael Methushael)  
6. (son Methushael Lamech)  
7. (wife Lamech Ada)  
8. (son Ada Jabal)  
9. (son Ada Jubal)  

(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 exercise 4.69 for some rules to deduce more complicated relationships.)

Answer:

view plainprint?

1. (rule (grandson ?g ?s)  
2.       (and (son ?g ?f)  
3.            (son ?f ?s)))  
4.   
5. (rule (son ?m ?s)  
6.       (and (wife ?m ?w)  
7.            (son ?w ?s)))  
8.   
9. ;;;; Query input:  
10. ;(grandson Methushael ?x)  
11.   
12. ;;;; Query results:  
13. ;(grandson Methushael Jubal)  
14. ;(grandson Methushael Jabal)  

(rule (grandson ?g ?s) (and (son ?g ?f) (son ?f ?s))) (rule (son ?m ?s) (and (wife ?m ?w) (son ?w ?s))) ;;;; Query input: ;(grandson Methushael ?x) ;;;; Query results: ;(grandson Methushael Jubal) ;(grandson Methushael Jabal)
Exercise 4.64. Louis Reasoner mistakenly deletes the outranked-by rule (section 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

1. (rule (outranked-by ?staff-person ?boss)  
2.       (or (supervisor ?staff-person ?boss)  
3.           (and (outranked-by ?middle-manager ?boss)  
4.                (supervisor ?staff-person ?middle-manager))))  

(rule (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

1. (outranked-by (Bitdiddle Ben) ?who)  

(outranked-by (Bitdiddle Ben) ?who)
After answering, the system goes into an infinite loop. Explain why.

Answer: I'll use the procedure explained in section 4.4.2 (pg. 460) to explore how this query is executed.

1. Unify query with the conclusion of the rule to form, if successful, an extension of the original frame. By unifying the query (outranked-by (Bitiddle Ben) ?who) with the conclusion of the rule (outranked-by ?staff-person ?boss) we get a frame where ?staff-person and ?boss are bound to (Bitiddle Ben) and ?who respectively.

2. Relative to the extended frame, evaluate the query formed by the body of the rule. The query formed by the body of the rule in this case is:

1. (or (superior ?staff-person ?boss)  
2.     (and (outranked-by ?middle-manager ?boss)  
3.          (superior ?staff-person ?middle-manager)))  

(or (superior ?staff-person ?boss) (and (outranked-by ?middle-manager ?boss) (superior ?staff-person ?middle-manager)))
The first argument to or immediately produces a match from the database: (supervisor (Bitiddle Ben) (Warbucks Oliver)). This result is printed. The second argument to or is the and sub-query, the first part of which uses the outranked-by rule. This leads the interpreter to again evaluate the rule body resulting in a frame where ?staff-person and ?boss are bound to to ?middle-manager and ?who respectively. This once again leads to the evaluation of outranked-by and so on infinitely.

I can see how the infinite loop is triggered. What I don't understand is how the first part of or, i.e., (superior ?staff-person ?boss) is not matched in these infinite calls and their results printed (like how the first result got printed). Perhaps I'll be able to explain it once I study how the query interpreter is implemented.

Exercise 4.65. 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 4.4.1):

1. (wheel ?who)  

(wheel ?who)
To his surprise, the system responds

view plainprint?

1. ;;; Query results:  
2. (wheel (Warbucks Oliver))  
3. (wheel (Bitdiddle Ben))  
4. (wheel (Warbucks Oliver))  
5. (wheel (Warbucks Oliver))  
6. (wheel (Warbucks Oliver))  

;;; Query results: (wheel (Warbucks Oliver)) (wheel (Bitdiddle Ben)) (wheel (Warbucks Oliver)) (wheel (Warbucks Oliver)) (wheel (Warbucks Oliver))
Why is Oliver Warbucks listed four times?

Answer: Once again I'll use the procedure explained in section 4.4.2 (pg. 460) to explore how this query is executed.

1. Unify query with the conclusion of the rule to form, if successful, an extension of the original frame. By unifying the query (wheel ?who) with the conclusion of the rule (wheel ?person) we get a frame where ?person is bound to ?who.

2. Relative to the extended frame, evaluate the query formed by the body of the rule. The query formed by the body of the rule in this case is:

1. (and (supervisor ?middle-manager ?person)  
2.      (supervisor ?x ?middle-manager))  

(and (supervisor ?middle-manager ?person) (supervisor ?x ?middle-manager))
This query produces multiple matches, one each for every instance of a supervisor-employee pair where the supervisor reports to ?person.

1. (and (supervisor (Scrooge Eben) (Warbucks Oliver)) (supervisor (Cratchet Robert) (Scrooge Eben)))  
2. (and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (supervisor (Tweakit Lem E) (Bitdiddle Ben)))  
3. (and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (supervisor (Reasoner Louis) (Hacker Alyssa P)))  
4. (and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (supervisor (Fect Cy D) (Bitdiddle Ben)))  
5. (and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))  

(and (supervisor (Scrooge Eben) (Warbucks Oliver)) (supervisor (Cratchet Robert) (Scrooge Eben))) (and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (supervisor (Tweakit Lem E) (Bitdiddle Ben))) (and (supervisor (Hacker Alyssa P) (Bitdiddle Ben)) (supervisor (Reasoner Louis) (Hacker Alyssa P))) (and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (supervisor (Fect Cy D) (Bitdiddle Ben))) (and (supervisor (Bitdiddle Ben) (Warbucks Oliver)) (supervisor (Hacker Alyssa P) (Bitdiddle Ben)))
The rule conclusion is instantiated with the value for ?person for every result produced by the query. Therefore we find that Oliver Warbuck's name pops up four times.

Exercise 4.66. 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

1. (sum ?amount  
2.      (and (job ?x (computer programmer))  
3.           (salary ?x ?amount)))  

(sum ?amount (and (job ?x (computer programmer)) (salary ?x ?amount)))
In general, Ben's new system allows expressions of the form

1. (accumulation-function <variable>  
2.                        <query pattern>)  

(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 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.

Answer: Consider the following application of Ben's new system:

1. (sum ?amount  
2.      (and (wheel ?who)  
3.           (salary ?who ?amount)))  

(sum ?amount (and (wheel ?who) (salary ?who ?amount)))
This query is meant to calculate the sum of the salaries paid to "wheels". As we saw in exercise 4.65 the (wheel ?who) query will repeat Oliver Warbuck's name. Consequently his salary will be added up multiple times. This is the error Ben has realized - that queries can repeat the results.

One way to solve Ben's problem would be to ensure that the query pattern produces unique results. This can be done by implementing the equivalent of distinct? for the query results.

Exercise 4.68. Define rules to implement the reverse operation of 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)) ?

Answer:

1. (assert!  
2.  (rule (reverse (?first . ?rest) ?y)  
3.        (and (reverse ?rest ?reverse-of-rest)  
4.             (append-to-form ?reverse-of-rest (?first) ?y))))  
5.   
6. (assert!  
7.  (rule (reverse (?x) (?x))))  

(assert! (rule (reverse (?first . ?rest) ?y) (and (reverse ?rest ?reverse-of-rest) (append-to-form ?reverse-of-rest (?first) ?y)))) (assert! (rule (reverse (?x) (?x))))
(reverse (1 2 3) ?x) returns (reverse (1 2 3) (3 2 1)).

(reverse ?x (1 2 3)) prints (reverse (3 2 1) (1 2 3)) and goes into an infinite loop if the order of the reverse rules is as shown. If the second rule is added first then the evaluator goes into infinite loop without printing any result.

Exercise 4.69. 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).

Answer:

1. (assert!  
2.  (rule (grandson ?g ?s)  
3.        (and (son ?g ?f)  
4.             (son ?f ?s))))  
5.   
6. (assert!  
7.  (rule (son ?m ?s)  
8.        (and (wife ?m ?w)  
9.             (son ?w ?s))))  
10. (assert!  
11.  (rule (last-pair (?x) (?x))))  
12.   
13. (assert!  
14.  (rule (last-pair (?y . ?rest) ?x)  
15.        (last-pair ?rest ?x)))  
16.   
17. (assert!  
18.  (rule (ends-in-grandson ?list)  
19.        (last-pair ?list (grandson))))  
20.   
21. (assert!  
22.  (rule ((grandson) ?a ?d) (grandson ?a ?d)))  
23.   
24. (assert!  
25.  (rule ((great . ?rel) ?x ?person)  
26.        (and (and (son ?x ?son-of-x)  
27.                  (?rel ?son-of-x ?person))  
28.             (ends-in-grandson ?rel))))  

(assert! (rule (grandson ?g ?s) (and (son ?g ?f) (son ?f ?s)))) (assert! (rule (son ?m ?s) (and (wife ?m ?w) (son ?w ?s)))) (assert! (rule (last-pair (?x) (?x)))) (assert! (rule (last-pair (?y . ?rest) ?x) (last-pair ?rest ?x))) (assert! (rule (ends-in-grandson ?list) (last-pair ?list (grandson)))) (assert! (rule ((grandson) ?a ?d) (grandson ?a ?d))) (assert! (rule ((great . ?rel) ?x ?person) (and (and (son ?x ?son-of-x) (?rel ?son-of-x ?person)) (ends-in-grandson ?rel))))
Exercise 4.70. 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 3.5.2: (define ones (cons-stream 1 ones)).

view plainprint?

1. (define (add-assertion! assertion)  
2.   (store-assertion-in-index assertion)  
3.   (set! THE-ASSERTIONS  
4.         (cons-stream assertion THE-ASSERTIONS))  
5.   'ok)  

(define (add-assertion! assertion) (store-assertion-in-index assertion) (set! THE-ASSERTIONS (cons-stream assertion THE-ASSERTIONS)) 'ok)

Answer: The implementation given in the question uses THE-ASSERTIONS in the cons-stream operation. This defines THE-ASSERTIONS recursively as a combination of the given assertion and THE-ASSERTIONS. Such a definition would make THE-ASSERTIONS an infinite stream (whose stream-car is the new assertion) rather than a finite stream of assertions. The original definition creates a finite stream by joining the given assertion with the empty stream.

Exercise 4.71. Louis Reasoner wonders why the simple-query and disjoin procedures (section 4.4.4.2) are implemented using explicit delay operations, rather than being defined as follows:

view plainprint?

1. (define (simple-query query-pattern frame-stream)  
2.   (stream-flatmap  
3.    (lambda (frame)  
4.      (stream-append (find-assertions query-pattern frame)  
5.                     (apply-rules query-pattern frame)))  
6.    frame-stream))  
7.   
8. (define (disjoin disjuncts frame-stream)  
9.   (if (empty-disjunction? disjuncts)  
10.       the-empty-stream  
11.       (interleave  
12.        (qeval (first-disjunct disjuncts) frame-stream)  
13.        (disjoin (rest-disjuncts disjuncts) frame-stream))))  

(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?

Answer: The call to delay application of rules will prevent infinite looping in cases where the rules recursively rely on themselves and/or assertions. In such cases the delay will ensure that results matching the assertions in the database are printed before the rules get evaluated rather than going into an infinite loop immediately.

Exercise 4.72. 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 section 3.5.3?)

Answer: The hint is sufficient to get you started towards the answer. Interleaving was originally introduced to handle multiple infinite streams. Interleaving prevented any one stream being explored infinitely and ensured that values from all component streams were explored in turn. These reasons are still valid here in the case of stream-flatmap and disjoin.

Exercise 4.73. Why does flatten-stream use delay explicitly? What would be wrong with defining it as follows:

view plainprint?

1. (define (flatten-stream stream)  
2.   (if (stream-null? stream)  
3.       the-empty-stream  
4.       (interleave  
5.        (stream-car stream)  
6.        (flatten-stream (stream-cdr stream)))))  

(define (flatten-stream stream) (if (stream-null? stream) the-empty-stream (interleave (stream-car stream) (flatten-stream (stream-cdr stream)))))

Answer: Flatten-stream internally calls the interleave procedure. The first argument to interleave is the stream-car of the input stream. The second argument is the result of flattening the stream-cdr of the input stream. In the absence of an explicit delay the second argument is evaluated before being passed to interleave. As the second argument recursively calls flatten-stream this leads to a loop. The loop will not terminate until the input stream is exhausted. In case of infinite streams this leads to an infinite loop.

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 the empty stream or a singleton stream, so no interleaving is needed when combining these streams.

a. Fill in the missing expressions in Alyssa's program.

view plainprint?

1. (define (simple-stream-flatmap proc s)  
2.   (simple-flatten (stream-map proc s)))  
3.   
4. (define (simple-flatten stream)  
5.   (stream-map <??>  
6.               (stream-filter <??> stream)))  

(define (simple-stream-flatmap proc s) (simple-flatten (stream-map proc s))) (define (simple-flatten stream) (stream-map <??> (stream-filter <??> stream)))
b. Does the query system's behavior change if we change it in this way?

Answer: a.

view plainprint?

1. (define (simple-stream-flatmap proc s)  
2.   (simple-flatten (stream-map proc s)))  
3.   
4. (define (simple-flatten stream)  
5.   (stream-map stream-car  
6.               (stream-filter (lambda (s) (not (stream-null? s))) stream)))  

(define (simple-stream-flatmap proc s) (simple-flatten (stream-map proc s))) (define (simple-flatten stream) (stream-map stream-car (stream-filter (lambda (s) (not (stream-null? s))) stream)))
b. The changes will not affect the behavior of the query system. The end result of simple-stream-flatmap remains a stream of singleton streams in the same order as before the changes. Therefore the overall behavior should remain unchanged.

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,

1. (unique (job ?x (computer wizard)))  

(unique (job ?x (computer wizard)))
should print the one-item stream

1. (unique (job (Bitdiddle Ben) (computer wizard)))  

(unique (job (Bitdiddle Ben) (computer wizard)))
since Ben is the only computer wizard, and

1. (unique (job ?x (computer programmer)))  

(unique (job ?x (computer programmer)))
should print the empty stream, since there is more than one computer programmer. Moreover,

1. (and (job ?x ?j) (unique (job ?anyone ?j)))  

(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

1. (put 'unique 'qeval uniquely-asserted)  

(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.

Answer:

view plainprint?

1. (define (unique-query operands)  
2.   (car operands))  
3.   
4. (define (singleton-stream? s)  
5.   (and (not (stream-null? s))  
6.        (stream-null? (stream-cdr s))))  
7.          
8. (define (uniquely-asserted operands frame-stream)  
9.   (stream-flatmap  
10.    (lambda (frame)  
11.      (let ((ext (qeval (unique-query operands) (singleton-stream frame))))  
12.        (if (singleton-stream? ext) ext the-empty-stream)))  
13.    frame-stream))  
14.   
15. ;;; Query input:  
16. (and (supervisor ?x ?boss)  
17.      (unique (supervisor ?anyone ?boss)))  
18.   
19. ;;; Query results:  
20. (and (supervisor (Cratchet Robert) (Scrooge Eben)) (unique (supervisor (Cratchet Robert) (Scrooge Eben))))  
21. (and (supervisor (Reasoner Louis) (Hacker Alyssa P)) (unique (supervisor (Reasoner Louis) (Hacker Alyssa P))))  

(define (unique-query operands) (car operands)) (define (singleton-stream? s) (and (not (stream-null? s)) (stream-null? (stream-cdr s)))) (define (uniquely-asserted operands frame-stream) (stream-flatmap (lambda (frame) (let ((ext (qeval (unique-query operands) (singleton-stream frame)))) (if (singleton-stream? ext) ext the-empty-stream))) frame-stream)) ;;; Query input: (and (supervisor ?x ?boss) (unique (supervisor ?anyone ?boss))) ;;; Query results: (and (supervisor (Cratchet Robert) (Scrooge Eben)) (unique (supervisor (Cratchet Robert) (Scrooge Eben)))) (and (supervisor (Reasoner Louis) (Hacker Alyssa P)) (unique (supervisor (Reasoner Louis) (Hacker Alyssa P))))
Exercise 4.76. Our implementation of and as a series combination of queries (figure 4.5) 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.

Answer:

view plainprint?

1. (define (conjoin conjuncts frame-stream)  
2.   (if (empty-conjunction? conjuncts)  
3.       frame-stream  
4.       (let ((fs1 (qeval (first-conjunct conjuncts) frame-stream))  
5.             (fs2 (conjoin (rest-conjuncts conjuncts) frame-stream)))  
6.         (compare-and-merge-streams fs1 fs2))))  
7.   
8. (define (compare-and-merge-streams fs1 fs2)  
9.   (stream-flatmap  
10.    (lambda (f1)  
11.      (stream-filter  
12.       (lambda (frame) (not (equal? frame 'failed)))  
13.       (stream-map  
14.        (lambda (f2)  
15.          (merge-frames f1 f2))  
16.        fs2)))  
17.    fs1))  
18.   
19. (define (merge-frames f1 f2)  
20.   (if (null? f1)  
21.       f2  
22.       (let ((variable (caar f1))  
23.             (value (cdar f1)))  
24.         (let ((extension (extend-if-possible variable value f2)))  
25.           (if (equal? extension 'failed)  
26.               'failed  
27.               (merge-frames (cdr f1) extension))))))  

(define (conjoin conjuncts frame-stream) (if (empty-conjunction? conjuncts) frame-stream (let ((fs1 (qeval (first-conjunct conjuncts) frame-stream)) (fs2 (conjoin (rest-conjuncts conjuncts) frame-stream))) (compare-and-merge-streams fs1 fs2)))) (define (compare-and-merge-streams fs1 fs2) (stream-flatmap (lambda (f1) (stream-filter (lambda (frame) (not (equal? frame 'failed))) (stream-map (lambda (f2) (merge-frames f1 f2)) fs2))) fs1)) (define (merge-frames f1 f2) (if (null? f1) f2 (let ((variable (caar f1)) (value (cdar f1))) (let ((extension (extend-if-possible variable value f2))) (if (equal? extension 'failed) 'failed (merge-frames (cdr f1) extension))))))
Note: I am skipping the last three problems of this chapter and moving on to Chapter 5. I will revisit them after completing Chapter 5.