Eating "nachos" in Bangalore

Wikipedia defines Nachos as "a popular food based on nixtamalized corn, of Mexican origin". I've had nachos before, in India as well as outside it. The one thing common to all my experiences was corn. No matter where I ate, nachos always meant corn (chips). Then came California Burrito (specifically the one in Koramangala, Bangalore). I had lunch there today and made the mistake of ordering nachos. They served "nachos" made of maida! For those not in the know, maida is "is a finely milled and refined and bleached wheat flour". If you have ever had samosas, you probably have tasted maida. Samosa shells are most commonly made of maida.

The "nachos" were unappetizing to say the least. Imagine eating samosa shells with guacamole and sour cream! Someone (not me) asked about the maida and was told that everything they served had been "adapted for India". What rubbish! If you must "Indianize" (it still makes no sense to me), then at least show the courtesy of announcing it on your menu.

I am told that the story is the same for their burritos and tacos. Everything tastes like Indian rotis/chapatis because of the wheat. Now I'm fine with people customizing their food but I expect to be told upfront if the food being served has been customized. I took 'California Burrito' and 'nachos' at face value and did not get what I paid for. I won't be visiting them again. Taco Bell is not far away and looks like a much better choice.

Quick review: Sapna book house Koramangala

I checked out Sapna book house in Koramangala today. Sapna is one of the old players in the book store market. They were in Bangalore way before newer stores like Landmark and Crossword opened branches here. The Koramangala branch is the latest in their steadily expanding chain.

The first thing that caught my eye was the layout of the place. The shop is located in a brand new four storey building served by a single elevator. Ground and first floors stock stationery, movies, computer games and the like. Books are stocked in the second and third floors with the latter dedicated to technical and text books. The layout of the building reminded me of old Gangaram's in MG Road. Specifically the multi-floor building, the lone elevator and the distribution of wares across floors. Unlike G's however Sapna has kept the place clean, orderly, and dust free. No peeling paint or books stacked in the aisles here. They also have clean if tiny restrooms for men and women.

You can browse the collection reasonably well without needing help from staff. This is nice for an "old format" book store - I've rarely managed to dig up books in Gangaram's without help from their employees.

My first target was the history section. Unfortunately there isn't one. There is a section for biographies but that's about it. Sapna uses the non-fiction section as a catch-all for everything from "How to improve your sex life" to "Rise and Fall of the Third Reich" (no pun intended). Contrast this with say any of The Strand, Landmark or Crossword. All three of them boast decent sized history sections. Landmark even has a separate section for military history.

The fiction section contains mostly popular books. I thought it compared well with other bookstores. A rather sparse science fiction section is housed together with the humor section. Perhaps they find science fiction a joke? :P There is no separate grouping for fantasy titles. Again Landmark, Crossword etc. make this distinction.

I found Sapna's collection of comics rather lacking. While the staples are all there - The Adventures of Tintin, Asterix and Obelix, Amar Chithra Katha (Amar Chithra Katha even a separate section) there isn't much else. A few issues of Spiderman were placed below a boxed set of Maus. No sign of other popular DC or Marvel volumes let alone comic novels like Sandman, V for Vendetta or 100 Bullets, to name a few. I couldn't find any Anime/Manga titles either.

Fourth floor sets aside a lot of space to technical and text books. All computer science books are grouped under "computers". There are a dozen shelves titled computers making it tricky to look up specific books.

If there is one area that Sapna beats the competition it is in Kannada books. They have dedicated half a dozen shelves to stock Kannada volumes. I can't comment on the quality of the titles though.

Sapna is one of those bookstores who don't seem to expect their customers to read the books in the store. There are no chairs in the aisles, not even plastic footstools. Even the more crowded Landmark with its narrower aisles has a few cushioned seats, not to mention the comfortable upholstered sofas and chairs in Crossword.

In spite of the five floors there is only one elevator. Most of the customers trudged up and down the stairs. A sign board placed next to the elevator doors asks customers to use they stairs if they like to stay fit. I think stairs are fine when you have two floors (Landmark and Crossword, the former even sports an escalator) but with four they become irritating.

Billing is in the ground floor. There are nine counters but only three accept payment. Others are variously for delivery, issuing membership cards etc. The payment and delivery counters are helpfully located next to each other.

Post script: I find a store modeled after ol' Gangaram's in a brand new building in Karamangala very surprising. I believe that there is a lot of demand for more bookstalls like Landmark and Crossword. Why don't old brands like Sapna try to meet that demand? Are they content to get by with volume sales alone?

A Comic Interlude

(While I work up courage and energy to write about other things)

The comic strip Frazz offers insightful and witty takes on (American) school life. Its calligraphic style and appearance of the eponymous character has fueled speculation that Frazz's creator Jef Mallett is actually Bill Watterson. Wikipedia seems to believe otherwise but hey, it is fun to speculate :P

Christmas day's Frazz comic offers a nod and wink to Calvin and Hobbes. Those who have enjoyed Calvin's early Christmas morning sorties to check for presents (and wake up his parents at ungodly hours) should get the reference easily enough.

Frazz (Dec 25, 2010)



Calvin and Hobbes (Dec 25, 199?)



I am not surprised - Jeff Mallett has acknowledged Watterson's influence and this is not the first time he has tipped his hat at Watterson.

In case you didn't know already, you can read both Frazz and Calvin and Hobbes online.

Re: Why Django Sucks

I recently came across this presentation on 'Why Django Sucks' and the associated discussion in Hacker News.

One of the key points raised was the perceived insularity of Django's core development community. In this context I have an anecdote to share about the core community or rather how the core community is frequently sloppy with the triage process.

I reported a Django bug and more importantly submitted tests for it. The bug languished for a while and eventually got fixed as a side effect of some changes. I reported this when I found out and a month later someone closed it. The regression tests, however, never made it to the test suite.

I believe that (1) people who take their time to give you a test are doing you a favor (2) one should never miss a chance to add a valid regression test to the suite.

I don't think there was any malice or hubris but the closed nature of the community did have something to do with this. I suspect that how fast and how thoroughly a bug is accepted and processed depends on who submits it. This will prove unhealthy in the long run.

So what can be done to address this? I believe that the bug triage process will benefit from more eyes. These don't have to be those of core developers but of people with the authority to take decisions on bugs. The community should also actively encourage people to submit more tests. Spread the word that this is as important as submitting patches.

Setting up a color scheme for Emacs

I am an Emacs newbie. I found a nice color theme for Emacs and wanted to set it as default. Following the instructions from the color-scheme homepage did not work. After some searching I found out a way to make it work.

I installed emacs-goodies-el using apt-get and put the following in my $HOME/.emacs.el file:
(require 'color-theme) (load-file "/path/to/color-theme-chocolate-rain.el") (color-theme-chocolate-rain)
I am reproducing this here in the hope that someone else will find it useful. I am running Emacs 22.2.1 (i486-pc-linux-gnu, GTK+ Version 2.16.1) of 2010-03-26 on palmer, modified by Ubuntu on Ubuntu Jaunty.

Indian Software quote of the day

A friend was asked to translate the following sentence to another language. The author was an "experienced senior software engineer" in a large Indian software services company.

"We were bit used to use remote desktop, but I will do the necessary actions to check this option and shift the full activity independent for the remote option."

Reading Notes #3: Ring Benchmark

I have been working my way through Joe Armstrong's Programming in Erlang. One of the exercises in chapter 8 is to write a "ring benchmark" in Erlang and any other language, compare the results and publish them.

Write a ring benchmark. Create N processes in a ring. Send a message round the ring M times so that a total of N * M messages get sent. Time how long this takes for different values of N and M. Write a similar program in some other programming language you are familiar with. Compare the results. Write a blog, and publish the results on the Internet!

Here are my benchmarks written in Erlang and Python respectively. I have presumed that the author meant sending messages synchronously; i.e. a message has to go around the whole ring before the next can be sent.

The Erlang version was easy to write. After all the language is designed to use a processes and messages paradigm of programming. Here is the source code:
-module(pring). %% %% Exported Functions %% -export([run/2]). -ifdef(debug). -define(DEBUG(Format, Args), io:format(Format, Args)). -else. -define(DEBUG(Format, Args), void). -endif. %% %% API Functions %% run(N, M) when is_integer(N), is_integer(M), N > 0, M > 0 -> time_it(fun() -> start(N, M) end). %% %% Local Functions %% time_it(F) when is_function(F) -> statistics(runtime), statistics(wall_clock), Result = F(), {_, CPUTime} = statistics(runtime), {_, ElapsedTime} = statistics(wall_clock), {Result, CPUTime/1000, ElapsedTime/1000}. start(N, M) when is_integer(N), is_integer(M), N > 0, M > 0 -> This = self(), First = spawn(fun() -> loop(This, This) end), ?DEBUG("Creating ~p for N = ~p~n", [First, N]), Last = create(First, First, N - 1), First ! {realign, First, Last}, First ! {relay, message, M, This}, receive {done, message} -> N * M end. create(First, Previous, N) when is_pid(First), is_pid(Previous), is_integer(N), N > 0 -> Pid = spawn(fun() -> loop(First, Previous) end), ?DEBUG("Creating ~p for N = ~p~n", [Pid, N]), create(First, Pid, N - 1); create(First, Previous, 0) when is_pid(First), is_pid(Previous) -> Previous. send_relay_message(Target, Message, M, ReportBack) when is_pid(Target), is_integer(M), is_pid(ReportBack) -> ?DEBUG("~p => ~p (M = ~p) ~n", [self(), Target, M + 1]), Target ! {relay, Message, M, ReportBack}. loop(First, Previous) when is_pid(First), is_pid(Previous) -> This = self(), receive {realign, NewFirst, NewPrevious} when is_pid(NewFirst), is_pid(NewPrevious) -> ?DEBUG("I am ~p Realigning: First ~p to ~p, Previous ~p to ~p~n", [This, First, NewFirst, Previous, NewPrevious]), loop(NewFirst, NewPrevious); {relay, Message, M, ReportBack} when is_integer(M), is_pid(ReportBack), This =:= First, M > 0 -> send_relay_message(Previous, Message, M - 1, ReportBack), loop(First, Previous); {relay, Message, M, ReportBack} when is_integer(M), is_pid(ReportBack), This =:= First, M =:= 0 -> ?DEBUG("I am ~p All rounds of relay over~n", [This]), ReportBack ! {done, Message}, void; {relay, Message, M, ReportBack} when is_integer(M), is_pid(ReportBack), This =/= First, M > 0 -> send_relay_message(Previous, Message, M, ReportBack), loop(First, Previous); {relay, Message, M, ReportBack} when is_integer(M), is_pid(ReportBack), This =/= First, M =:= 0 -> send_relay_message(Previous, Message, M, ReportBack), void; _Other -> ?DEBUG("I am ~p I don't understand ~p~n", [This, _Other]), loop(First, Previous) end.
I wrote the "other programming language" version in Python. The benchmark code makes use of Python's multiprocessing module (available in version 2.6 and above). Since I couldn't find any Erlang-style way to directly send a message to a process I chose to use a set of Queue objects to accomplish message passing. Each process has access to two queues - an "in" queue to receive messages and an "out" queue to relay them to the next process in the ring. Each process' "out" queue serves as the "in" for the next. After constructing N - 1 processes, a "plug" process is created to complete the process ring.
from multiprocessing import Process, Pipe, Queue import os, sys, argparse, time def create(first, target, in_queue, n): if n == 0: return in_queue out_queue = Queue() process = Process(target = target, args = (first, in_queue, out_queue,)) process.start() return create(first, target, out_queue, n - 1) def send_relay_message(queue, message, m, sender): queue.put(('relay', message, m,)) def loop(first, in_queue, out_queue): this = os.getpid() while True: input_data = in_queue.get() message_type = input_data[0] if message_type == 'realign': new_first = input_data[1] first = new_first elif message_type == 'relay': (message, m) = input_data[1:] if (this == first) and (m > 0): send_relay_message(out_queue, message, m - 1, this) elif (this == first) and (m == 0): return elif (this != first) and (m > 0): send_relay_message(out_queue, message, m, this) elif (this != first) and (m == 0): send_relay_message(out_queue, message, m, this) return else: print "I am %s. I do not understand %s" % (this, input_data) if __name__ == '__main__': parser = argparse.ArgumentParser(description = 'Run an N * M ring benchmark.') parser.add_argument('-n', '--processes', help ='Number of Processes') parser.add_argument('-m', '--messages', help = 'Number of Messages') args = parser.parse_args(sys.argv[1:] or []) n, m = map(int, (args.processes, args.messages)) start = time.time() this = os.getpid() first_in_queue = Queue() first_out_queue = Queue() first = Process(target = loop, args = [this, first_in_queue, first_out_queue]) first.start() last_out_queue = create(first.pid, loop, first_out_queue, n - 2) plug = Process(target = loop, args = [first, last_out_queue, first_in_queue]) plug.start() first_in_queue.put(('realign', first.pid)) first_in_queue.put(('relay', 'hello', m)) first.join() plug.join() end = time.time() print (end - start)
I am not entirely convinced that Python's processes are the equivalent of Erlang ones. Certainly threads are not the answer given their use of shared memory. Perhaps the difficulty in creating lightweight, shared-nothing processes in other languages is what the author wanted to illustrate using the example.

The results are shown below. The program was executed on a machine with a dual core Pentium, 2GB memory and running Ubuntu Jaunty.

Please note that:

• I could not increase the number of Python processes to the order of 1000 (10^3). When I tried to do this the program crashed with a number of errors.
• I got a curious QueueFeederThread exception when I executed the process for N = 100, M = 10000.

N	M	N * M	(Wall) Time in seconds
			Erlang	Python
10	10	10^2	0.0	0.0732
10	100	10^3	0.003	0.1795
100	100	10^4	0.036	2.3976
100	1000	10^5	0.242	12.2252
1000	1000	10^6	1.877	-
1000	10000	10^7	18.593	-
10000	10000	10^8	197.477	-

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.
% 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.
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:
def add_one(x): return x + 1
Usage:
>>> 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. 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. 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.
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:
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:
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:
# 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:
# 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:
{% 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/):
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:
{% 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
(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
(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:
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.
(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.
(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
(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.
(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.
(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.
(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.
(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.
(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.
(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:
;; 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:
(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:
(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.
(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.
(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.
(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:
(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
(set-breakpoint <machine> <label> <n>)
that sets a breakpoint just before the nth instruction after the given label. For example,
(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
(proceed-machine <machine>)
She should also be able to remove a specific breakpoint by means of
(cancel-breakpoint <machine> <label> <n>)
or to remove all breakpoints by means of
(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" :)
(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:
(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:
(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.
(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.
(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.
(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:
(define (expt b n) (if (= n 0) 1 (* b (expt b (- n 1)))))
b. Iterative exponentiation:
(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.
(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.
(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:
(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.
(supervisor ?name (Bitdiddle Ben))
b. The names and jobs of all people in the accounting division.
(job ?name (accounting . ?type))
c. The names and addresses of all people who line in Slumerville.
(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.
(and (supervisor ?person (Bitdiddle Ben)) (address ?person ?details))
b.
(and (salary (Bitdiddle Ben) ?bens-salary) (salary ?person ?amount) (lisp-value < ?amount ?bens-salary))
c.
(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:
(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.
(can-replace ?person (Fect Cy D))
b.
(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:
(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:
(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.
(meeting whole-company (Wednesday 4pm))
a. On Friday morning, Ben wants to query the data base for all the meetings that occur that day. What query should he use?

b. Alyssa P. Hacker is unimpressed. She thinks it would be much more useful to be able to ask for her meetings by specifying her name. So she designs a rule that says that a person's meetings include all whole-company meetings plus all meetings of that person's division. Fill in the body of Alyssa's rule.
(rule (meeting-time ?person ?day-and-time) <rule-body>)
c. Alyssa arrives at work on Wednesday morning and wonders what meetings she has to attend that day. Having defined the above rule, what query should she make to find this out?

Answer: a.
(meeting ?department (Friday ?time))
b.
(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.
(meeting-time (Hacker Alyssa P) (Wednesday . ?time))
Exercise 4.60. By giving the query
(lives-near ?person (Hacker Alyssa P))
Alyssa P. Hacker is able to find people who live near her, with whom she can ride to work. On the other hand, when she tries to find all pairs of people who live near each other by querying
(lives-near ?person-1 ?person-2)
she notices that each pair of people who live near each other is listed twice; for example,
(lives-near (Hacker Alyssa P) (Fect Cy D)) (lives-near (Fect Cy D) (Hacker Alyssa P))
Why does this happen? Is there a way to find a list of people who live near each other, in which each pair appears only once? Explain.

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.
(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:
(rule (?x next-to ?y in (?x ?y . ?u))) (rule (?x next-to ?y in (?v . ?z)) (?x next-to ?y in ?z))
What will the response be to the following queries?
(?x next-to ?y in (1 (2 3) 4)) (?x next-to 1 in (2 1 3 1))

Answer:
;; (?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:
(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:
(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:
(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
(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
(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:
(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):
(wheel ?who)
To his surprise, the system responds
;;; Query results: (wheel (Warbucks Oliver)) (wheel (Bitdiddle Ben)) (wheel (Warbucks Oliver)) (wheel (Warbucks Oliver)) (wheel (Warbucks Oliver))
Why is Oliver Warbucks listed four times?

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:
(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.
(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
(sum ?amount (and (job ?x (computer programmer)) (salary ?x ?amount)))
In general, Ben's new system allows expressions of the form
(accumulation-function <variable> <query pattern>)
where accumulation-function can be things like sum, average, or maximum. Ben reasons that it should be a cinch to implement this. He will simply feed the query pattern to qeval. This will produce a stream of frames. He will then pass this stream through a mapping function that extracts the value of the designated variable from each frame in the stream and feed the resulting stream of values to the accumulation function. Just as Ben completes the implementation and is about to try it out, Cy walks by, still puzzling over the wheel query result in exercise 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:
(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:
(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:
(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)).
(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:
(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:
(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.
(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.
(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,
(unique (job ?x (computer wizard)))
should print the one-item stream
(unique (job (Bitdiddle Ben) (computer wizard)))
since Ben is the only computer wizard, and
(unique (job ?x (computer programmer)))
should print the empty stream, since there is more than one computer programmer. Moreover,
(and (job ?x ?j) (unique (job ?anyone ?j)))
should list all the jobs that are filled by only one person, and the people who fill them.

There are two parts to implementing unique. The first is to write a procedure that handles this special form, and the second is to make qeval dispatch to that procedure. The second part is trivial, since qeval does its dispatching in a data-directed way. If your procedure is called uniquely-asserted, all you need to do is
(put 'unique 'qeval uniquely-asserted)
and qeval will dispatch to this procedure for every query whose type (car) is the symbol unique.

The real problem is to write the procedure uniquely-asserted. This should take as input the contents (cdr) of the unique query, together with a stream of frames. For each frame in the stream, it should use qeval to find the stream of all extensions to the frame that satisfy the given query. Any stream that does not have exactly one item in it should be eliminated. The remaining streams should be passed back to be accumulated into one big stream that is the result of the unique query. This is similar to the implementation of the not special form.

Test your implementation by forming a query that lists all people who supervise precisely one person.

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