Chapter 2: Building Abstractions with Data
Chapter 3 Modularity, Objects, and State
Chapter 4: Metalinguistic Abstraction
Chapter 5: Computing with Register Machines

Chapter 2: Building Abstractions with Data

Hierarchical Data and the Closure Property

Repersenting Sequences

Does it prints same as list to construct a sequence by conses?
```
(cons 1 (cons 2 (cons 3 (cons 4 '()))))
```
```
(list 1 2 3 4)
```
→Yeah, looks same.

Exercise 2.17

(define (last-pair items)               ;assume items is non empty list
  (let ((next-p (cdr items)))
    (if (null? next-p)
	items
	(last-pair next-p))))

Let's test with it

(last-pair (list 23 72 149 34))

It works.

Exercise 2.18

(define (reverse l)
  (define (iter l r)
    (if (null? l)
	r
	(iter (cdr l) (cons (car l) r))))
  (iter l nil))                         ; we don't know what nil is but assume we have

Or do not use nil explicitly analogous to last-pair.

(define (reverse l)                     ;assume that l is not empty
  (let ((next-p (cdr l)))
    (if (null? next-p)
	l
	(append (reverse next-p) (list (car l))))))
(define (append l1 l2)
  (if (null? l1)
      l2
      (cons (car l1) (append (cdr l1) l2))))

Exercise 2.19

Let's review the change-counting program. We know that the number of
change-count can be reduced as follows:
- Exchange the change using the first coin and
- not using the first coin
The above states the reductive process. To complete the whole process of it, we
need to specify the base case:
- when the amount is zero, then we have only one way to change.
It is quite tricky at first why this is true; but think it this way: simulate
the situation with some simple case,e.g. the amount is 6 cents or like that.
Then we come to realize it really need to count as 1 when amount is zero in this
recursive process.

That's not the only base case; by the reductive process we have only two cases left to consider:
- when we have 0 coins to change, we count this as 0 and
- when we have negative amount to change, there is no way to change the amount; 0.
Again, we can got the guts by simulating the simple cases or more formally we
should reason this argument using induction. I think it is reasonable to use the
computer aided proof check like this situation because humankind inherited the
error-prone property. Nonetheless let's code.

Then we can code this recursive process:
```
(define us-coins (list 50 25 10 5 1))   ;examples of how the parameter, coin-values, constructed
(define (cc amount coin-values)
  (cond ((= amount 0) 1)
	((< amount 0) 0)
	((no- wjmore? coin-values) 0)         ;↑base cases
	(else (+ (cc (- amount
			(first-denomination coin-values)) ;first reduction branch
		     coin-values)
		 (cc amount             ;second (last) reduction branch
		     (except-first-denomination coin-values))))))

(define (no-more? coin-values)
  (null? coin-values)) ;we could (define no-more? null?) but we don't like to mess up the debugger

(define (first-denomination coin-values)
  (car coin-values))                 ;we provided that the coin-values not empty

(define (except-first-denomination coin-values)
  (cdr coin-values))                 ;we provided that the coin-values not empty
```
We can reason that the order of the list coin-values does not affect the
answer produced by cc; it just only takes more times to evaluate it.

We can assure that by experimenting with some examples:
```
(define us-reverse (reverse us-coins))
(cc 100 us-reverse)
(cc 100 us-coins)
(cc 112 us-reverse)
(cc 112 us-coins)
```
The us-reverse results to same as us-coins. Why should it be?: The reductive
process and base case I've wrote above does not mention about the order of
coins; it should behave as same whatever order is.

Then how about the efficiency (complexity) of space and times? We can guess the
reversed order should be more complex than the previous case; but it is not
obvious.

Let's do some trick. While we have not studied the set! statement, but it is
useful to estimate the complexity and get some intuition about the general case:
```
(define (cc amount coin-values)
  (define (cc-counter amount coin-values)
    (cond ((= amount 0)
	   (set! count (1+ count))
	   1)
	  ((< amount 0)
	   (set! count (1+ count))
	   0)
	  ((no-more? coin-values)
	   (set! count (1+ count))
	   0)                           ;↑base cases
	  (else
	   (set! count (1+ count))
	   (+ (cc-counter (- amount
		     (first-denomination coin-values)) ;first reduction branch
		  coin-values)
	      (cc-counter amount                ;second (last) reduction branch
		  (except-first-denomination coin-values))))))
  (define count 0)                      ;count the steps needed to evaluate cc
  (cons count (cc-counter amount coin-values))) ;return the pair of count and number of cc ways
```
Then we can inspect by using that:
```
(cc 100 us-reverse)                     ;=> (38901 . 292)
(cc 100 us-coins)                       ;=> (15499 . 292)
```
Yeah, as we expected, the reversed version needs more than double steps than original.
How can we reason this? Let's we do some simulation with simple argument using
substitution model. After some experiment, I've realized it is hard to prove
that the reversed one has more step complexity than previous in asymptotic notation.
To prove that the reversed one has more step & space complextity, we should
prove that using inequality sign not asymptotic notation; it will convolve more
subtle argument. We should use proof assistant otherwise it become really tricky
to prove.

Exercise 2.20

I've started not to think about the structure. It's the evidence that I've
exhausted completely. Anyway here is the code:

(define (same-parity first . rest)
  (let ((same? (if (even? first)
		   even?
		   odd?)))
    (cons first (filter same? rest))))  ;wishful tinking

(define (filter include? l)
  (if (null? l)
      l
      (let ((hd (car l))                ;it would be clearer if I use the let* notation.
	    (tl (cdr l)))               ;but I've not learned yet.
	(let ((filtered
	       (filter include? tl)))
	  (if (include? hd)
	      (cons hd filtered)
	      filtered)))))

Isn't this obvious to explain? Anyway, I'll skip that.

Mapping over lists

(define (map proc items)
  (if null? items)
  nil
  (cons (proc (car items))
	(map proc (cdr items))))

Exercise 2.21

(define (square-list items)
  (if (null? items)
      nil
      (cons (square (car items) (square-list (cdr items))))))

(define (square-list items)
  (map square items))

Exercise 2.22
1. Because the structure of the helper procedure iter is same as our first
  definition of reverse.
2. List is, by definition, sequence of pairs. But the tried implementation
  returns something other than list: (cons answer (square (car things))) is
  not chained pairs.

Exercise 2.23

First try

(define (for-each proc items)
  (if (null? items)                     ;base case
      true                              ;done case (termination)
.....

↑ We can not use if clause for evaluation of sequenced statement.
So we should use cond clause instead.

(define (for-each proc items)
  (cond ((null? items) true)            ;termination (base) case return true, which can be arbitrary value.
	(else
	 (proc (car items))
	 (for-each proc (cdr items))))

Let's test it:

(for-each (lambda (x) (newline) (display x))
	  (list 57 321 88))

Yeah works well.

Hierarchical Structures

Let's implement the count-leaves. It should behave like follows:

(define x (cons (list 1 2) (list 3 4)))
(length x)                              ;3
(count-leaves x)                        ;4
(list x x)                              ;(((1 2) 3 4) ((1 2) 3 4))
(length (list x x))                     ;2
(count-leaves (list x x))               ;8

The implementation of count-leaves is analogous to length:

count-leaves of the empty list is 0.

But in the reduction step, we should take a count the car part:

count-leaves of tree x is count-leaves of the car of x plus
count-leaves of the cdr of x.

After repeatedly apply the reduction step, we reach the another base case:

count-leaves of a leaf is 1.

And we can test whether it is leaf by using the primitive predicate pair? we
test whether it is pair or not.

Then we can complete the procedure:

(define (count-leaves x)
  (cond ((null? x) 0)
	((not (pair? x)) 1)
	(else (+ (count-leaves (car x))
		 (count-leaves (cdr x))))))

Exercise 2.24

I've drawn assigned task in Digital Papper.
Exercise 2.25
1. (cadaddr (list 1 3 (list 5 7) 9)) results to 7.
  The notation (cadaddr x) is abbreviation for (car (cdr (car (cdr (cdr x))))).
  Let we use this notation from this point for the space.
2. (caar (list (list 7))).
3. (cadadadadadadr x), where x is (1 (2 (3 (4 (5 (6 7)))))).
Exercise 2.26
1. (append x y) would result to (1 2 3 4 5 6).
2. (cons x y) would result to ((1 2 3) 4 5 6).
3. (list x y) would result to ((1 2 3) (4 5 6)).
We can verify those by evaluating:
```
(define x (list 1 2 3))
(define y (list 4 5 6))
(append x y)
(cons x y)
(list x y)
```
Yeah the results are same as above.
Exercise 2.27

We should implement, so called, deep-reverse. It behaves as follows:
```
(define x (list (list 1 2) (list 3 4))) ;((1 2) (3 4))
(reverse x)                             ;((3 4) (1 2))
(deep-reverse x)                        ;((4 3) (2 1))
```
It is obvious that we should use, so called, tree recursion for it. Or wishful
thinking so to say.

Let's start with reduction step:
- We assume that subtrees are deep reversed. Then we can complete the whole
  procedure:
```
(reverse (cons (deep-reverse (car x)) (deep-reverse (cdr x))))
```
- Then the results are reduced to the subproblem whose argument is subtree of x.
There are two base case with which the reduction step end up:
- By cdring down the list, we optain nil at the very end.
- Or, we could encounter the leaf, not the pair by caring the list.
As consequence, we can complete the procedure analogous to count-leaves:
```
(define (deep-reverse x)
  (cond ((null? x) x)
	((not (pair? x)) x)
	(else (reverse (cons
			(deep-reverse (car x))
			(deep-reverse (cdr x)))))))
```

Exercise 2.28

Implement fringe. Whose behavior are the followings:

(define x (list (list 1 2) (list 3 4)))
(fringe x)                              ;(1 2 3 4)
(fringe (list x x))                     ;(1 2 3 4 1 2 3 4)

The strategy is similar with above:

(define (fringe x)
  (cond ((null? x) x)
	((not (pair? x)) (list x))
	(else (append (fringe (car x))
		      (fringe (cdr x))))))

Note that we return the singleton list in the case of leaf; it is necessary at
the reduction step.

Exercise 2.29

Here we model the binary mobile, which consists of two branches–a left branch
and right branch. Each branch is a rod of a certain length, from which hangs
either a weight or another binary mobile.

We can construct it by using list:

(define (make-mobile left right)
  (list left right))

A branch is constructed from a length, which must be a number, together with a
structure, which may be either a number–a simple weight– or another mobile:

(define (make-branch length structure)
  (list length structure))

a.

Then we can implement the selectors, namely left-branch and right-branch:

(define (left-branch mobile)
  (car mobile))
(define (right-branch mobile)
  (cadr mobile))

And the branch' structure:

(define (branch-structure branch)
  (cadr branch))

b.

The procedure that returns weight of mobile, total-weight, is similar with
above tree recursion processes: ¹

Reduction process:

(+ (total-weight (branch-structure (left-branch mobile)))
   (total-weight (branch-structure (right-branch mobile))))

which end up with

Base case:

(if (not (mobile? x)) x)                ;a simple weight case

And the mobile? test whether it is mobile:

(define (mobile? x) (pair? x))

And then we complete the procedure:

(define (total-weight mobile)
  (if (not (mobile? mobile))
      mobile
      (+ (total-weight (branch-structure (left-branch mobile)))
	 (total-weight (branch-structure (right-branch mobile))))))

c. Design the predicate that tests whether a binary mobile is balanced.

Here we also exploit the wishful thinking about the tree structure:

Reduction process:

(let ((left (left-branch mobile))
      (right (right-branch mobile)))
  (let ((mobile-l (branch-structure left))
	(mobile-r (branch-structure right)))
    (if (and (balanced? mobile-l)
	     (balanced? mobile-r))
	(= (* (branch-length left)
	      (total-weight mobile-l))
	   (+ (branch-length right)
	      (total-weight mobile-r)))
	false)))

Here we used the branch-length whose definition is

(define (branch-length branch)
  (car branch))

Yeah, it's quite dirty; but straight forward. We can revise the if clause as
follow:

(and (balanced? mobile-l)
     (balanced? mobile-r)
     (= (* (branch-length left)
	      (total-weight mobile-l))
	   (+ (branch-length right)
	      (total-weight mobile-r))))

as the consequence and alternative of if clause are boolean. This end up with

Base case (a simple weight):
```
(if (not (mobile? x)) true)
```
which can be reduced to
```
(not (mobile? x))
```

The complete code:

(define (blanced? mobile)
  (and (not (mobile? mobile))
       (let ((left (left-branch mobile))
	     (right (right-branch mobile)))
	 (let ((mobile-l (branch-structure left))
	       (mobile-r (branch-structure right)))
	   (and (balanced? mobile-l)
		(balanced? mobile-r)
		(= (* (branch-length left)
		      (total-weight mobile-l))
		   (+ (branch-length right)
		      (total-weight mobile-r))))))))

d.

Suppose we change the representation of mobiles so that the constructors are

(define (make-mobile left right)
  (cons left right))
(define (make-branch length structure)
  (cons length structure))

Then we should change only the followings:

(define (right-branch mobile)
  (cdr mobile))
(define (branch-structure branch)
  (cdr branch))

Boom! That's it. The power of abstract barrier!

Mapping over trees

We can define the scale-tree procedure analogous to scale-list using map:

(define (scale-tree tree factor)
  (map (lambda (sub-tree)
	 (if (pair? sub-tree)
	     (scale-tree sub-tree factor)
	     (* sub-tree factor)))
       tree))

Exercise 2.30

Define a procedure square-tree analogous to the square-list procedure of exercise 2.21.
That is, square-tree should behave as follows:

(square-tree
 (list 1
       (list 2 (list 3 4) 5)
       (list 6 7)))                     ;(1 (4 (9 16) 25) (36 49))

Define square-tree without higher-order procedures

We can do this by analogy to scale-tree:

(define (square-tree tree)
  (cond ((null? tree) tree)
	((not (pair? tree)) (square tree))
	(else (cons (square-tree (car tree))
		    (square-tree (cdr tree))))))

Define square-tree using map

(define (square-tree tree)
  (map (lambda (sub-tree)
	 (if (pair? sub-tree)
	     (square-tree sub-tree)
	     (square sub-tree)))
       tree))

Exercise 2.31

Define tree-map that behave as follows:

(define (square-tree tree) (tree-map square tree))

It is easy:

(define (tree-map proc tree)
  (map (lambda (sub-tree)
	 (if (pair? sub-tree)
	     (tree-map proc sub-tree)
	     (proc sub-tree)))
       tree))

Exercise 2.32

We can get the whole subsets of s by reducing that:

The subsets that include the element a of s plus
The subsets that do not include the element a.

Then we can complete the code:

(define (subsets s)
  (if (null? s)
      (list s)
      (let ((rest (subsets (cdr s))))
	(append rest
		(map (lambda (subset)
		       (cons (car s) subset))
		     rest)))))

Sequences as Conventional Interfaces

Sequence Operations

The main procedures that complete the signal processing interfaces are
followings:

map
filter

accumulate

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
	  (accumulate op initial (cdr sequence)))))

All that remains to implement signal-flow diagrams is to enumerate the sequence
of elements to be processed. That is, to make signals which processed afterward.

make initial signal; produces list.
To enumerate the interval of integers, we can code

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

For tree, we can transform the tree as follows²:

(define (enumerate-tree tree)
  (cond ((null? tree) nil)
	((not (pair? tree)) (list tree))
	(else (append (enumerate-tree (car tree))
		      (enumerate-tree (cdr tree))))))

Exercise 2.33

By comparing the map procedure and accumulate we can define the map as follows:

(define (map p sequence)
  (accumulate (lambda (x y) (cons (p x) y))
	      nil
	      sequence))

And the others also can be implemented analogous to above:

(define (append seq1 seq2)
  (accumulate cons seq2 seq1))
(define (length sequence)
  (accumulate (lambda (x y) (1+ y)) 0 sequence))

Exercise 2.34

Horner's rule.

(define (horner-eval x coefficient-sequence)
  (accumulate (lambda (this-coeff higher-terms) (+ this-coeff (* x higher-terms)))
	      0
	      coefficient-sequence))
;; test
(horner-eval 2 (list 1 3 0 5 0 1))      ;79

Actually I've used this in the exercise in Isabelle.

Exercise 2.35

We can redefine count-leaves from this using accumulate, which means that we
can formulate count-leaves as signal processing interface.

At first, let's try out without lingering over it; just compare those structure
and code it appropriately:
```
(define (count-leaves t)
  (accumulate (lambda (x y)
		(if (not (pair? x))
		    (1+ y)
		    (+ (count-leaves x)
		       y)))
	      0
	      t))
```
It works; but it is not the one the text wanted: Text want we process the t
with map before feed it to accumulate:
```
(define (count-leaves t)
  (accumulate <??> <??> (map <??> <??>)))
```
And more, it is no more clear than we did previously; just cramming all of the
messy things from count-leaves into the op of accumulate.

We can do better than that. Let's follow text's intention; but how we get the
count-leaves coded? As we trying to formulate this as signal processing
interface, first we need to processing the input t as 'signal'–list–so that
we can use conventional interfaces for this.

Then the remain is simple:
```
(define (count-leaves t)
  (accumulate + 0 (map (lambda (x) 1)
		       (enumerate-tree t))))
```
Yeah, who even said that we shouldn't use enumerate-tree here? I think the
intention of this exercise was in that capturing recursive process in signal
processing framework. It looks silly when we map all the list items into number
1 like this; but it will compensate someday I think. Whatever, let's move on.
Exercise 2.36

The generalized version of accumulate, accumulate-n deal with sequence of
sequences that all have same number of elements. The behavior is as follows:
```
(accumulate-n + 0 (list (list 1 2 3) (list 4 5 6) (list 7 8 9) (list 10 11 12)))
;(22 26 30)
```
Here we use wishful thinking as usual:
- Reduction process:
  Let we assume that we were given the results of
  accumulate-n with sequence of sequences except the first element of each.
  Then we can complete the process by accumulate the first element of each and
  then consing it with the given:
```
(cons (accumulate op init (map car seqs))
      (accumulate-n op init (map cdr seqs)))
```
  After repeatedly applying this process we get
- Base case:
  we end up with sequence of nil:
```
(if (null? (car seqs))
    (car seqs))
```
  This is the only base case because nil is not the sequence of sequences.
Then the complete code can be synthesized as usual:
```
(define (accumulate-n op init seqs)
  (if (null? (car seqs))
      (car seqs)
      (cons (accumulate op init (map car seqs))
	    (accumulate-n op init (map cdr seqs)))))
```

Exercise 2.37

From now on, I'll pace up because I've already designed the strucutre of these
exercises on my note.

(define (dot-product v w)
  (accumulate + 0 (map * v w)))
(define (matrix-*-vector m v)
  (map (lambda (m_i) (dot-product m_i u))
       m))
(define (transpose mat)
  (accumulate-n cons '() mat))
(define (matrix-*-matrix m n)
  (let ((cols (transpose n)))
    (map (lambda (m_i)
	   (matrix-*-vector cols m_i))
	 m)))

Exercise 2.38

To get equal value from both fold-right and fold-left, op should satisfy
the associative law of algebra and also commutative law with repect to init.

Exercise 2.39

(define (snoc x y)
  (append y (list x)))
(define (reverse sequence)
  (fold-right (lambda (x y)
		(snoc x y))
	      '()
	      sequence))
(define (reverse sequence)
  (fold-left (lambda (x y)
	       (cons y x))
	     '()
	     sequence))

Exercise 2.40

(define (flatmap proc seq)
  (accumulate append '() (map proc seq)))
(define (unique-pairs n)
  (flatmap
   (lambda (i)
     (map (lambda (j) (list i j))
	  (enumerate-interval 1 (- i 1))))
   (enumerate-interval 1 n)))

Exercise 2.41

(define (triple-sum-to-s n s)
  (filter (lambda (triple)
	    (= s (fold-right + 0 triple)))
	  (flatmap (lambda (k)
		     (map (lambda (p)
			    (snoc k p))
			  (unique-pairs (- k 1))))
		   (enumerate-interval 1 n))))

Exercise 2.42

(define (queens board-size)
  (define (queen-cols k)
    (if (= k 0)
	(list empty-board)
	(filter
	 (lambda (positions) (safe? k positions))
	 (flatmap
	  (lambda (rest-of-queens)
	    (map (lambda (new-row)
		   (adjoin-position new-row k rest-of-queens))
		 (enumerate-interval i board-size)))
	  (queen-cols (- k 1))))))
  (queen-cols board-size))

(define empty-board '())

(define (adjoin-position new-row k rest-of-queens)
  (cons new-row rest-of-queens))

(define (safe? k positions)
  (define (equal-not-to? nr rest)
    (or (null? rest)
	(and (not (= nr (car rest)))
	     (equal-not-to? nr (cdr rest)))))
  (define (pm-i-not-equal-to? nr i rest)
    (or (null? rest)
	(and (not (or (= (+ nr i) (car rest))
		      (= (- nr i) (car rest))))
	     (pm-i-not-equal-to? nr (1+ i) (cdr rest)))))
  (let ((new-row (car positions))
	(rest-queens (cdr positions)))
    (and (equal-not-to? new-row rest-queens) ;provided that positions not empty
	 (pm-i-not-equal-to? new-row 1 rest-queens))))

Note that here we didn't use the parameter k none of helper procedures–
adjoin-position and safe? – because we don't need to; I've thought it is
natural to think the first k-1 columns as counted from the rightmost.

#<unspecified>

Exercise 2.43

Because by exchange the order of flatmap and map in the procedure
queen-cols now the procedure call (queen-cols (- k 1)) become evaluated
duplicately every new-row of (enumerate-interval 1 board-size), i.e
board-size times.

We can reason the asymptotic time complexity of both cases:
- The original one is θ(n³)
- The troubled one is θ(nⁿ)
Here we used the n as board-size. As consequence, when board-size is 8 and
let the time taken by original one T, then the Louis's one takes approximately
more than 8⁵ × T.

Example: A Picture Language

The picture language
- Primitives: painter
- Means of combination: beside, below
  - Create new painter from existing one: filp-vert, flip-horiz
- Means of abstraction: define in scheme language; As means of combination are
  all procedure in scheme, we can abstract them like any other procedure in scheme.
The results of combination of painter are also painters; by this closure
property with scheme's picture language inherit closure property in complete
sense.

I've tried to configure the picture language framework in mit-scheme; but to no vail.
I've searched the github of mit-scheme, which has the directory named "6001"
that contains 6001.pkg; to use that package, I've read the relevant content of
MIT scheme's user manual, also to no use; I've complied it with sf method in
edwin editor–this package depends on the edwin package, so I have no choice to
use emacs in this case–, and I found myself it is useless I need to put more
time in configuration than solving the exercises. The easiest alternative was to
use racket's sicp package, which I knew but have stuck with using pure
mit-scheme as I felt it is more canonical. Well, whatever, I've given up with
that; let's go with racket.

Exercise 2.44

We can define up-split analogous to right-split.

(define (up-split painter n)
  (if (= n 0)
      painter
      (let ((smaller (up-split painter (- n 1))))
	(below painter (beside smaller smaller)))))

Exercise 2.45

We can easily abstract this by higher order function:

(define (split tran1 tran2)
  (lambda (painter n)
    (if (= n 0)
	painter
	(let ((smaller ((split tran1 tran2) painter (- n 1))))
	  (tran1 painter (tran2 smaller smaller))))))

Exercise 2.46

Note that I implement sub-vect using the scale-vect and add-vect; it is
subtle matter but I thought this definition is more canonical in algebraical
sense:

(define (make-vect x y)
  (cons x y))

(define (xcor-vect v)
  (car v))

(define (ycor-vect v)
  (cdr v))

(define (add-vect v1 v2)
  (make-vect (+ (xcor-vect v1)
		(xcor-vect v2))
	     (+ (ycor-vect v1)
		(ycor-vect v2))))
(define (scale-vect s v)
  (make-vect (* (xcor-vect v) s)
	     (* (ycor-vect v) s)))
(define (sub-vect v1 v2)
  (add-vect v1 (scale-vect -1 v2)))

Exercise 2.47

For first representation, we can implement selectors accordingly:

(define (origin-frame f)
  (car f))
(define (edge1-frame f)
  (cadr f))
(define (edge2-frame f)
  (caddr f))

For the latter, similarly:

(define (origin-frame f)
  (car f))
(define (edge1-frame f)
  (cadr f))
(define (edge2-frame f)
  (cddr f))

Exercise 2.48

Didn't we solved this in exercise 2.2? In there, we made segment using points
not vector but the representation axiom is same in both; we can reuse that
definiiton:

;; Constructor make-segment
(define (make-segment start-pt end-pt)
  (cons start-pt end-pt))
;; Selector start-segment
(define (start-segment segment)
  (car segment))
;; Selector end-segment
(define (end-segment segment)
  (cdr segment))

Exercise 2.49

a.

The painter that draws the outline of the designated frame.

(define outliner
  (let ((o (make-vect 0 0))
	(br (make-vect 1 0))
	(tr (make-vect 1 1))
	(tl (make-vect 0 1)))
    (segments->painter (list (make-segment o br)
			     (make-segment br tr)
			     (make-segment tr tl)
			     (make-segment tl o)))))

b.

The painter that draws an "X" by connecting opposite corners of the frame.

(define x-liner
  (let ((o (make-vect 0 0))
	(br (make-vect 1 0))
	(tr (make-vect 1 1))
	(tl (make-vect 0 1)))
    (segments->painter (list (make-segment o tr)
			     (make-segment br tl)))))

c.

The painter that draws a diamond shape by connecting the midpoints of the sides
of the frame.

(define dia-liner
  (let ((o (make-vect 0 0))
	(br (make-vect 1 0))
	(tr (make-vect 1 1))
	(tl (make-vect 0 1)))
    (let ((left (scale-vect 0.5 tl))
	  (bottom (scale-vect 0.5 br)))
      (let ((right (add-vect br left))
	    (top (add-vect tl bottom)))
	(segments->painter (list (make-segment left top)
				 (make-segment top right)
				 (make-segment right bottom)
				 (make-segment bottom left)))))))

DONE d.

The wave painter.

(define wave
  (let ((lhl (make-vect 0 0.65))         ;left hand
	(lhh (make-vect 0 0.8))
	(rhh (make-vect 1 0.35))
	(rhl (make-vect 1 0.2))
	(lal (make-vect 0.24 0.45))     ;left arm joint
	(lah (make-vect 0.24 0.6))
	(lsl (make-vect 0.4 0.6))       ;left shoulder
	(lsh (make-vect 0.4 0.65))
	(ln (make-vect 0.45 0.65))
	(rn (make-vect 0.55 0.65))
	(rs (make-vect 0.6 0.65))
	(lfa (make-vect 0.43 0.8))
	(rfa (make-vect 0.57 0.8))
	(lh (make-vect 0.45 1))
	(rh (make-vect 0.55 1))
	(lv (make-vect 0.43 0.55))
	(rv (make-vect 0.57 0.55))
	(lfo (make-vect 0.3 0))
	(rfo (make-vect 0.7 0))
	(lfo1 (make-vect 0.4 0))
	(rfo1 (make-vect 0.6 0))
	(cl (make-vect 0.5 0.3)))
    (segments->painter (list (make-segment lhh lah)
			     (make-segment lah lsh)
			     (make-segment lsh ln)
			     (make-segment ln lfa)
			     (make-segment lfa lh) ;from left hand high to left head
			     (make-segment lhl lal)
			     (make-segment lal lsl)
			     (make-segment lsl lv)
			     (make-segment lv lfo) ;from left hand low to left foot
			     (make-segment lfo1 cl)
			     (make-segment cl rfo1) ;from left foot1 to right foot1
			     (make-segment rfo rv)
			     (make-segment rv rhl) ;from left foot to right hand low
			     (make-segment rhh rs)
			     (make-segment rs rn)
			     (make-segment rn rfa)
			     (make-segment rfa rh)))        ;from left hand high left head
    ))

Transforming and combining painters

As we noted in the introductive session of this section, the combinators created
new painter element using the existing ones. Now we implement the combinators
using more general procedure, transform-painter:

(define (transform-painter painter origin corner1 corner2)
  (lambda (frame)
    (let ((m (frame-coord-map frame)))
      (let ((new-origin (m origin)))
	(painter
	 (make-frame new-origin
		     (sub-vect (m corner1) new-origin)
		     (sub-vect (m corner2) new-origin)))))))

Here we exploit the fact that painter is actually just procedure, which takes
frame for its arguemnt, so to transform the painter all we need to do is
transform the frame appropriately. Also note that we could have chosen edge1
and edge2 for transformation instead corner1 and corner2; we just found
from the use case it is more convenient.

Then we can implement a lot of combinators:

filp-vert

(define (flip-vert painter)
  (transform-painter painter
		     (make-vect 0.0 0.0)
		     (make-vect 1.0 1.0)
		     (make-vect 0.0 0.0)))

We can also shrink the frame:

(define (shrink-to-upper-right painter)
  (transform-painter painter
		     (make-vect 0.5 0.5)
		     (make-vect 1.0 0.5)
		     (make-vect 0.5 1.0)))

Also we can rotate the frame:

(define (rotate90 painter)
  (transform-painter painter
		     (make-vect 1.0 0.0)
		     (make-vect 1.0 1.0)
		     (make-vect 0.0 0.0)))

We can combine two or more paitners

(define (beside painter1 painter2)
  (let ((split-point (make-vect 0.5 0.0)))
    (let ((paint-left
	   (transform-painter painter1
			      (make-vect 0.0 0.0)
			      split-point
			      (make-point 0.0 1.0)))
	  (paint-right
	   (transform-painter painter2
			      split-point
			      (make-vect 1.0 0.0)
			      (make-vect 0.5 1.0))))
      (lambda (frame)
	(paint-left frame)
	(paint-right frame)))))

Exercise 2.50

We can define flip-horiz analogous to flip-vert:

(define (flip-horiz painter)
  (transform-painter painter
		     (make-vect 1.0 0.0) ;new origin
		     (make-vect 0.0 0.0) ;new end of edge1
		     (make-vect 0.0 1.0))) ;new end of edge2

We can define rotating frames in either way, using rotate90 or directly:

Using rotate90:

(define (rotate180 painter)
  (rotate90 (rotate90 painter)))
(define (rotate270 painter)
  (rotate90 (rotate180 painter)))

define directly:

(define (rotate180 painter)
  (transform-painter painter
		     (make-vect 1.0 1.0)
		     (make-vect 0.0 1.0)
		     (make-vect 1.0 0.0)))
(define (rotate270 painter)
  (transform-painter painter
		     (make-vect 0.0 1.0)
		     (make-vect 0.0 0.0)
		     (make-vect 1.0 1.0)))

Exercise 2.51

Define below analogous to beside:

(define (below painter1 painter2)
  (let ((split-point (make-vect 0.0 0.5)))
    (let ((paint-bottom
	   (transform-painter painter1
			      (make-vect 0.0 0.0)
			      (make-point 1.0 0.0)
			      split-point))
	  (paint-top
	   (transform-painter painter2
			      split-point
			      (make-vect 1.0 0.5)
			      (make-vect 0.0 1.0))))
      (lambda (frame)
	(paint-bottom frame)
	(paint-top frame)))))

Using beside:

(define (below painter1 painter2)
  (rotate270 (beside (rotate90 painter2)
		     (rotate90 painter1))))

Exercise 2.52

a.

Let's add some smile to our wave:

(define wave
  (let ((lhl (make-vect 0 0.65))         ;left hand
	(lhh (make-vect 0 0.8))
	(rhh (make-vect 1 0.35))
	(rhl (make-vect 1 0.2))
	(lal (make-vect 0.24 0.45))     ;left arm joint
	(lah (make-vect 0.24 0.6))
	(lsl (make-vect 0.4 0.6))       ;left shoulder
	(lsh (make-vect 0.4 0.65))
	(ln (make-vect 0.45 0.65))
	(rn (make-vect 0.55 0.65))
	(lm (make-vect 0.48 0.77))      ;smile~
	(rm (make-vect 0.52 0.77))
	(cm (make-vect 0.5 0.75))
	(rs (make-vect 0.6 0.65))
	(lfa (make-vect 0.43 0.8))
	(rfa (make-vect 0.57 0.8))
	(lh (make-vect 0.45 1))
	(rh (make-vect 0.55 1))
	(lv (make-vect 0.43 0.55))
	(rv (make-vect 0.57 0.55))
	(lfo (make-vect 0.3 0))
	(rfo (make-vect 0.7 0))
	(lfo1 (make-vect 0.4 0))
	(rfo1 (make-vect 0.6 0))
	(cl (make-vect 0.5 0.3)))
    (segments->painter (list (make-segment lhh lah)
			     (make-segment lah lsh)
			     (make-segment lsh ln)
			     (make-segment ln lfa)
			     (make-segment lfa lh) ;from left hand high to left head
			     (make-segment lhl lal)
			     (make-segment lal lsl)
			     (make-segment lsl lv)
			     (make-segment lv lfo) ;from left hand low to left foot
			     (make-segment lfo1 cl)
			     (make-segment cl rfo1) ;from left foot1 to right foot1
			     (make-segment rfo rv)
			     (make-segment rv rhl) ;from left foot to right hand low
			     (make-segment rhh rs)
			     (make-segment rs rn)
			     (make-segment rn rfa)
			     (make-segment rfa rh) ;from left hand high left head
			     (make-segment lm cm)
			     (make-segment cm rm))) ;smile~
    ))

b.

Change corner-split using only one copy of the up-split and right-split:

(define (corner-split painter n)
  (if (= n 0)
      painter
      (let ((up (up-split painter (- n 1)))
	    (right (right-split painter (- n 1))))
	(let ((top-left up)
	      (bottom-right right))
	  (beside (below painter top-left)
		  (below bottom-right (corner-split painter (- n 1))))))))

c.

Modify square-limit so that the big Mr. Rogers look outward from each corner
of the square:

(define (squre-limit painter n)
  (let ((combine4 (square-of-four flip-vert
				  rotate180
				  identity
				  flip-horiz)))))

Resulting Pictures

#lang racket
(require sicp-pict)
(define/contract wave
  (listof segment?)
  (let ((lhl (make-vect 0 0.65))         ;left hand
	(lhh (make-vect 0 0.8))
	(rhh (make-vect 1 0.35))
	(rhl (make-vect 1 0.2))
	(lal (make-vect 0.24 0.45))     ;left arm joint
	(lah (make-vect 0.24 0.6))
	(lsl (make-vect 0.4 0.6))       ;left shoulder
	(lsh (make-vect 0.4 0.65))
	(ln (make-vect 0.45 0.65))
	(rn (make-vect 0.55 0.65))
	(rs (make-vect 0.6 0.65))
	(lm (make-vect 0.48 0.77))      ;smile~
	(rm (make-vect 0.52 0.77))
	(cm (make-vect 0.5 0.75))
	(lfa (make-vect 0.43 0.8))
	(rfa (make-vect 0.57 0.8))
	(lh (make-vect 0.45 1))
	(rh (make-vect 0.55 1))
	(lv (make-vect 0.43 0.55))
	(rv (make-vect 0.57 0.55))
	(lfo (make-vect 0.3 0))
	(rfo (make-vect 0.7 0))
	(lfo1 (make-vect 0.4 0))
	(rfo1 (make-vect 0.6 0))
	(cl (make-vect 0.5 0.3)))
    (list (make-segment lhh lah)
	  (make-segment lah lsh)
	  (make-segment lsh ln)
	  (make-segment ln lfa)
	  (make-segment lfa lh)         ;from left hand high to left head
	  (make-segment lhl lal)
	  (make-segment lal lsl)
	  (make-segment lsl lv)
	  (make-segment lv lfo)         ;from left hand low to left foot
	  (make-segment lfo1 cl)
	  (make-segment cl rfo1)        ;from left foot1 to right foot1
	  (make-segment rfo rv)
	  (make-segment rv rhl)         ;from left foot to right hand low
	  (make-segment rhh rs)
	  (make-segment rs rn)
	  (make-segment rn rfa)
	  (make-segment rfa rh)         ;from left hand high left head
	  (make-segment lm cm)
	  (make-segment cm rm))         ;smile~
    ))
(define wave-p (segments->painter wave))
(paint wave-p)

Symbolic Data

Quotation

Exercise 2.53

This is easy stuff to get familized with quote notation

(list 'a 'b 'c)                         ;(a b c)
(list (list 'george))                   ;((george))
(cdr '((x1 x2) (y1 y2)))                ;((y1 y2))
(pair? (car '(a short list)))           ;#f
(memq 'red '((red shoes) (blue socks))) ;#f
(memq 'red '(red shoes blue socks))     ;(red shoes blue socks)

Exercise 2.54

We can think equal? procedure as two independent unit:

check if two arguments are symbols–not list and if it is then delegate to eq?.
otherwise, it means both are list; delegate this to another helper procedure
eqList?.

Here we used our old strategy wishful thinking: We haven't eqList?; we defered
to implement it.

(define (equal? s1 s2)
  (or (and (symbol? s1)
	   (symbol? s2)
	   (eq? s1 s2))
      (eqList? s1 s2)))

Then we should implement eqList?. We can design it using the type constrains,
of which Standard ML is good at:

fun eqList [] [] = true
  | eqList _ [] = false
  | eqList [] _ = false
  | eqList (x::xs) (y::ys) = (eq x y) andalso (eqList xs ys);

We can translate to scheme easily:

(define (eqList? xs ys)
  (cond ((and (null? xs) (null? ys))
	 true)
	((and (not (null? xs)) (null? ys))
	 false)
	((and (null? xs) (not (null? ys))) ;base case
	 false)
	(else (and (eq? (car xs) (car ys)) ;recursive case
		   (eqList? (cdr xs) (cdr ys))))))

Exercise 2.55

Because '... is just syntatic sugar for (quote ...). So it is same as
(quote (quote ...)). That is, as inner parts of the outermost quote are
treated symbolically, (car (quote ...)) is quote. There is no surprise here.

Example: Symbolic Differentiation

By allowing the symbolic notation in our language, we can cope with algebraic
manipulation symbolically. For simplicity, here we consider only simple
differentiation rules:

(\frac{dc}{dx} = 0) for (c) a constant or a variable different from (x)
(\frac{dx}{dx} = 1)
(\frac{\left( u + v \right)}{dx} = \frac{du}{dx} + \frac{dv}{dx})
(\frac{\left( uv \right)}{dx} = u \left( \frac{dv}{dx} \right) + v \left( \frac{du}{dx} \right))

Here we delegate implementing of representation of symbolic differentiation
system by using wishful thinking: We just need specify what we want.

First let's try to code deriv that calculate the derivative of given
expression with respect to var along with differentiation rules:

(define (deriv exp var)
  (cond ((number? exp) 0)
	((variable? exp)
	 (if (same-variable exp var) 1 0))
	((sum? exp)
	 (make-sum (deriv (addend exp) var)
		   (deriv (augend exp) var)))
	((product? exp)
	 (make-sum
	  (make-product (multiplicand exp)
			(deriv (multiplier exp) var))
	  (make-product (deriv (multiplicand exp) var)
			(multiplier exp))))
	(else
	 (error "unknown expression type -- DERIV" exp))))

Note that we just used all the procedure that we need without implementing
that. Also note that this deriv procedure coded directly the differential
rules from calculus.

Can we represent the expression that we used in deriv? Yes sure!

(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
  (and (symbol? v1) (symbol? v2) (eq? v1 v2)))
(define (make-sum a1 a2)
  (list '+ a1 a2))
(define (make-product m1 m2)
  (list '* m1 m2))
(define (sum? s)
  (and (pair? s) (eq? (car s) '+)))
(define (addend s) (cadr s))
(define (augend s) (caddr s))
(define (product? p)
  (and (pair? p) (eq? (car p) '*)))
(define (multiplier p) (cadr p))
(define (multiplicand P) (caddr p))

Here we embedded the symbolic expression analogous to lisp's compound
expression–prefix notation.

Let's test this:

(deriv '(+ x 3) 'x)                     ;(+ 1 0)
(deriv '(* x y) 'x)                     ;(+ (* x 0) (* 1 y))
(deriv '(* (* x y) (+ x 3)) 'x)         ;(+ (* (+ x 3) (+ (* y 1) (* 0 x))) (* (+ 1 0) (* x y)))

Is what we expected? Well, yes and no: The program produces answer that are
correct with respect with the differentiation rules; but it is so verbose. We
need some simplifying steps; we can accomplish this using the analogy to
rational number arithmetic system; we don't need to alter the deriv procedure,
which uses the constructors and selectors–the lower lever of language.

Let's specify what we exactly expect from the simplification:

For multiplication
- (x \times 0 = 0)
- (y \times 1 = y)
For summation
- (x + 0 = 0)

Also we want to fold the constants:
If the two argument of symbolic operation are both number than we calculate
appropriately, i.e.

('+ 5 4) should be simplified to 9
('* 5 4) should be simplified to 20

Then we can implement this by amending the low level language.

(define (make-sum a1 a2)
  (cond ((=number? a1 0) a2)
	((=number? a2 0) a1)
	((and (number? a1) (number? a2)) (+ a1 a2))
	(else (list '+ a1 a2))))
(define (=number? s n)
  (and (number? s) (= s n)))
(define (make-product m1 m2)
  (cond ((or (=number? m1 0) (=number? m2 0)) 0)
	((=number? m1 1) m2)
	((=number? m2 1) m1)
	((and (number? m1) (number? m2))
	 (* m1 m2))
	(else (list '* m1 m2))))

Exercise 2.56

Add the exponentiation to our symbolic algebraic system.
Our differentiation system become

(define (deriv exp var)
  (cond ((number? exp) 0)
	((variable? exp)
	 (if (same-variable? exp var) 1 0))
	((sum? exp)
	 (make-sum (deriv (addend exp) var)
		   (deriv (augend exp) var)))
	((product? exp)
	 (make-sum
	  (make-product (multiplicand exp)
			(deriv (multiplier exp) var))
	  (make-product (deriv (multiplicand exp) var)
			(multiplier exp))))
	((exponentiation? exp)
	 (make-product (make-product (exponent exp)
				     (make-exponentiation (base exp) (- (exponent exp) 1)))
		       (deriv (base exp) var)))
	(else
	 (error "unknown expression type -- DERIV" exp))))

with the representation

(define (make-exponentiation base exponent)
  (cond ((=number? exponent 0) 1)
	((=number? exponent 1) base)
	((and (number? base) (number? exponent))
	 (expt base exponent))
	(else (list '** base exponent))))

(define (exponentiation? e)
  (and (pair? e) (eq? (car e) '**)))

(define (base ex)
  (cadr ex))

(define (exponent ex)
  (caddr ex))

Let's test it:

The normal differentiation:

(deriv '(** x 5) 'x)                    ;(* 5 (** x 4))

Check if it simplify appropriately:

(deriv '(** x 2) 'x)                    ;(* 2 x)

Exercise 2.57

Extend our program to handle sums and product of arbitrary numbers (two or more)
of terms; e.g.
- our last example of test, (deriv '(* (* x y) (+ x 3)) 'x), can be expressed
  as (deriv '(* x y (+ x 3)) 'x).
Just amending the lower level of language–constructors and selectors.
Note that the differential rules– deriv– doesn't assume that the (v) is just
symbol; if we can recognize the (v) part appropriately, we are done.

Here is the idea:
[\frac{d\left[ u + \left( v + w + \cdots \right) \right]}{dx} = \frac{du}{dx} + \frac{d\left( v + w + \cdots \right)}{dx}]
That is, if we can amend (augend exp) to return (+ v w ...) then we complete
our mission.

We can code it directly:
```
(define (augend s)
;; provided that s has more than two number of terms
  (if (null? (cdddr s))
      (caddr s)                         ;it has exactly two terms addend augend.
      (cons '+ (cddr s))))              ;it has more than that
```
Similarly,
```
(define (multiplicand m)
;; provided that s has more than two number of terms
  (if (null? (cdddr m))
      (caddr m)                         ;it has exactly two terms.
      (cons '* (cddr m))))              ;it has more than that
```
We don't need to fix any of the constructors. We don't like to fix any so that
our construct afford to make expression with arbitrary terms; that only make
things more complicate.
Exercise 2.58

The mathematicians want to use infix form instead of prefix form like lisp
expression. Suppose we have to program our differentiation procedure for such
mathematicians; i.e. we have to modify our differentiation program so that it
works with ordinary mathematical notation–infix form.
- a. binary infix form
  
  Here we consider the infix operator accept only two terms, i.e. binary infix
  operator. By experimenting with some examples, we can conclude that in the
  correct syntax form of expression, the operator should position at cadr of it.
  
  Then we can accomplish it by coding that observation:
```
(define (sum? iexp)
  (and (pair? iexp)
       (pair? (cdr iexp))
       (eq? (cadr iexp) '+)))
```
  Here we used pair? twice to assure it will not raise exception when we call
  (cadr iexp). It is necessary not to raise exception because the caller of
  sum? doesn't know and doesn't need to know the gross detail like whether
  iexp satisfy the constraint of representation of sum; they doesn't need to
  know the representation of those.
  
  Likewise,
```
(define (product? iexp)
  (and (pair? iexp)
       (pair? (cdr iexp))
       (eq? (cadr iexp) '*)))
```
  The selectors can be expressed as follows
```
(define (addend is) (car is))
(define (augend is) (caddr is))
(define (multiplier im) (car im))
(define (multiplicand im) (caddr im))
```
  Similarly, the constructors represented as
```
(define (make-sum a1 a2)
  (cond ((=number? a1 0) a2)
	((=number? a2 0) a1)
	((and (number? a1) (number? a2)) (+ a1 a2)) ;↑ simplification
	(else (list a1 '+ a2))))

(define (make-product m1 m2)
  (cond ((or (=number? m1 0) (=number? m2 0)) 0)
	((=number? m1 1) m2)
	((=number? m2 1) m1)
	((and (number? m1) (number? m2)) ;↑ simplification
	 (* m1 m2))
	(else (list m1 '* m2))))
```
  The test works well:
```
(deriv '((x * 5) + (y + 4)) 'x)         ;5
```
- b. Standard algebraic notation
  
  Now we want to deal with more general case, standard algebraic notation, e.g.
  (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that
  multiplication is done before addition, i.e. multiplication has higher
  precedence than addition.
  
  To simplify the task, we develop new language, that is, the semantics of
  standard algebraic notation. We can be rephrased as add new layer under the
  representation; or to layer out between semantics and syntax.
  
  First let's experiment with some examples:
  ((x + y) * 5 * z), (x * y + (z + y) * 5)
  
  We can reconstruct using tree representation. Unfortunately I myself don't know
  yet how to print the tree figure here³; so I've drew these in my personal
  note. Well, anyway there is one way to represent the tree structure in text:
  Lisp! As said in text or lecture of SICP, we can represent the tree as list!
  If we do that now, we obtain following results:
  - (* (+ x y) 5 z) or (* (+ x y) (* 5 z))
  - (+ (* x y) (* (+ z y) 5))
  Note that in the first example we can represent in both, binary tree or tree
  with arbitrary branches. Also note that this situation exactly match with the
  previous exercise, ex 2.57.
  
  Consequently, all we need to do is to convert infix form to prefix form allowed
  to have arbitrary number of terms; the rest would be handled by ex 2.57 as said.
  
  Then how? Again by wishful thinking assume that all the subtrees are constructed
  appropriately. Let's try out.
  
  If (car exp) is compound data, then delegate it to subtree constructor and
  also we know that if it is correct infix form the (cadr exp) is
  operator⁴. Now we can construct whole tree by delegating the (cddr exp)
  and then constructing ((cadr exp) sub1 sub2).
  
  We constructed the abstract design of our code. The thing is, is it correct?
  No, it isn't! The second example shows why it is; we have not considered the
  precedence relation appropriately! To cope with it, we have to build the whole
  tree either when we encounter with the lowest precedence operator or when we
  get faced with last operator of expression at the top level.
  
  This time, it works! How can we be sure? Can we prove it? Well, at least it is
  worth to prove for practice or because it is not obvious; yet we are left with
  long way to go. Let's consider that first. We've built the so called AST–
  Abstract Syntactic Tree. Are we good to go and code this idea? Unfortunately no;
  there is something we missed: The selectors that used by deriv should return
  infix form not the prefix form as AST.
  
  That is, this time, we have to linger over the opposite way than we have
  constructed so far: To convert from AST to infix form. Here we also use the
  wishful thinking in recursive case: The subtrees are constructed for us; the
  rest is to deal with at the very top level.
  
  For simplicity, let we ignore the unnecessary parentheses, i.e. we don't have to
  omit the verbose parenthesis for conciseness when we convert to infix form. Then
  we can easily do the task: (cov-sub1 op cov-sub2)
  
  Yeah It was quite long way to accomplish this! We did the design things! All the
  left is to code it!
  
  If we code that directly without further design–naive approach, then we get
```
(define (->AST iexp)
  (define (constructor left stack)
    (let ((op (cadr left)))
      (cond ((or (lowest? op) (last? op left))
	     (list op
		   (->AST (cons (car left) stack))
		   (->AST (cddr left))))
	    (else (constructor
		   (cddr left)
		   (cons op
			 (cons (car left)
			       stack)))))))
  (cond ((null? (cdr iexp))             ;in the top level, it appears as singlton expression
	 (if (pair? (car iexp))
	     (->AST (car iexp))         ;compound expression
	     (car iexp)))               ;singleton
	(else (constructor iexp '()))))

(define (lowest? op)
  (and (symbol? op) (eq? op '+)))
(define (last? op left)
  (and (symbol? op) (null? (cdddr left))))
```
  We can test it; it works:
```
;; test
(->AST '((x + y) * 5 * z))              ;(* (* 5 (+ x y)) z)
(->AST '(x * y + (z + y) * 5))          ;(+ (* y x) (* (+ z y) 5))
```
  The reverse process can be coded likely:
```
(define (->infix ast)
  (cond ((not (pair? ast)) ast)         ;base case
	(else (list (->infix (cadr ast)) ;recursive case
		    (car ast)
		    (->infix (caddr ast))))))
```
  It also works:
```
(->infix (->AST '((x + y) * 5 * z)))    ;((5 * (x + y)) * z)
```
  With those, we can complete the code:
```
(define (sum? iexp)
  (and (pair? iexp)
       (pair? (cdr iexp))
       (let ((ast (->ast iexp)))
	 (eq? (car ast) '+))))

(define (product? iexp)
  (and (pair? iexp)
       (pair? (cdr iexp))
       (let ((ast (->ast iexp)))
	 (eq? (car ast) '*))))

(define (addend iexp)
  (let ((ast (->ast iexp)))
    (->infix (cadr ast))))

(define (augend iexp)
  (let ((ast (->ast iexp)))
    (->infix (caddr ast))))

(define (multiplier iexp)
  (let ((ast (->ast iexp)))
    (->infix (cadr ast))))

(define (multiplicand iexp)
  (let ((ast (->ast iexp)))
    (->infix (caddr ast))))
```
  The constructor should work as a. without modification.
  
  Let's test it:
```
(deriv '(x + 3 * (x + y + 2)) 'x)       ;4
(deriv '((x + y) * 5 * z) 'x)           ;(z * 5)
(deriv '(x * y + (z + y) * 5) 'x)       ;y
```
  It works well. Phew, we did it.
  
  Well, we did it, but we did not include the exponentiation expression. Our
  standard infix form should accommodate that expression? Although the statement
  of this exercise did not mention it, isn't it cool if we can handle the
  exponentiation? If we can accomplish that thing, we can extend further more!
  
  First we need to redesign our ->AST procedure. It is possible to cope with
  exponentiation just modifying our existing procedure; but the result would be
  quite mess–hard to recognize and maintain, no logic behind, etc.
  - Try: Let we assume there are specialist who can only handle specific operation.
    
    For instance, expt->AST can convert only exponentiation to AST and so on.
    
    The flow of overall ->AST procedure can be described as
```
infix form => inital setup + handle base case => expt->AST => prod->AST
=> sum->AST => AST(output)
```
    We can specify the <??>->AST's behavior:
    - should take infix form with partially built AST.
    - should return partially built AST whit rest infix form where the first
      operation is not <??>.
    So, for example, the output of expt->AST should satisfy that its first op is
    either + or * (or no operation left in infix form); by the same argument,
    when it comes to sum->AST the first op should + (or as mentioned no more
    operation).
    
    Let we code it:
```
(define (->AST iexp)
  (cond ((not (pair? iexp))             ;symbol--singleton
	 iexp)
	((null? (cdr iexp))             ;eof mark
	 (if (pair? (car iexp))
	     (->AST (car iexp))         ;turns out compound exp
	     (car iexp)))               ;it was singleton
	(else (expt->AST (cdr iexp) (->AST (car iexp)))))) ;recursive process
(define (expt->AST iexp AST)
  (cond ((null? iexp) AST)              ;eof
	((and (symbol? (car iexp))
	      (eq? (car iexp) '**))
	 (expt->AST (cddr iexp) (list '** AST (->AST (cadr iexp)))))
	(else (prod->AST iexp AST))))
(define (prod->AST iexp AST)
  (cond ((null? iexp) AST)
	((and (symbol? (car iexp))
	      (eq? (car iexp) '*))
	 (prod->AST (cddr iexp) (list '* AST (->AST (cadr iexp)))))
	(else (sum->AST iexp AST))))
(define (sum->AST iexp AST)
  (cond ((null? iexp) AST)
	((and (symbol? (car iexp))
	      (eq? (car iexp) '+))
	 (list '+ AST (->AST (cdr iexp))))))
```
    The results:
```
(->AST '(x + 3 * (x + y + 2)))          ;(+ x (* 3 (+ x (+ y 2))))
(->AST '(x ** 4 * (x * 2 + y + 2)))     ;(* (** x 4) (+ (* x 2) (+ y 2)))
```
    Works well!
    
    The rest are the predicate, selectors and constructors of exponentiation, which
    can be accomplished using analogy with others:
```
(define (exponentiation? iexp)
  (and (pair? iexp)
       (pair? (cdr iexp))
       (let ((ast (->ast iexp)))
	 (eq? (car ast) '**))))

(define (base iexp)
  (let ((ast (->ast iexp)))
    (->infix (cadr ast))))

(define (exponent iexp)
  (let ((ast (->ast iexp)))
    (->infix (caddr ast))))

(define (make-exponentiation base exponent)
  (cond ((=number? exponent 0) 1)
	((=number? exponent 1) base)
	((and (number? base) (number? exponent))
	 (expt base exponent))
	(else (list base '** exponent))))
```
    Let's test our last piece:
```
(deriv '(x ** 4 * (x * 2 + y + 2)) 'x)
;;((((x * 2) + (y + 2)) * (4 * (x ** 3))) + (2 * (x ** 4)))
```
    Done.

Example: Representing Sets

We can abstract out the representation of set by using data abstraction: As long
as we have union-set, intersection-set, element-of-set?, and adjoin-set
we can do anything as with normal set. Those procedures can be thought as
interface of object set or axioms of set:

(element-of-set? x (union-set S1 S2)) is equivalent to
(or (element-of-set? x S1) (element-of-set? x S2)
(element-of-set? x (intersection-set S1 S2)) is equivalent to
(and (element-of-set? x S1) (element-of-set? x S2)
For any element x and set S, (element-of-set? x (adjoin-set x S)) is true

All the representation that satisfy all the axioms above can be treat as set.

Sets as unordered lists

Here we represent a set as list of its elements in which no element appears more
than once. As we are going to represent sets as ordered lists, we name this
representation as unordered list representation.

As we mentioned adjoin-set should adjoin member if and only if member is not
already element-of-set?:

(define (adjoin-set x set)
  (if (element-of-set? x set)
      set
      (cons x set)))

Then element-of-set? get straightforward:

(define (element-of-set? x set)
  (cond ((null? set) false)
	((equal? x (car set)) true)
	(else (element-of-set? x (cdr set)))))

For the intersection-set we can rely on induction on either of each arguments:

(define (intersection-set set1 set2)
  (cond ((or (null? set1) (null? set2)) '())
	((element-of-set? (car set1) set2)
	 (cons (car set1)
	       (intersection-set (cdr set1) set2)))
	(else (intersection-set (cdr set1) set2))))

Exercise 2.59

Finally, union-set can be implemented as append-like procedure:
```
(define (union-set set1 set2)
  (cond ((null? set1) set2)
	(else (adjoin-set (car set1)
			  (union-set (cdr set1) set2)))))
```
This procedure has Θ(n²) step complexity as intersection-set.
Exercise 2.60

What if we represent a set as a list allowed to be duplicate? We don't need to
check if the member already in the given set to adjoin:
```
(define (adjoin-set x set)
  (cons x set))
```
And others doesn't have to change at all but the complexity change. As
adjoin-set became Θ(1) of step complexity, union-set, which depends on
adjoin-set, get to have Θ(n) of step complexity, where n is the size of set1.

The complexity of the others– element-of-set?, intersection-set– doesn't
change at all but now the concept of size of set has changed; although it is
same along with the specification, the size of it can depend on representation,
e.g. {1,2,1,1,1,1} has two member in it–1,2– and also it is {1,2} but
those differ in size–6, 2 respectively.

If we use adjoin-set (and union-set) a lot and sarcely element-of-set (or
intersection-set) then current version would be more efficient than previous
one, vice versa.

Sets as ordered lists

To simplify our discussion, we consider only the case where the set elements are
numbers. This section is well documented in text book. So we just jot down
necessary procedures here:

(define (element-of-set? x set)
  (cond ((null? set) false)
	((= x (car set)) true)
	((< x (car set)) false)
	(else (element-of-set? x (cdr set)))))

(define (intersection-set set1 set2)
  (if (or (null? set1) (null? set2))
      '()
      (let ((x1 (car set1))
	    (x2 (car set2)))
	(cond ((= x1 x2) (cons x1 (intersection-set (cdr set1)
						    (cdr set2))))
	      ((< x1 x2) (intersection-set (cdr set1) set2))
	      ((> x1 x2) (intersection-set set1 (cdr set2)))))))

Exercise 2.61

We know that if the member, which we are about to adjoin in given set, is
smaller then the (car set) then the member are not contained in given set;
if the member equals to (car set) then we don't have to do anything,
else we should look up the cdr of set recursively. Then we end up with
base case–nil of set; we just cons our member with nil:
```
(define (adjoin-set x set)
  (if (null? set)
      (list x)
      (let ((hd (car set)))
	(cond ((< x hd) (cons set))
	      ((= x hd) set)
	      (else
	       (adjoin-set x (cdr set)))))))
```

Exercise 2.62

To give Θ(n) growth union-set, we exploit the idea behind the
intersection-set. I've got quite bored with jotting down all the rules that
governs the algorithm; as this implementation is straightforward, let me just
show them:

(define (union-set set1 set2)
  (cond ((null? set1) set2)
	((null? set2) set1)
	(let ((x1 (car set1))
	      (x2 (car set2)))
	  (cond ((= x1 x2) (cons x1 (union-set (cdr set1) (cdr set2))))
		((< x1 x2) (cons x1 (union-set (cdr set1) set2)))
		((> x1 x2) (cons x2 (union-set set1 (cdr set2))))))))

Sets as binary trees

Here we represent sets as binary trees–composed by entry, left branch, right
branch. In turns, we have to represent the binary tree which satisfy following
axioms:

(entry (make-tree entry left right)) equals to entry
(left-branch (make-tree entry left right)) equals to left
(right-branch (make-tree entry left right)) equals to right

Here is one of representation that satisfy above axioms:

(define (entry tree) (car tree))
(define (left-branch tree) (cadr tree))
(define (right-branch tree) (caddr tree))
(define (make-tree entry left right)
  (list entry left right))

Given with above, we can write element-of-set? procedure:

(define (element-of-set? x set)
  (if (null? set)
      false
      (let ((hd (entry set)))
	(cond ((= x hd) true)
	      ((< x hd) (element-of-set? x (left-branch set)))
	      ((> x hd) (element-of-set? x (right-branch set)))))))

For the adjoin-set we recursively branching down the tree whether entry is
equals to given member or not; if there is no such entry, it end up with empty
tree, at that point, we should construct new tree and put the all pieces
together appropriately:

(define (adjoin-set x set)
  (if (null? set)
      (make-tree x '() '())
      (let ((hd (entry set)))
	(cond ((= x hd) set)
	      ((< x hd) (make-tree hd
				   (adjoin-set x (left-branch set))
				   (right-branch set)))
	      ((> x hd) (make-tree hd
				   (left-branch set)
				   (adjoin-set x (right-branch set))))))))

Exercise 2.63
```
(define (tree->list-1 tree)
  (if (null? tree)
      '()
      (append (tree->list-1 (left-branch tree))
	      (cons (entry tree)
		    (tree->list-1 (right-branch tree))))))

(define (tree->list-2 tree)
  (define (copy-to-list tree result-list)
    (if (null? tree)
	result-list
	(copy-to-list (left-branch tree)
		      (cons (entry tree)
			    (copy-to-list (right-branch tree)
					  result-list)))))
  (copy-to-list tree '()))
```
- a.
  
  We prove both produce the same result– ordered list.
  For the former, we can prove the assertion by induction on the depth of tree.
  For the latter, we prove the assertion by using the invariance that
  copy-to-list returns ordered list of given tree with appending the
  result-list at the end.
  
  As consequence, the figure 2.16 end up with (1 2 3 4 5 6 7).
- b.
  
  For the former, if we estimate the size of input as number of entries of tree,
  then we get the following differential equation:
  [f \left( n \right) - 2 f \left( n/2 \right) = \Theta \left( n/2 \right)],
  which end up with
  [f \left( n \right) = \Theta(n) + \Theta (n \log n)].
  As consequence, we got (\Theta(n \log n)) step complexity.
  
  For the latter, it becomes
  [ f(n) - 2 f(n/2) = \Theta (1) ];
  it can be concluded as
  [f(n) = \Theta(n) + \Theta(\log n) = \Theta(n)], i.e. (\Theta(n)) step complexity.
Exercise 2.64
```
(define (list->tree elements)
  (car (partial-tree elements (length elements))))
(define (partial-tree elts n)
  (if (= n 0)
      (cons '() elts)
      (let ((left-size (quotient (- n 1) 2)))
	(let ((left-result (partial-tree elts left-size)))
	  (let ((left-tree (car left-result))
		(non-left-elts (cdr left-result))
		(right-size (- n (+1 left-size))))
	    (let ((this-entry (car non-left-elts))
		  (right-result (partial-tree (cdr non-left-elts)
					      right-size)))
	      (let ((right-tree (car right-result))
		    (remaining-elts (cdr right-result)))
		(cons (make-tree this-entry
				 left-tree
				 right-tree)
		      remaining-elts))))))))
```
- a.
  
  The partial-tree's behavior is as follows
  - given with ordered list elts it returns pair that contains balanced tree
    with first n elements from the elts with ordered list but first n elements.
  This is just specification that we want to implement for list->tree. Then how
  to implement it? We have the powerful strategy, wishful thinking:
  Let we assume that for all inputs that has less than n partial-tree
  implemented by John. Our task is to complete the partial-tree for the inputs
  with n. Here is the idea:
  1. First, build the left half tree with the elts.
  2. And then, take one element from the remaining elts from step 1.
  3. Using the rest elements construct right half tree.
  4. Build whole tree using make-tree with above left tree, entry, right tree
    from 1, 2, 3, respectively.
  5. Returns pair consisting the tree built from step 4 with remaining elements
    from step 3.
  The straightforward implementation is shown above. Note that we used for the
  left-size since we have to satisfy the relation– (n - 1 \ge 2 ~\text{left-size}).
- b.
  
  Analogous to previous exercise, we can deduce that the order of growth of this
  implementation is Θ(n).
Exercise 2.65
- intersection-set
  
  After I've played with some examples, I concluded that the ordered list version
  of it is quite ideal implementation than using tree. Given with exercise 2.63,
  we can revert the (balanced) tree to ordered list.
  
  Then we simply put together all the modules:
```
(define (intersection-set set1 set2)
  (let ((ol1 (tree->list-2 set1))
	(ol2 (tree->list-2 set2)))
    (list->tree (intersection-setl ol1 ol2))))
```
  Here I rephrase the previous version of intersection-set as
  intersection-setl for denoting ordered list.
  
  Similarly, we can do same thing to union-set:
```
(define (union-set set1 set2)
  (let ((ol1 (tree->list-2 set1))
	(ol2 (tree->list-2 set2)))
    (list->tree (union-setl ol1 ol2))))
```
  These have all Θ(n) order of growth.

Exercise 2.66

As we know that lookup is analogous to element-of-set?, here also we can
implement using that observation:

(define (lookup given-key set)
  (if (null? set)
      false
      (let ((hd (key (entry set))))
	(cond ((= given-key hd) true)
	      ((< given-key hd) (lookup given-key (left-branch set)))
	      ((> given-key hd) (lookup given-key (right-branch set)))))))

Example: Huffman Encoding trees

Representing Huffman trees

Here we represent Huffman tree as weighted tree. The leaf can be represented as
```
(define (make-leaf symbol weight)
  (list 'leaf symbol weight))
(define (leaf? object)
  (eq? (car object) 'leaf))
(define (symbol-leaf x) (cadr x))
(define (weight-leaf x) (caddr x))
```
A general tree will be a list of left branch, a right branch, a set of symbols,
and as weight. The set of symbols will be simply a list of the symbols, which
contains all the symbols of leaves under the tree. And weight will be number
which indicate sum of leaves' weights under the tree. As I noted before, the
append operation is very similar to union. Here, as we represent the set of
symbols as just list, we can get the behavior of union using append:
```
(define (make-code-tree left right)
  (list left
	right
	(append (symbols left) (symbols right))
	(+ (weight left) (weight right))))
```
The other interface procedures determined by this representation:
```
(define (left-branch tree) (car tree))
(define (right-branch tree) (cadr tree))
(define (symbols tree)
  (if (leaf? tree)
      (list (symbol-leaf tree))
      (caddr tree)))
(define (weight tree)
  (if (leaf? tree)
      (weight-leaf tree)
      (cadddr tree)))
```
The decoding procedure

Given bits with Huffman tree, we can start decode with each bit from the
leftmost bit to determine how to choose next branch in the tree. If we
encountered with leaf, then it means we decoded one symbol in message.
Repeatedly decoding the symbols, and accumulating the symbols in list, we
complete the decoding process. It is natural to decompose this decoding
procedure to decoding one symbol, procedure to choose branch with the current
bit and branch of tree, accumulating the result symbols and determining
termination condition. Here is one possible implementation:
```
(define (decode bits tree)
  (define (decode-1 bits current-branch)
    (if (null? bits)
	'()
	(let ((next-branch
	       (choose-branch (car bits) current-branch)))
	  (if (leaf? next-branch)
	      (cons (symbol-leaf next-branch)
		    (decode-1 (cdr bits) tree))
	      (decode-1 (cdr bits) next-branch)))))
  (decode-1 bits tree))

(define (choose-branch bit branch)
  (cond ((= bit 0) (left-branch branch))
	((= bit 1) (right-branch branch))
	(else (error "bat bit -- CHOOSE-BRANCH" bit))))
```
Here we merged somehow decode one symbol with accumulating & terminating; we
found that it is way more concise than bothering to decompose with the described
fashion.
Sets of weighted elements

The tree-generating algorithm requires to choose smallest nodes in the set. To
do this, it is more convenient to represent a set as an ordered list as we did
before. However, in this situation, provided that the element being adjoined to
the set is not in the set. Using this fact we can adjoin-set more efficiently:
```
(define (adjoin-set x set)
  (cond ((null? set) (list x))
	((< (weight x) (weight (car set))) (cons x set))
	(else (cons (car set)
		    (adjoin-set x (cdr set))))))
```
Using this, we can construct the ordered list of pairs, which contains symbol
with frequency:
```
(define (make-leaf-set pairs)
  (if (null? pairs)
      '()
      (let ((pair (car pairs)))
	(adjoin-set (make-leaf (car pair) ;symbol
			       (cadr pair)) ;frequency
		    (make-leaf-set (cdr pairs))))))
```

Exercise 2.67

(define sample-tree
  (make-code-tree (make-leaf 'A 4)
		  (make-code-tree
		   (make-leaf 'B 2)
		   (make-code-tree (make-leaf 'D 1)
				   (make-leaf 'C 1)))))
(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
;; test
(decode sample-message sample-tree)     ;(a d a b b c a)

Exercise 2.68

The encode process can be decomposed as

(define (encode message tree)
  (if (null? message)
      '()
      (append (encode-symbol (car message) tree)
	      (encode (cdr message) tree))))

Then we should implement the encode-symbol procedure that encode one symbol as
sequence of bits. This procedure also should raise exception when there is not
such symbol in the tree. We can deduce the algorithm by playing with it:

Test whether the symbol included in tree.
If not raise error, else choose next branch that contains given symbol.
If we get all the way down to the leaf (which also contains given symbol by
contract) return the accumulated bits.

When we code this algorithm, we get

(define (element-of-set? x set)
  (cond ((null? set) false)
	((equal? x (car set)) true)
	(else (element-of-set? x (cdr set)))))

(define (encode-symbol symbol tree)
  (define (encode-1 current-branch)
    (if (leaf? current-branch)
	'()
	(if (element-of-set? symbol
			     (symbols (left-branch current-branch)))
	    (cons 0
		  (encode-1 (left-branch current-branch)))
	    (cons 1
		  (encode-1 (right-branch current-branch))))))
  (if (not (element-of-set? symbol (symbols tree)))
      (error "bad symbol -- ENCODE-SYMBOL" symbol)
      (encode-1 tree)))
;; test
(encode (decode sample-message sample-tree) sample-tree) ;(0 1 1 0 0 1 0 1 0 1 1 1 0)

Exercise 2.69

I've designed in my personal note. The result:

(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))

(define (successive-merge leaf-set)     ;provided that leaf-set is list
  (cond ((null? leaf-set) '())
	((null? (cdr leaf-set)) (car leaf-set)) ;termination condition
	(else                                   ;provided that it has atleast 2 leaves in this
	 (let ((leaf1 (car leaf-set))
	       (leaf2 (cadr leaf-set))
	       (rest-set (cddr leaf-set)))
	 (successive-merge (adjoin-set (make-code-tree leaf1 leaf2)
				       rest-set))))))
;;test
(define sample-pairs '((A 4) (B 2) (C 1) (D 1)))
(decode sample-message (generate-huffman-tree sample-pairs)) ;(a d a b b c a)

Exercise 2.70

If we do the instructions, we get

(define rock-pairs '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1)))
(define rock-tree (generate-huffman-tree rock-pairs))
(define rock-message '(Get a job
			   Sha na na na na na na na na
			   Get a job
			   Sha na na na na na na na na
			   Wah yip yip yip yip yip yip yip yip yip
			   Sha boom))
(define rock-code (encode rock-message rock-tree))
(length rock-code)                      ;84

In Huffman encoding, we need 84 bits for encoding the message. If we have used
fixed-length code for eight-symbol alphabet–we need at least 3 bits per
symbol, we get (* 3 (length rock-message)) that evaluated to 108. We saved
about 22% bits for encoding the message.

Exercise 2.71

We can prove by induction on n or on depth of tree that the most frequent
symbol requires 1 bit to encode and for the least frequent one n-1 bits.
Exercise 2.72

For the given special case, we can prove that for the most frequent one the
order of growth is Θ(n) and for the least frequent one Θ(n²) at the
worst case.

Data-Directed Programming and Additivity

Exercise 2.73

We can convert the symbolic differentiation system to data-directed style:

(define (deriv exp var)
  (cond ((number? exp) 0)
	((variable? exp) (if (same-variable? exp var) 1 0))
	(else ((get 'deriv (operator exp)) (operands exp) var))))

(define (operator exp) (car exp))
(define (operands exp) (cdr exp))

a.

Here we recognized the exp as typed datum as being discussed in this section,
i.e. we found that we use operator only for determining the type of procedure
to be applied at operands; this is exactly what we discussed so far. Note that
we handle the number and variable case explicitly because they aren't attached a
type– just contents. And also if we strugle to attach auxilary type to those,
our code got cluttered more than present one.

To summarize, deriv procedure do
1. Check the exp is number or variable and do the right thing for that
2. If it isn't that means it's compound expression, on which attached type. So
  deriv look up the table with operation name– deriv– and expression
  type– operator to get appropriate procedure for that expression.
3. Then apply that procedure given arguments– operands with respect to var.

b.

We can accomplish this by using analogy with the complex number representation.
Here we decide to use operator's symbol as type consistently:

(define (install-sum--package)
  ;; constructor
  (define (make-sum a1 a2)
    (cond ((=number? a1 0) a2)
	  ((=number? a2 0) a1)
	  ((and (number? a1) (number? a2)) (+ a1 a2))
	  (else (list '+ a1 a2))))
  ;; selectors
  (define (addend operands) (car operands))
  (define (augend operands) (cadr operands))
  ;; interface to the rest of the system.
  (put 'make '+ make-sum)
  (put 'addend '+ addend)
  (put 'augend '+ augend)
  ;; For differential algebraic system.
  (put 'deriv '+
       (lambda (operands var) (make-sum (deriv (addend operands) var)
					(deriv (augend operands) var))))
  'done)

(define (install-product-package)
  ;;constructor
  (define (make-product m1 m2)
    (cond ((or (=number? m1 0) (=number? m2 0)) 0)
	  ((=number? m1 1) m2)
	  ((=number? m2 1) m1)
	  ((and (number? m1) (number? m2))
	   (* m1 m2))
	  (else (list '* m1 m2))))
  ;;selectors
  (define (multiplier p) (car p))
  (define (multiplicand p) (cadr p))
  ;; interface to the rest of the system.
  (put 'make '* make-product)
  (put 'multiplier '* multiplier)
  (put 'multiplicand '* multiplicand)
  ;; For differential algebraic system
  (put 'deriv '*
       (lambda (operands var)
	 ((get 'make '+)
	  (make-product (multiplier operands)
			(deriv (multiplicand operands) var))
	  (make-product (deriv (multiplier operands) var)
			(muliplicand operands)))))
  'done)

c.

To add some additional differentiation rule, all we need to do is to install
that specific package, anything else not affected by that:

(define (install-exponentiation-package)
  ;; constructor
  (define (make-exponentiation base exponent)
    (cond ((=number? exponent 0) 1)
	  ((=number? exponent 1) base)
	  ((and (number? base) (number? exponent))
	   (expt base exponent))
	  (else (list '** base exponent))))
  ;; selectors
  (define (base ex)
    (car ex))

  (define (exponent ex)
    (cadr ex))

  ;; differentiation
  (define (deriv-expt operands var)
    (let ((make-product (get 'make '*)))
      (make-product (make-product (exponent operands)
				  (make-exponentiation (base operands) (- (exponent operands) 1)))
		    (deriv (base operands) var))))
  ;; interface
  (put 'make '** make-exponentiation)
  (put 'base '** base)
  (put 'exponent '** exponent)
  (put 'deriv '** deriv-expt)
  'done)

d.

If we changed our mind from

...
	(else ((get 'deriv (operator exp)) (operands exp) var))))
...

to

...
	(else ((get (operator exp) 'deriv) (operands exp) var))))
...

Then, in our implementation, we need change all the code in each package
according to that change:

(define (install-sum-package)
...
(put '+ 'deriv ...)
...
 'done)
(define (install-product-package)
...
(put '* 'deriv ...)
...
 'done)
(define (install-exponentiation-package)
...
(put '** 'deriv ...)
...
 'done)

Exercise 2.74

We can solve the problem by using the table which contains all the employee's
recode from all the division. As noted in the text, as the data representation
all different from division to division, to use data-directed programming, these
individual division's personal file should have type tag that indicate specific
division. Further more, we can assume that in the specific division they know
how to retrieves a specified employee's record– as mentioned in the statement
the employee's name would be supplied for specifying.
- a.
  
  We can think of get-record take personal file with employee's name specified
  for its arguments and then take off the type tag– division– from personal
  file to retrieve:
```
(define (get-record record-file employee-name)
;; we assume that each file has division name as its type.
  (let ((division (type-tag record-file)))
    ((get 'get-record division) employee-name)))
```
  Here we assume that each division put the procedure to retrieve their
  employee's record in that division to table; we can get that procedure.
  
  More formally we only require that
  - each division should attach their record file type tag, which specify their division.
  - each division should register their own method for retrieving specific
    employee's record with universal key, employee's name.
  As long as those specification satisfied, how the recored structured do not
  affect above implementation.
- b.
  
  By the same argument with a., to select specific information from given
  record we should know the division to which the employee belong. So to speak,
  each record should have division information as its type.
```
(define (get-salary record)
  (let ((division (type-tag record)))
    ((get 'get-salary division) record)))
```
  It's not our business but if get-record attach division as type to its return
  value– record, we don't need to modify any code in individual division file to
  work with above procedure.
- c.
  
  Here we only consider one record; it is possible that some employees have same
  name, but we do not consider that: as soon as we find record with name given, we
  only return that one.
  
  Here we exploit the fact that any scheme data treated as true when it used with
  boolean operation:
```
(or false 0 5)                          ;0
(and true 5)                            ;#t
```
  Using this fact, we can implement the given task:
```
(define (find-employee-record division-files employee-name)
  (fold-left (lambda (x y) (or x y))
	     false
	     (map (lambda (division-file)
		    (get-record division-file employee-name))
		  division-files)))
```
  Note that we assumed get-record return false if it couldn't find one.
- d.
  
  To incorporate with the other division, the new division should
  - attach its own division name to its personal record file,
  - register its own procedure which retrieves its employee's record to the lookup
    table,
  - also put procedure that retrieves some information from record data to the
    lookup table.
  That's it. It doesn't matter how many the employee's records under that division.
  Cool!
Message passing

I found this section discuss the skeleton of modern object oriented programming.
To consider how it connected to OOP, we should keep learning the remaining
chapters in it, but I've felt this methodology, message passing, is the most
simple object that contains all the operations that operate on given object. We
can consider the constructor of object as somewhat analogous to class
declaration:
```
(define (make-from-real-imag x y)
  (define (dispatch op)
    (cond ((eq? op 'real-part) x)
	  ((eq? op 'imag-part) y)
	  ((eq? op 'manitude)
	   (sqrt (+ (square x) (square y))))
	  ((eq? op 'angle) (atan y x))
	  (else
	   (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
  dispatch)
```

Exercise 2.75

We can do the same thing to make-from-mag-ang as above:

(define (make-from-mag-ang r a)
  (define (dispatch op)
    (cond ((eq? op 'real-part) (* r (cos a)))
	  ((eq? op 'imag-part) (* r (sin a)))
	  ((eq? op 'manitude) r)
	  ((eq? op 'angle) a)
	  (else
	   (error "Unknown op -- MAKE-FROM-MAG-ANG" op))))
  dispatch)

Exercise 2.76

We can characterizes the three strategies as following:
- data directed programming: dealing with table, i.e. 2 dimensional. We can
  add arbitrary operation or type (data) on the table without interfering
  existing code.
- dispatch on type: dealing with operation row. Each of the operation can be
  thought as individual entity. We can add new operation without altering
  existing code.
- message passing: dealing with type (data) column. Each of data can be
  thought as object which has operations that operate on it. We can add new
  data (type) additively.
With these information, we are likely to think data directed programming is
most ideal strategies to deal with big project. However, it has another edge: As
it allow maximum flexibility, the individual cells in the table get likely to
lack of connectivity. For instance, when we modeling the real world object, it
is more intuitive to implement using OOP (in this context, message passing).

I've demonstrated enough to answer the given question: For system in which new
types must often be added, message passing would be the best choice, whereas
for system in which new operations must often be added dispatch on type or
data directed programming both can be good choice as we seen in the complex
number system. If you could not determine how your system would evolves then
give data directed programming a shot; it will answer to you.

Or OOP can be thought as the one that takes both advantages of using type and the
intuitive representation of message passing.

Lecture 4A: Pattern Matching and Rule-based Substitution

In this lecture, the professor discuss the pattern matching algorithm in
general. I think it is main feature of all the functional programming language
such as Haskell, ML, Scala, and so on. In their language– especially Scala,
which I've used commercially– user also can add arbitrary pattern variable by
using special notation– case class in Scala. These feature is the instance of
application of data-directed programming so that we can modify the compiler's
behavior seamlessly.

We can introduce pattern matching feature by ourself:

(define (match pat exp dict)
  (cond ((eq? dict 'failed) 'failed)
	((not (pair? pat))
	 (if (not (pair? exp))
	     (if (eq? pat exp)
		 dict
		 'failed)
	     'failed))
	((arbitrary-constant? pat)
	 (if (constant? exp)
	     (extend-dictionary pat exp dict)
	     'failed))
	((arbitrary-variable? pat)
	 (if (variable? exp)
	     (extend-dictionary pat exp dict)
	     'failed))
	((arbitrary-expression? pat)
	 (extend-dictionary pat exp dict))
	((not (pair? exp)) 'failed)
	(else
	  (match (cdr pat)
		 (cdr exp)
		 (match (car pat)
			(car exp)
			dict)))))

(define (arbitrary-constant? pat)
  (and (pair? pat) (eq? (car pat) '?c)))

(define (arbitrary-variable? pat)
  (and (pair? pat) (eq? (car pat) '?v)))

(define (arbitrary-expression? pat)
  (and (pair? pat) (eq? (car pat) '?)))

(define (constant? exp)
  (number? exp))

(define (variable? exp)
  (symbol? exp))

(define (instantiate skeleton dict)
  (define (loop s)
    (cond ((not (pair? s)) s)
	  ((skeleton-evaluation? s)
	   (evaluate (eval-exp s) dict))
	  (else (cons (loop (car s))
		      (loop (cdr s))))))
  (loop skeleton))

(define (skeleton-evaluation? s)
  (and (pair? s) (eq? (car s) ':)))

(define (eval-exp s)
  (cadr s))

(define (simplifier the-rules)
  ; (define (simplify-exp exp)
  ;   (try-rules (if (compound? exp)
  ;                  (simplify-parts exp)
  ;                  exp)))
  ; (define (simplify-parts exp)
  ;   (if (null? exp)
  ;       '()
  ;       (cons (simplify-exp (car exp))
  ;             (simplify-parts (cdr exp)))))
  ;; Another idiom
  (define (simplify-exp exp)
    (try-rules
      (if (compound? exp)
	  (map simplify-exp exp)
	  exp)))
  (define (try-rules exp)
    (define (scan rules)
      (if (null? rules)
	  exp
	  (let ((dict
		  (match (pattern (car rules))
			 exp
			 (empty-dictionary))))
	    (if (eq? dict 'failed)
		(scan (cdr rules))
		(simplify-exp
		  (instantiate
		    (skeleton (car rules))
		    dict))))))
    (scan the-rules))
  simplify-exp)

(define (pattern rule)
  (car rule))

(define (skeleton rule)
  (cadr rule))

(define (compound? exp) (pair? exp))

(define (evaluate form dict)
  (if (not (pair? form))
      (lookup form dict)
      (apply
	(eval (lookup (car form) dict)
	      user-initial-environment)
	(map (lambda (v)
		  (lookup v dict))
		(cdr form)))))

(define (empty-dictionary) '())

(define (extend-dictionary pat dat dict)
  (let ((name (variable-name pat)))
    (let ((v (assq name dict)))
      (cond ((not v)
	     (cons (list name dat) dict))
	    ((eq? (cadr v) dat) dict)
	    (else 'failed)))))

(define (variable-name pat)
  (cadr pat))

(define (lookup var dict)
    (let ((v (assq var dict)))
      (if (not v) var (cadr v))))

;; (cdr '(x . y))                          ;y

(define deriv-rules
  '(
    ( (dd (?c c) (? v))         0           )
    ( (dd (?v v) (? v))         1           )
    ( (dd (?v u) (? v))         0           )

    ( (dd (+ (? x1) (? x2)) (? v))
      (+ (dd (: x1) (: v))
	 (dd (: x2) (: v)))                 )
    ( (dd (* (? x1) (? x2)) (? v))
      (+ (* (: x1) (dd (: x2) (: v)))
	 (* (dd (: x1) (: v)) (: x2)))      )
    ))

(define algebra-rules
  '(
    (((? op) (?c e1) (?c e2))
     (: (op e1 e2)))
    (((? op) (? e1) (?c e2))
     ((? op) (: e2) (: e1)))
    ((+ 0 (? e))
     (: e))
    ((* 1 (? e))
     (: e))
    ((* 0 (? e))
     0)
    ((* (?c e1) (* (?c e2) (? e3)))
     (* (: (* e1 e2)) (: e3)))
    ((* (? e1) (* (?c e2) (? e3)))
     (* (: e2) (* (: e1) (: e3))))
    ((* (* (? e1) (? e2)) (? e3))
     (* (: e1) (* (: e2) (: e3))))
    ((+ (?c e1) (+ (?c e2) (? e3)))
     (+ (: (+ e1 e2)) (: e3)))
    ((+ (? e1) (+ (?c e2) (? e3)))
     (+ (: e2) (+ (: e1) (: e3))))
    ((+ (+ (? e1) (? e2)) (? e3))
     (+ (: e1) (+ (: e2) (: e3))))
    ((+ (* (?c c) (? a)) (* (?c d) (? a)))
     (* (: (+ c d)) (: a)))
    ((* (? c) (+ (? d) (? e)))
     (+ (* (: c) (: d)) (* (: c) (: e))))
    ))

Then we can calculate length of list like Standard ML:

(define length-list
  '(
    ((ll ()) 0)                         ;base case
    ((ll ((? x) . (? y))) (+ 1 (ll (: y)))) ;recursive case
    ))

((simplifier length-list) '(ll (x y z))) ;(+ 1 (+ 1 (+ 1 0)))
((simplifier algebra-rules) ((simplifier length-list) '(ll (x y z)))) ;3

Note that here as we don't used stack for recursive process, we have to stack up
explicitly using symbols; then we simplify using algebraic rules.

Then we can test the previous deriv test using dsimp:

(define dsimp
  (simplifier deriv-rules))
(define asimp
  (simplifier algebra-rules))
(deriv '(* (* x y) (+ x 3)) 'x)         ;(+ (* x y) (* y (+ x 3)))
(asimp (dsimp '(dd (* (* x y) (+ x 3)) x))) ;(+ (* x y) (+ (* 3 y) (* y x)))

Well, we need more clever algebraic simplifying rules here.

Systems with Generic Operations

Generic Arithmetic Operations

Now we want to integrate all the arithmetic system to generic arithmetic system;
that is, by just using add we want to add whatever arithmetic type that we
constructed so far: rational numbers, complex numbers, and primitive numbers in
scheme.

To do so, first we should attach tag at each arithmetic system for
data-directed programming. After that we use the generic arithmetic by using
apply-generic as we did in section 2.4.3:

(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))

For the primitive numbers, all we need to do is just attach tag on each
construction:

(define (install-scheme-number-package)
  (define (tag x)
    (attach-tag 'scheme-number x))
  (put 'add (scheme-number scheme-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub (scheme-number scheme-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul (scheme-number scheme-number)
       (lambda (x y) (tag (* x y))))
  (put 'div (scheme-number scheme-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'scheme-number
       (lambda (x) (tag x)))
  'done)

And user of this package would access constructor by following procedure:

(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))

Exploiting data-directed programming, we don't need modify any parts of
previous code; we just add the put s for interfacing others.

Here we show the complex number package for instance, rational numbers can be
implemented similarly (see text book):

(define (install-complex-package)
  ;; improted procedures from rectangular and polar packages
  (define (make-from-real-imag x y)
    ((get 'make-from-real-imag 'rectangular) x y))
  (define (make-from-mag-ang r a)
    ((get 'make-from-mag-ang 'polar) x y))
  ;; internal procedure
  (define (add-complex z1 z2)
    (make-from-real-imag (+ (real-part z1) (real-part z2))
			 (+ (imag-part z1) (imag-part z2))))
  *** other procedures goes here
  ;; interface to rest of the system
  (define (tag z) (attach-tag 'complex z))
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
  *** other procedures goes here
  (put 'make-from-real-imag 'complex
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'complex
       (lambda (r a) (tag (make-from-mag-ang r a))))
  'done)

Then users can call the constructor granted the procedure:

(define (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
  ((get 'make-from-mag-ang 'complex) r a))

Exercise 2.77

By calling
```
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
```
we can call each selector for complex number. How? let's trace the call, for
instance here we call the magnitude:
1. Call (magnitude (make-complex-from-mag-ang r a)). Then
2. By the definition of
```
(define (magnitude z) (apply-generic 'magnitude z))
```
  (magnitude z) call apply-generic (here we abbreviated the object as z)
3. Then apply generic strip the type tag– complex type– and look up the operation-type table
  to get appropriate operation to apply. By above put s, the returned
  operation is also magnitude; then apply that procedure to contents of z
4. We do the same thing as step 3. but with 'polar tag; then apply-generic
  get (lambda (z) (car z)) to apply with contents of (r . a).
5. It return r as expected.
So to summarize, the number of invoking apply-generic is 2 and the first
dispatch returns magnitude which we just started with and then the last
dispatch do the real work.

Exercise 2.78

To exploit the internal type system of scheme, we should modify the procedures
that we made for type: type-tag, contents, attach-tag. The naive approach
would add conditional clause that check whether it has internal type:

(define (attach-tag type-tag contents)
  (cond ((number? contents) contents)   ;do nothing: it has internal type system
;; We can add more primitive data here
	(else (cons type-tag contents))))
(define (type-tag datum)
  (cond ((pair? datum) (car datum))
	((number? datum) 'scheme-number)
;; other primitive goes here
	(else (error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
  (cond ((pair? datum) (cdr datum))
	((number? datum) datum)
	(else (error "Bad tagged datum -- CONTENTS" datum))))

Or we can accomplish this data-directed style (revised):

(define (attach-tag type-tag contents)
  (cond ((number? contents) contents)   ;do nothing: it has internal type system
;; We can add more primitive data here
	(else (cons type-tag contents))))
(define (type-tag datum)
  (cond ((pair? datum) (car datum))
	((number? datum) ((get 'type 'scheme-number) datum)) ;data-directed programming
;; other primitive goes here
	(else (error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
  (cond ((pair? datum) (cdr datum))
	((number? datum) datum)
	(else (error "Bad tagged datum -- CONTENTS" datum))))

~~Then we don't need change any parts of previous code.~~
Then we need to change scheme-number package accordingly:

(define (install-scheme-number-package)
  (define (scheme-number-type num)      ;actually this means we implemented abstract class scheme-number.
    (cond ((and (integer? num) (exact? num)) 'integer)       ;inter? -> exact? for cope with (raise (raise (raise 5)))
	  ((real? num) 'real)
	  (else (error "Unknown scheme number -- SCHEME-NUMBER-TYPE" num))))
  (put 'type 'scheme-number scheme-number-type) ;for type tag
  (put 'make 'real exact->inexact)
  (put 'make 'integer inexact->exact)
  (define subtypes '(real integer))
  (for-each
   (lambda (t1)
     (for-each
      (lambda (t2)
	(for-each
	 (lambda (op)
	   (put (car op) (list t1 t2)
		(lambda (x y) ((cdr op) x y))))
	 (list (cons 'add +) (cons 'sub -) (cons 'mul *) (cons 'div /))))
      subtypes)
     (put 'make t1 identity-procedure)  ;do nothing just warpping.
     )
   subtypes)
  'done)

(define make-real (get 'make 'real))
(define make-integer (get 'make 'integer))

Exercise 2.79

We can do this by either modifying each arithmetic packages or adding new
package that add equ?. Here we implement the latter one:

;; Exercise 2.79
(define (install-equ-package)
  ;; import from rational number package
  (define (numerator r) ((get 'numerator '(rational)) r))
  (define (denominator r) ((get 'denominator '(rational)) r))
  ;; internal procedures
  (define scheme-types '(real integer))
  (for-each (lambda (type) (put 'equ? (list type type) =)) scheme-types)
  (put 'equ? '(rational rational) (lambda (r1 r2)
				   (and (= (numerator r1) (numerator r2))
					(= (denominator r1) (denominator r2)))))
  (put 'equ? '(complex complex) (lambda (c1 c2)
				 (and (= (real-part c1) (real-part c2))
				      (= (imag-part c1) (imag-part c2)))))
  'done)

(define (equ? x y) (apply-generic 'equ? x y))

Here we assumed that the selectors of rational number– numer, denom–
generally accessible somehow. We can accomplish this adding that procedures in
operation-type table in rational number package.

Exercise 2.80

Here we use equ? for implementing =zero? and also exploit the fact
(= 0.0 0); #t for ordinary number:

(define (install-zero-package)
  ;; import from rational number package
  (define (numerator r) ((get 'numerator '(rational)) r))
  (define (denominator r) ((get 'denominator '(rational)) r))

  (define scheme-types '(real integer))
  (for-each (lambda (type) (put '=zero? (list type) (lambda (e) (equ? e 0)))) scheme-types)
  (put '=zero? '(rational) (lambda (r) (equ? (numerator r) 0)))
  (put '=zero? '(complex) (lambda (c)
				   (equ? (attach-tag 'complex c) (make-complex-from-real-imag 0 0))))
  'done)

(define (=zero? x) (apply-generic '=zero? x))

Combining Data of Different Types

Exercise 2.81

We have apply-generic that cope with coercion:

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
	  (apply proc (map contents args))
	  (if (= (length args) 2)
	      (let ((type1 (car type-tags))
		    (type2 (cadr type-tags))
		    (a1 (car args))
		    (a2 (cadr args)))
		(let ((t1->t2 (get-coercion type1 type2))
		      (t2->t1 (get-coercion type2 type1)))
		  (cond (t1->t2
			 (apply-generic op (t1->t2 a1) a2))
			(t2->t1
			 (apply-generic op a1 (t2->t1 a2)))
			(else
			 (error "No method for these types"
				(list op type-tags))))))
	      (error "No method for these types"
				(list op type-tags)))))))

a.

As t1->t2 is not false by the self coercion method, we get into infinite loop.
b.

It works as it is. Note that in the sub clause of t1->t2 we call again
apply-generic with coerced types; if we coerced already to the same type, and
then also the operation for that types doesn't exist on table, it get into
coerce check again, but this time fails as it should since the coercion to its
own type is not defined at all. However as it is, it has overhead that lookup
the table for checking whether there exist coercion to same type. We can avoid this.

c.

Result:

(define (apply-generic op . args)
  (define (raise-exception)
    (error "No method for these types"
		       (list op type-tags)))
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
	  (apply proc (map contents args))
	  (if (= (length args) 2)
	      (let ((type1 (car type-tags))
		    (type2 (cadr type-tags))
		    (a1 (car args))
		    (a2 (cadr args)))
		(if (not (eq? type1 type2))
		    (let ((t1->t2 (get-coercion type1 type2))
			  (t2->t1 (get-coercion type2 type1)))
		      (cond (t1->t2
			     (apply-generic op (t1->t2 a1) a2))
			    (t2->t1
			     (apply-generic op a1 (t2->t1 a2)))
			    (else
			     (raise-exception))))
		    (raise-exception))
		(raise-exception))))))

It's messy.

Exercise 2.82

Extend to arbitary number of operands in apply-generic. Let first we try what
the text suggested: To attempt to coerce all the arguments to the type of the
first argument, then to the type of the second arguemnt, and so on.

Here is the algorithm:

Take one type to which all the arguments to be tried to coerce.
Then coerce each argument (except the one that taken as "to type" argument).
Then try to get operation with coerced types.
Keep doing from 1 to 3 steps until either such operation found or tried all
of the types of given argument (this time we should error appropriately).

It is reasonable to define the step 2 procedure standalone unit. Also this unit
can be decomposed to

check whether such coerce procedure exist,

(define (try-coerce-> type types)
  (let ((coercions
	 (map (lambda (t)
	   (if (eq? t type)
	       identity-procedure       ;return taken argument itself
	       (get-coercion t type)))
	      types)))
    (let ((exist?
	   (fold-left (lambda (x y) (and x y))
		      true
		      coercions)))
      (if exist?
	  coercions
	  false))))

if it exists, then apply to each arguments.

(define (apply-each procs args) ;provided that these are same length
  (if (null? procs)
      '()
      (cons ((car procs) (car args))
	    (apply-each (cdr procs) (cdr args)))))

Armed with this, we can implement what we want using signal processing scheme:

(define (apply-generic op . args)
  (define (raise-exception)
    (error "no method for these types"
		       (list op type-tags)))
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (cond (proc (apply proc (map contents args)))
	    ((fold-left (lambda (t1 t2) ;check whether all the types are same
			  (if t1
			      (if (eq? t1 t2)
				  t1
				  false)
			      false))
			type-tags)
	     (raise-exception))         ;error
	    (else
	     (let ((result (fold-left (lambda (x y) (or x y))
				      false
				      (map (lambda (tArgs)
					     (let ((types (map type-tag tArgs)))
					       (let ((tProc (get op types)))
						 (if tProc
						     (cons tProc (map contents tArgs))
						     false))))
					   (map (lambda (coercions)
						  (apply-each coercions args))
						(filter identity-procedure
							(map (lambda (type)
							       (try-coerce-> type type-tags))
							     type-tags)))))))
	       (if result
		   (apply (car result) (cdr result))
		   (raise-exception))))))))

It's total mess. Can you read this? Even for me it's hard to understand there're
a lot of tricks; I should refactor my procedure.

Let think about the situation where this strategy don't work. For instance, we
can think the circumstance where we got task that implement matrix in our
arithmetic systems. In that system, we have to implement scalar multiplication
of matrix; as we wanted to make our system as general as possible, we have
chosen to implement that with complex number (the supremum type of number
system). And our user used that procedure with integer number; however it gives
an error saying "no method for these types". What happend? Think about it.

This time let we try the refactoring. There's no end for it.

Try 1: Extract common pattern

(define (apply-generic op . args)
  (define (raise-exception)
    (error "no method for these types"
		       (list op type-tags)))
  (define (try aArgs types?)
    (let ((type-tags (if types?
			 types?
			 (map type-tag aArgs))))
      (let (proc (get op type-tags))
	(if proc
	    (cons proc (map contents aArgs))
	    false))))
  (let ((type-tags (map type-tag args)))
    (let ((procPair (try args type-tags)))
      (cond (procPair (apply (car procPair) (cdr procPair)))
	    ((fold-left (lambda (t1 t2) ;check whether all the types are same
			  (if t1
			      (if (eq? t1 t2)
				  t1
				  false)
			      false))
			type-tags)
	     (raise-exception))         ;error
	    (else
	     (let ((result (fold-left (lambda (x y) (or x y))
				      false
				      (map (lambda (tArgs)
					     (try tArgs false))
					   (map (lambda (coercions)
						  (apply-each coercions args))
						(filter identity-procedure
							(map (lambda (type)
							       (try-coerce-> type type-tags))
							     type-tags)))))))
	       (if result
		   (apply (car result) (cdr result))
		   (raise-exception))))))))

Well, it's still mess; as I've exploited signal interface I'm persuading myself
that it's the style of that.

Conclusion

You have to consider or design the algorithm thoroughly until the end; otherwise
if you jump in the middle of that like me, you get in such trouble.

Let's try thorough design in signal processing scheme:

Take type list
Filter it with have coercion to?
Filter it with have such operation?
If it is null signal error else
Then apply args coerce to car of it
and then apply found operation to it's contents

We can do these by wishful thinking and using conventional interface. Now we
should implement the auxiliary procedures

have-coercion-to?

We can accomplish this amending try-coerce->:

(define (have-coercion-to? type types)
  (fold-left (lambda (x y) (and x y))
	     true
	     (map (lambda (t)
		    (if (eq? t type)
			identity-procedure       ;return taken argument itself
			(get-coercion t type)))
		  types)))

have such operation?

To implement this we should supply length of args to test with (get op type); this is no problem if we define these procedure in the apply-generic:
```
(define (have-such-operation? type)
  (get op (map (lambda (t) type)
	       args)))
```

Put together

(define (apply-generic op . args)
  (define (raise-exception)
    (error "no method for these types"
	   (list op type-tags)))
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (cond (proc (apply proc (map contents args)))          ;base case?
	    ((have-same-types? type-tags) (raise-exception)) ;error
	    (else
	     (coerce-and-apply op args type-tags raise-exception))))))

(define (coerce-and-apply op args types exception)
  (define (have-coercion-to? type)
    (fold-left (lambda (x y) (and x y))
	       true
	       (map (lambda (t)
		      (if (eq? t type)
			  identity-procedure       ;return taken argument itself
			  (get-coercion t type)))
		    types)))
  (define (have-such-operation? type)
    (get op (map (lambda (t) type)
		 args)))
  (let ((avail-type (filter have-such-operation?
			    (filter have-coercion-to?
				    types))))
    (if (null? avail-type)
	(exception)
	(let ((type (car avail-type)))
	  (let ((proc (get op (map (lambda (t) type)
				  types)))
	       (coerced-args (apply-each
			       (map (lambda (t)
				      (if (eq? t type)
					  identity-procedure
					  (get-coercion t type)))
				    types)
			       args)))
	   (apply proc coerced-args))))))

(define (have-same-types? types)
  (fold-left (lambda (t1 t2) ;check whether all the types are same
	       (if t1
		   (if (eq? t1 t2)
		       t1
		       false)
		   false))
	     (car types)
	     (cdr types)))

Here we used apply-each, which defined before.

Let's test:

(define (install-test)
  (put 'add '(real real real real) +)
  (put-coercion 'integer 'real exact->inexact)
  (add 5.4 3 2 .43))

And to support arbitrary arguments in add procedure:

(define (add . xs) (apply apply-generic (cons 'add xs)))

Then the test return 10.83. Works well.

Way better. Isn't it?

Exercise 2.83

Here we also implement this feature as one isolated package. This is
straightforward:

(define (install-raise)
  ;; import from ratinal number
  (define numer (get 'numerator '(rational)))
  (define denom (get 'denominator '(rational)))
  ;; internal procedures
  (define (real->complex num)
    (make-complex-from-real-imag num 0))
  (define (rational->real num)
    (make-real (/ (numer num) (denom num))))
  (define (integer->rational num)
    (make-rational num 1.0))
  ;; interface to rest system
  (put 'raise '(integer) integer->rational)
  (put 'raise '(rational) rational->real)
  (put 'raise '(real) real->complex)
  'done)

We've already coped with this situation in previous exercise.

Exercise 2.84

Here is the algorithm:

Check all the arguments' type are in tower:

(define tower '(integer rational real complex))

Then, check all the types are equal (apply-generic handles the first check).
If not, raise the arguement whose type is the subtype of others.
Do step 3 until all the types are equal. Then apply apply-generic to it.

To find the argument whose type is minimum in the arguments,
we need to devise the method of comparing the rank of types. The easiest way
is mapping type to rank

Maps the type to rank number.
Then compare the numbers!

Here is the mapping procedure:

(define (type->rank type)
  (define (iter towerstack)
    (cond ((null? towerstack)
	   (error "given type not included in tower TYPE->RANK" type))
	  ((eq? (car towerstack) type) (length towerstack))
	  (else (iter (cdr towerstack)))))
  (iter tower))

Or, more straightforward encoding would be

Let assume that we compare two types in the tower.
If latter type is in the former's supertype then former < latter.
else, former ≥ latter.

(define (type< t1 t2)
  (define (super-of-t1 towerstack)
    (cond ((null? towerstack)
	   (error "given type not included in tower TYPE<" t1))
	  ((eq? (car towerstack) t1) (cdr towerstack))
	  (else (super-of-t1 (cdr towerstack)))))
  (element-of-set? t2 (super-of-t1 tower)))

Using this, we can find the minimum type in given types:

(define (mintype types)                 ;provided that types are in tower
  (fold-left (lambda (t1 t2)
	       (if (type< t1 t2)
		   t1
		   t2))
	     (car types)
	     (cdr types)))

Here is the result:

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags))
	  (raise-exception
	    (lambda () (error "no method for these types"
			      (list op type-tags)))))
      (cond (proc (apply proc (map contents args)))          ;base case?
	    ((have-same-types? type-tags) (raise-exception)) ;error
	    ((all-in-tower? type-tags)
	     (apply
	      apply-generic
	      (cons op
		    (do-until raise-minimum
			      (lambda (args)
				(have-same-types? (map type-tag args)))
			      (raise-minimum args)))))
	    (else
	     (coerce-and-apply op args type-tags raise-exception))))))

We capture the common procedure pattern by

(define (all-in-tower? types)
  (fold-left (lambda (t1 t2)
	       (and t1
		    (element-of-set? t2 tower)))
	     true
	     types))

(define (raise-minimum args)
  (let ((minT (mintype (map type-tag args))))
    (map (lambda (arg)
	   (if (eq? (type-tag arg) minT)
	       (raise arg)
	       arg))
	 args)))

(define (do-until proc pred args)
  (define (iter args)
    (if (pred args)
	args
	(iter (proc args))))
  (iter args))

And we can test this feature:

(add (make-complex-from-real-imag 5 3) 5 (make-rational 9 16) 5.3)
;; (complex rectangular 15.8625 . 3)

We used generalized version of arithmetic operations:

(define (add . xs)
  (fold-left (lambda (x y)
	       (apply-generic 'add x y))
	     (car xs)
	     (cdr xs)))
(define (sub . xs)
  (fold-left (lambda (x y)
	       (apply-generic 'sub x y))
	     (car xs)
	     (cdr xs)))
(define (mul . xs)
  (fold-left (lambda (x y)
	       (apply-generic 'mul x y))
	     (car xs)
	     (cdr xs)))
(define (div . xs)
  (fold-left (lambda (x y)
	       (apply-generic 'div x y))
	     (car xs)
	     (cdr xs)))

Exercise 2.85

Implementing proeject

As implied in text– avoided to project 1.5 to rational, in fact, the
projection from real to rational is quite complicate process. For
simplicity, we also avoid the projection from real to rational.

(define (install-project)
  ;; internal procedures
  (define (complex->real num)
    (make-real (real-part num)))
  (define (real->integer num)
    (make-integer (round num)))
  (define (rational->integer num)
    (make-integer (round (raise num)))) ;depends on raise package
  ;; interface to rest system
  (put 'project '(rational) rational->integer)
  (put 'project '(real) real->integer)
  (put 'project '(complex) complex->real)
  'done)

Implementing drop

We can deduce rules from the text:
1. Check whether project defined with respect to the given argument
2. If it is, then try drop one level: Project it and raise to what we started
  with and then check it equals to given argument using equ? then project one
  level.
3. Do step 2 until neither step 1 is satisfied nor step 2.
The result:
```
(define (drop term)
  (let ((type (type-tag term)))
    (cond ((not (get 'project type))
	   term)
	  (else
	   (let ((drop-1 (project term)))
	     (if (equ? term
		       (do-until raise
				 (lambda (arg)
				   (eq? (type-tag arg)
					type))
				 drop-1))
		 (drop drop-1)
		 term))))))
```

Put together to apply-generic

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags))
	  (raise-exception
	    (lambda () (error "no method for these types"
			      (list op type-tags)))))
      (cond (proc (drop (apply proc (map contents args))))   ;simply result
	    ((have-same-types? type-tags) (raise-exception)) ;error
	    ((all-in-tower? type-tags)
	     (apply
	      apply-generic
	      (cons op
		    (do-until raise-minimum
			      (lambda (args)
				(have-same-types? (map type-tag args)))
			      (raise-minimum args)))))
	    (else
	     (coerce-and-apply op args type-tags raise-exception))))))

Let's test:

(add (raise 5) (raise (raise (raise 5)))) ;fall into infinite loop!!

Uoh, it falls into infinite loop! It's because raise itself applied by drop,
and then drop apply raise …

We have to revise this. Note that we don't want to drop every result of
apply-generic; for now, it is sufficient to drop the result of clause,
all-in-tower?. Then let's redo our test:

(add (raise 5) (raise (raise (raise 5)))) ;10

Okay, let's move on.

Exercise 2.86

If we can convert all the arithmetic operations used in rectangular and polar
package to generic arithmetic operations, then complex number can be made by
arbitrary type generic arithmetic system supports.

Here we jot down what operations need to be conversed:

For rectangular package:
sqrt, atan, +, *, sin, cos, square
For polar package:
*, +, cos, sin, atan, sqrt, square
For complex package:
+, /, *, -

So, as consequence, we only need to convert the followings:

sqrt, sin, cos, atan, square
+, -, *, /

The latter ones are easy: We already have the generic operations namely, add,
sub, mul, div.

For the former ones, some of these are hard to think in the domain of complex
number, so we constrain the domain of procedure to real:

(define (raise-until upper x)
  (do-until raise
	    (lambda (arg)
	      (eq? (type-tag arg) upper))
	    x))
(define (make-general<= utype op opname)
  (lambda (x) (let ((type (type-tag x)))
		(cond ((type< type utype)           ;the domain of procedure is until utype
		       (op (raise-until utype x)))
		      ((eq? type utype)
		       (op x))
		      (else
			(error (string-append "Bad argument type -- " opname) x))))))

(define squareroot
  (make-general<= 'real sqrt "SQUARROOT"))

(define sine
  (make-general<= 'real sin "SINE"))

(define cosine
  (make-general<= 'real cos "COSINE"))

(define (arctan y x)
  (let ((yT (type-tag y))
	(xT (type-tag x))
	(upper 'real))
    (cond ((and (or (type< yT upper)
		    (eq? yT upper))
		(or (type< xT upper)
		    (eq? xT upper)))
	   (atan (raise-until upper y)
		 (raise-until upper x)))
	  (else
	   (error "Bad arguments -- ARCTAN" y x)))))

(define (square-gen x)
  (mul x x))

Then the rest is simple.

Then we should test it:

(add (make-complex-from-real-imag (make-rational 5 2) 3)
     (make-complex-from-mag-ang (make-rational 3 2) 3.2))
;; (complex rectangular 1.0025578363078704 . 2.91243878485863)

Work!

Example: Symbolic Algebra

In this section we will make a new language that manipulate symbolic algebra. As
we have learned from chapter 1, to construct powerful language⁵ we need to
specify

primitives
means of combination
means of abstraction
capturing common pattern

We can think numbers and variables as primitives in symbolic algebra; then we
can compound that primitives using operations like addition and multiplication.
As we embed the language we develop in scheme, we naturally inherite the means
of abstraction of scheme, namely define. For capturing common pattern, we have
two method for that: data-directed programming and closure property; with
combination of these, we can obtain generic arithmetic system we developed until
previous section but now extends this as encompass symbolic algebra.

Actually we have construct "partially" the symbolic algebra system when we dealt
with symbolic differentiation in section 2.3.2. In there, we used scheme's
special expression quote for representing varibles, and used scheme's number
system as representing numbers. We can exploit this fact or not: We don't need
worry about that in this step; we can defer this implementation detail later.

Let's recap what we've learned in previous section. We've learned the concept
abstract data type, generic operations that operates on various data type,
data-directed programming that enables us to develop each part of language
individually without any interfering with others.

Abstract data type is something that captures the common pattern or natural
entity which combines some data relevant with it. In the context of symbolic
algebra, we can think of linear combination, polynomial, rational function, or
trigonometric fucntion as common pattern where we organize symbolic entities; so
we can think these pattern as type in foregoing dialogue.

Here we construct polynomial data type for the start. To encode polynomial into
computer language, first, we need to specify what the polynomial is. For
simplicity, as wrote in text book, we only consider the univariate polynomial
and also we consider polynomial syntactically, i.e. (x^{2}+x+1) is different
from (y^{2}+y+1) although these have the same structure.

Now we consider the arithmetic on polynomials. First, we construct the system
about addition and multiplication and then we can add other operations using
data-directed programming as we did before. We use abstract data type for
representing polynomials, which would add flexibilities to our system. To
interfacing with abstract data type we need to specify what the constructor is
and what the selectors are, in other words, we need to deduce contract between
constructor of polynomial and selectors, which encode the properties of
polynomials naturally. For this task, we can play with polynomials for a while,
if you are done with this stuff, then you can deduce

polynomials are composed by a variable that is dominant in our univariate
polynomial with term list where each term consist of its order and coefficient.
So, for constructing the polynomial we need to hand over term list and
variable,
and then we have to select each part of it, i.e. variable and term list appropriately.

Note that we installed abstract layer under the polynomials– term and term
list; we separated the variable from its term. As we designing polynomials using
term (and its list), we can assume that terms can be combined using addition and
multiplication and so on. With this buildings, we can construct concretely
polynomial arithmetic using the abstract data type:

(define (arith-poly term-op opname)
  (lambda (p1 p2)
    (if (same-variable? (variable p1) (variable p2))
	(make-poly (variable p1)
		   (term-op (term-list p1)
			    (term-list p2)))
	(error (string-append "Polys not in the same var -- " opname) (list p1 p2)))))

(define add-poly
  (arith-poly add-terms "ADD-POLY"))
(define mul-poly
  (arith-poly mul-terms "MUL-POLY"))

Here we used same-variable? that we defined in section 2.3.2 as we noted since
underlying primitives are same.

We are done with the very top level of our language, now we should tackle with
the lower level language, terms. We need to deduce the rules to terms as we did
with polynomial. Note that terms, or more precisely term list, consist of term.
So syntactically we can think term list constructed using term, i.e. there are
two language namely individual term langauge, term list language that using term.

This time, let we think about constructing term list using underlying term
language. Note that term list, as its name implies, having lots of analogy with
list data structure; so using that analogy, we can construct the rules that
govern term list as

constructors: - (adjoin-term term term-list) that adjoin a term at the very
beginning of term-list, which is analogous to cons.
- (the-empty-termlist) returns empty termlist upon which we keep constructing
  complex term list. This is analogous to nil.
selectors: - (first-term term-list) returns the first term in the term-list, which
is analogous to car.
- (rest-terms term-list) returns the term list but the first term, which
  is analogous to cdr.
predicates: (empty-termlist? L) return true when L has no term in it,
else false. That is analogous to null?

In addition with these, we make contract with these that first-term returns
the highest order of term in the term list. And adjoin-term adds term to the
term list and resulting term list in decreasing order in order of term. We could
make this assumption into our code to validate this contract; but for now, we
just relying on these verbal contract.

With these set up we can implement the operations on term list, for the term
language let us construct that as we go:

(define (add-terms L1 L2)
  (cond ((empty-termlist? L1) L2)
	((empty-termlist? L2) L1)
	(else
	 (let ((t1 (first-term L1)) (t2 (first-term L2)))
	   (cond ((< (order t1) (order t2))
		  (addjoin-term
		   t2
		   (add-terms L1
			      (rest-terms L2))))
		 ((> (order t1) (order t2))
		  (addjoin-term
		   t1
		   (add-terms L2
			      (rest-terms L1))))
		 (else
		  (adjoin-term
		   (make-term (order t1)
			      (add (coeff t1) (coeff t2)))
		   (add-terms (rest-terms L1)
			      (rest-terms L2)))))))))

Here we used what we wish to have in term language:

construtor: make-term that takes order of the term (integer) with coefficient
selectors: - order that return the order of given term,
- coeff that return the coefficient of given term.

Also note that here we used add rather than + to incorporate the generic
arithmetic system in term, i.e. we can take complex number as coefficient of
term or even more, if we install our polynomial system into our generic
arithmetic system, then term can take polynomial as its coefficient, which is
equivalent to express the full multivariate polynomial in our system.

Multiplication of terms are litte more trickey. To deduce the algorithm, we can
play with multiplication of polynomials in hand using the knowledges of middle
school algebra. We can break down the whole process by

multiply each term of the first addend by the second addend term list
and then add each of these results using add-terms

We can accomplish these procedure using recursive definiiton:

(define (mul-terms L1 L2)
  (if (empty-termlist? L1)
      (the-empty-termlist)
      (add-terms (mul-term-by-all-terms (first-term L1) L2)
		 (mul-terms (rest-terms L1) L2))))

(define (mul-term-by-all-terms t1 L)
  (if (empty-termlist? L)
      (the-empty-termlist)
      (let ((t2 (first-term L)))
	(addjoin-term (make-term (+ (order t1) (order t2))
				 (mul (coeff t1) (coeff t2)))
		      (mul-term-by-all-term t1 (rest-terms L))))))

Note that here we also used mul instead of * with the same reason above.

Representing term lists

Here we made contract that interface term list as a ordered list in decreasing
order in order of term. We could represent the term list as a set of
coefficients keyed by the order of the term or we could let the order of term
incoporated as index of term in the list– list of coefficients.

The major factor that determine which is better is density. For the
sparse⁶, the former would be more appropriate; while for the dense
polynomial the latter would be more efficient. Or we could install both
representation simultaneously like rectangular and polar representation of
complex number. Let we first follow the text's flow– the former one:

(define (adjoin-term term term-list)
  (if (=zero? (coeff term))
      term-list
      (cons term term-list)))

(define (the-empty-termlist) '())
(define (first-term term-list) (car term-list))
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))

Finally we can install our polynomial package into our generic arithmetic
package:

(define (install-polynomial-package)
  ;; internal procedures
  ;; representation of poly
  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  ;;[procedures same-variable? and variable? from section 2.3.2]

  ;; representation of terms and term lists
  ;;[procedures adjoin-term ... coeff from text below]

  ;;(define (add-poly p1 p2) ... )
  ;;[procedures used by add-poly]

  ;;(define (mul-poly p1 p2) ... )
  ;;[procedures used by mul-poly]

  ;; interface to rest of the system
  (define (tag p) (attach-tag 'polynomial p))
  (put 'add '(polynomial polynomial)
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial polynomial)
       (lambda (p1 p2) (tag (mul-poly p1 p2))))

  (put 'make 'polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  'done)

(define (add-terms L1 L2)
  (cond ((empty-termlist? L1) L2)
	((empty-termlist? L2) L1)
	(else
	 (let ((t1 (first-term L1)) (t2 (first-term L2)))
	   (cond ((> (order t1) (order t2))
		  (adjoin-term
		   t1 (add-terms (rest-terms L1) L2)))
		 ((< (order t1) (order t2))
		  (adjoin-term
		   t2 (add-terms L1 (rest-terms L2))))
		 (else
		  (adjoin-term
		   (make-term (order t1)
			      (add (coeff t1) (coeff t2)))
		   (add-terms (rest-terms L1)
			      (rest-terms L2)))))))))

(define (mul-terms L1 L2)
  (if (empty-termlist? L1)
      (the-empty-termlist)
      (add-terms (mul-term-by-all-terms (first-term L1) L2)
		 (mul-terms (rest-terms L1) L2))))

(define (mul-term-by-all-terms t1 L)
  (if (empty-termlist? L)
      (the-empty-termlist)
      (let ((t2 (first-term L)))
	(adjoin-term
	 (make-term (+ (order t1) (order t2))
		    (mul (coeff t1) (coeff t2)))
	 (mul-term-by-all-terms t1 (rest-terms L))))))


;; Representing term lists

(define (adjoin-term term term-list)
  (if (=zero? (coeff term))
      term-list
      (cons term term-list)))

(define (the-empty-termlist) '())
(define (first-term term-list) (car term-list))
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))

(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))

Exercise 2.87

We installed =zero? package independently from each arithmetic package so far;
however more aggregate the code in that package, harder it gets to maintain. So
I've decided to distribute each =zero? procedure to relevant package. Here is
that procedure for polynomial:

(put '=zero? '(polynomial) (lambda (p) (empty-termlist? (term-list p))))

In addition, I've implemented the equ? package to polynomial:

;; equ package
(define (equ-poly? p1 p2)
  (and (same-variable? (variable p1) (variable p2))
       (equ-terms? (term-list p1) (term-list p2))))
(define (equ-terms? L1 L2)
  (cond ((empty-termlist? L1) (empty-termlist? L2))
	((empty-termlist? L2) false)
	(else
	 (let ((t1 (first-term L1)) (t2 (first-term L2)))
	   (and (= (order t1) (order t2))
		(equ? (coeff t1) (coeff t2))
		(equ-terms? (rest-terms L1)
			    (rest-terms L2)))))))

Exercise 2.88

Let we assume that we have generic neg procedure. Then we can extend
polynomial package to include subtraction that is analogous to addition:

 ;; arithmetic operations on poly ( wrapper operation )
 (define (arith-poly term-op opname)
   (lambda (p1 p2)
     (if (same-variable? (variable p1) (variable p2))
	 (make-poly (variable p1)
		    (term-op (term-list p1)
			     (term-list p2)))
	 (error (string-append "Polys not in the same var -- " opname) (list p1 p2)))))

(define (sub-terms L1 L2)
   (cond ((empty-termlist? L1) (neg-terms L2))
	 ((empty-termlist? L2) L1)
	 (else
	  (let ((t1 (first-term L1)) (t2 (first-term L2)))
	    (cond ((< (order t1) (order t2))
		   (adjoin-term
		    t2
		    (sub-terms L1
			       (rest-terms L2))))
		  ((> (order t1) (order t2))
		   (adjoin-term
		    t1
		    (sub-terms L2
			       (rest-terms L1))))
		  (else
		   (adjoin-term
		    (make-term (order t1)
			       (sub (coeff t1) (coeff t2)))
		    (sub-terms (rest-terms L1)
			       (rest-terms L2)))))))))

 (define sub-poly
   (arith-poly sub-terms "SUB-POLY"))

Then we should install neg operator to all arithmetic package:

(define (install-scheme-number-package)
...
  (define subtypes '(real integer))
  (for-each
   (lambda (t1)
...
     (put 'neg (list t1) (lambda (e) (- e))))
   subtypes)
  'done)

(define (install-rational-package)
...
  (put 'neg '(rational)
       (lambda (r)
	 (tag (make-rat (neg n)
			(neg d)))))
  'done)

(define (install-complex-package)
...
  (put 'neg '(complex) (lambda (c) (tag (make-from-real-imag ((neg (real-part c))
							      (neg (imag-part c)))))))
  'done)

(define (install-polynomial-package)
...
;; neg package
;; (define (neg-terms L)
;;   (map (lambda (term)
;;          (make-term (order term)
;;                     (neg (coeff term))))
;;        L))
;; We should not assume the representation detail about the lower level language.
(define (neg-terms L)
    (if (empty-termlist? L)
	L
	(let ((t (first-term L)))
	  (adjoin-term (make-term (order t) (neg (coeff t)))
		       (neg-terms (rest-terms L))))))
 (define (neg-poly p)
   (make-poly (variable p)
	      (neg-terms (term-list p))))
...
 'done)

Then the generic operator can be called by setting up

(define (neg x) (apply-generic 'neg x))

Exercise 2.89

As we build up the term list language upon term language, let we decompose term
list language and term language from polynomial package:

(define (install-term-package)
  ;; representation of term
  (define (make-term order coeff) (list order coeff))
  (define (order term) (car term))
  (define (coeff term) (cadr term))
  (define (tag t) (attach-tag 'term t))
  (put 'make 'term (lambda (order coeff) (tag (make-term order coeff))))
  (put 'order '(term) order)
  (put 'coeff '(term) coeff)
  )

(define (install-sparse-termlist)
  ;; dependency
  (install-term-package)
  (define (coeff term) (apply-generic 'coeff term))
  ;; internal procedures
  (define (adjoin-term term term-list)
    (if (=zero? (coeff term))
	term-list
	(cons term term-list)))

  (define (the-empty-termlist) '())
  (define (first-term term-list) (car term-list))
  (define (rest-terms term-list) (cdr term-list))
  (define (empty-termlist? term-list) (null? term-list))
  ;; interface to rest of the system
  (define (tag L) (attach-tag 'sparse L))
  (put 'adjoin-term '(term sparse) (lambda (t L) (tag (adjoin-term (attach-tag 'term t) L))))
  (put 'first-term '(sparse) first-term)
  (put 'rest-terms '(sparse) (lambda (L) (tag (rest-terms L))))
  (put 'empty-termlist? '(sparse) empty-termlist?)
  (put 'the-empty-termlist 'sparse (lambda () (tag (the-empty-termlist))))
  )

Analogous to sparse term list, we can implement dense term list package:

(define (install-dense-termlist)
  ;; dependency
  (install-term-package)
  (define (make-term order coeff) ((get 'make 'term) order coeff))
  (define (order term) (apply-generic 'order term))
  (define (coeff term) (apply-generic 'coeff term))
  ;; internal procedures
  (define (the-empty-termlist) '())
  (define (empty-termlist? term-list) (null? term-list))
  (define (first-term term-list) (make-term (- (length term-list) 1) (car term-list)))
  (define (rest-terms term-list)
    (define (iter list)
      (cond ((empty-termlist? list) list)
	    ((=zero? (car list)) (iter (cdr list)))
	    (else list)))
    (iter (cdr term-list)))
  (define (adjoin-term term term-list)
    (cond ((=zero? (coeff term)) term-list)
	  ((= (order term) (length term-list)) (cons (coeff term) term-list))
	  (else (adjoin-term term (cons 0 term-list))))) ;we need consider general zero instead of 0
  ;; interface to rest of the system
  (define (tag L) (attach-tag 'dense L))
  (put 'adjoin-term '(term dense) (lambda (t L) (tag (adjoin-term (attach-tag 'term t) L))))
  (put 'first-term '(dense) first-term)
  (put 'rest-terms '(dense) (lambda (L) (tag (rest-terms L))))
  (put 'empty-termlist? '(dense) empty-termlist?)
  (put 'the-empty-termlist 'dense (lambda () (tag (the-empty-termlist))))
  )

By this decomposing we can test each package seperately.

Exercise 2.90

Here is the complete code that satisfy all the requirement:

(define (install-polynomial-package)
  ;; dependency
  (install-term-package)
  (install-dense-termlist)
  (install-sparse-termlist)
  ;; import from dependent package
  (define (empty-termlist? L) (apply-generic 'empty-termlist? L))
  (define (adjoin-term t L) (apply-generic 'adjoin-term t L))
  (define (first-term L) (apply-generic 'first-term L))
  (define (rest-terms L) (apply-generic 'rest-terms L))
  (define (the-empty-termlist) (sparse-empty-termlist))
  (define (sparse-empty-termlist) ((get 'the-empty-termlist 'sparse)))
  (define (dense-empty-termlist) ((get 'the-empty-termlist 'dense)))
  (define (make-term order coeff) ((get 'make 'term) order coeff))
  (define (order term) (apply-generic 'order term))
  (define (coeff term) (apply-generic 'coeff term))

  ;; internal procedures
  ;; representation of poly
  (define (make-poly variable term-list)
    (cons variable
	  (->appropriate-rep term-list)))
  (define (variable p)
    (car p))
  (define (term-list p)
    (cdr p))

  ;; from section 2.3.2
  (define (variable? x) (symbol? x))
  (define (same-variable? v1 v2)
    (and (symbol? v1) (symbol? v2) (eq? v1 v2)))

  ;; arithmetic operations on poly ( wrapper operation )
  (define (arith-poly term-op opname)
    (lambda (p1 p2)
      (if (same-variable? (variable p1) (variable p2))
	  (make-poly (variable p1)
		     (term-op (term-list p1)
			      (term-list p2)))
	  (error (string-append "Polys not in the same var -- " opname) (list p1 p2)))))

  ;; arithmetic operations on termlist
  (define (add-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
	  ((empty-termlist? L2) L1)
	  (else
	   (let ((t1 (first-term L1)) (t2 (first-term L2)))
	     (cond ((< (order t1) (order t2))
		    (adjoin-term
		     t2
		     (add-terms L1
				(rest-terms L2))))
		   ((> (order t1) (order t2))
		    (adjoin-term
		     t1
		     (add-terms L2
				(rest-terms L1))))
		   (else
		    (adjoin-term
		     (make-term (order t1)
				(add (coeff t1) (coeff t2)))
		     (add-terms (rest-terms L1)
				(rest-terms L2)))))))))

  (define (sub-terms L1 L2)
    (cond ((empty-termlist? L1) (neg-terms L2))
	  ((empty-termlist? L2) L1)
	  (else
	   (let ((t1 (first-term L1)) (t2 (first-term L2)))
	     (cond ((< (order t1) (order t2))
		    (adjoin-term
		     t2
		     (sub-terms L1
				(rest-terms L2))))
		   ((> (order t1) (order t2))
		    (adjoin-term
		     t1
		     (sub-terms L2
				(rest-terms L1))))
		   (else
		    (adjoin-term
		     (make-term (order t1)
				(sub (coeff t1) (coeff t2)))
		     (sub-terms (rest-terms L1)
				(rest-terms L2)))))))))

  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
	(the-empty-termlist)
	(add-terms (mul-term-by-all-terms (first-term L1) L2)
		   (mul-terms (rest-terms L1) L2))))


  (define add-poly
    (arith-poly add-terms "ADD-POLY"))
  (define mul-poly
    (arith-poly mul-terms "MUL-POLY"))
  (define sub-poly
    (arith-poly sub-terms "SUB-POLY"))
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L)
	(the-empty-termlist)
	(let ((t2 (first-term L)))
	  (adjoin-term (make-term (+ (order t1) (order t2))
				  (mul (coeff t1) (coeff t2)))
		       (mul-term-by-all-terms t1 (rest-terms L))))))

  ;; equ package
  (define (equ-poly? p1 p2)
    (and (same-variable? (variable p1) (variable p2))
	 (equ-terms? (term-list p1) (term-list p2))))
  (define (equ-terms? L1 L2)
    (cond ((empty-termlist? L1) (empty-termlist? L2))
	  ((empty-termlist? L2) false)
	  (else
	   (let ((t1 (first-term L1)) (t2 (first-term L2)))
	     (and (= (order t1) (order t2))
		  (equ? (coeff t1) (coeff t2))
		  (equ-terms? (rest-terms L1)
			      (rest-terms L2)))))))
  ;; neg package
  (define (neg-terms L)
    (map (lambda (term)
	   (make-term (order term)
		      (neg (coeff term))))
	 L))

  (define (neg-poly p)
    (make-poly (variable p)
	       (neg-terms (term-list p))))

  ;; number of terms
  (define (number-of-terms L)
    (if (empty-termlist? L)
	0
	(1+ (number-of-terms (rest-terms L)))))

  (define (->appropriate-rep L)
    (let ((ratio 0.5)) ;determine the ratio at which change the representation of term list
      (cond ((empty-termlist? L) L)
	    ((< (/ (number-of-terms L) (order (first-term L)))
		ratio)
	     (->sparse L))
	    (else (->dense L)))))

  (define (->sparse L)
    (define (recur L)
      (if (empty-termlist? L)
	  (sparse-empty-termlist)
	  (adjoin-term (first-term L)
		       (recur (rest-terms L)))))
    (if (eq? 'sparse (type-tag L))
	L
	(recur L)))

  (define (->dense L)
    (define (recur L)
      (if (empty-termlist? L)
	  (dense-empty-termlist)
	  (adjoin-term (first-term L)
		       (recur (rest-terms L)))))
    (if (eq? 'dense (type-tag L))
	L
	(recur L)))

  ;; interface to rest of the system
  (define (tag p) (attach-tag 'polynomial p))
  (put 'add '(polynomial polynomial)
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial polynomial)
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put 'sub '(polynomial polynomial)
       (lambda (p1 p2) (tag (sub-poly p1 p2))))
  (put 'make 'polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  (put 'equ? '(polynomial polynomial) equ-poly?)
  (put '=zero? '(polynomial) (lambda (p) (empty-termlist? (term-list p))))
  (put 'neg '(polynomial) (lambda (p) (tag (neg-poly p))))
  'done)

Also we should check it works as expected:

(sub (make-polynomial 'x '(dense 1 0 0 0 0 0 0))
     (make-polynomial 'x '(sparse (term 5 1) (term 4 2) (term 1 1))))

(add (make-polynomial 'x '(dense 1 0 0 0 0 0 0))
     (make-polynomial 'x '(sparse (term 5 1) (term 4 2) (term 1 1))))

(mul (make-polynomial 'x '(dense 1 0 0 0 0 0 0))
     (make-polynomial 'x '(sparse (term 5 1) (term 4 2) (term 1 1))))

As noted in the exercise's statement, unlike the complex number package, this
require global change rather than local chang, i.e. we should change
polynomial package to maintain the representation of term list efficiently. We
maintain the appropriate (efficient) representation every time we make a new
polynomial.

Note

As we noticed that the term list has lots of analogy with list
structure in scheme, we should find that similarity between polynomial with
strictly typed list structure like in ML or Scala, i.e. we can think variable of
polynomial is analogous to type of the list element. Then we can also guess the
work of complier in the strictly typed language as they perform type inference
using the operator table like in this section.

We can find this analogy in foregoing discussion.

Exercise 2.91

It is easy: If we follow the specified rules in the text, we can complete the
code accordingly:

(define (div-terms L1 L2)
  (if (empty-termlist? L1)
      (list (the-empty-termlist) (the-empty-termlist))
      (let ((t1 (first-term L1))
	    (t2 (first-term L2)))
	(if (> (order t2) (order t1))
	    (list (the-empty-termlist) L1)
	    (let ((new-c (div (coeff t1) (coeff t2)))
		  (new-o (- (order t1) (order t2))))
	      (let ((rest-of-result
		     (div-terms (sub-terms L1
					   (mul-term-by-all-terms
					    (make-term new-o new-c)
					    L2))
				L2)))
		(cons (adjoin-term (make-term new-o new-c)
				   (car rest-of-result))
		      (cdr rest-of-result))))))))

Let's test:

(div (make-polynomial 'x '(dense 1 0 0 0 0 0 0))
     (make-polynomial 'x '(sparse (term 5 1) (term 4 2) (term 1 1))))
;; (polynomial x dense 1 -2)

Exercise 2.92

The Problem

Our system works well even if we add multivariate polynomial, i.e. univariate
polynomial whose coefficients are also univariate polynomial, by the recursive
type dispatch operation. However that works well only we set up appropriately:
While if we add (x^{2}\left( y + 1 \right) + x \left( y^{2} + y \right) + y^{2} + y) with (x \left( y^{3} + y \right))
using our system, as the nested polynomial agree with variable in each level, it
results in (x^{2}\left( y + 1 \right) + x \left( y^{3} +y^{2} + 2y \right) + y^{2} + y);
whereas (x^{2}\left( y + 1 \right) + x \left( y^{2} + y \right) + y^{2} + y) with (y^{3} \left( x \right) + y \left( x \right))
doesn't work at all even if the first and second formula are same in the
algebraic context (by commutative law of multiplication).
To deal with this problem, i.e. to produce "right" answer consistently even if
we hand over the second formula, we consider to impose "canonical" order in
polynomial's variable; e.g. (x) has higher priority than (y) so that
(x \left( y^{3} + y \right)) is canonical form but (y^{3} \left( x \right) + y \left( x \right)).

Designing

Then how to deal with the addition and multiplication operation with this
impose? So far, we set up the abstraction barrier between each level of nested
formula so that let our generic operator deal with each type of formula
appropriately. Doing that, we actually set up the recursive process on data
type such as equ? package and so on.

As we learned in chapter 1 and practicing that skill with exercises– the
powerful "wishful thinking"– that recursive process are really good at handling
complex process by capturing local rules by which the process evolve. However,
this time we are about to break that barrier: We should access all the level of
nested polynomial to expand and rearrange.

To design our arithmetic operations in this scheme, we should grasp the gist of
it by playing with multivariate polynomial arithmetic by hand calculation. I've
done this with my digital paper. You should do this process with your own note
or something. After that, we could conclude that if we assume we can expand all
the terms and rearrange that to canonical form, then

addition is obtained by expanding and rearranging addend and augend all together,
multiplication can be decomposed to multiply each term of multiplicand with
multiplier and then expanding and rearranging all together as we did addition.

Also note that multiply each term of one argument to term list of other argument
is analogous to previous mul-terms procedure; but here we should notice that
this process is also a part of expansion of terms, as consequence if we can
implement the rearranging process the addition and multiplication of
multivariate polynomial is just by product of it.

Expansion

First we need to specify what we want from expansion:

The output should be ordered list or not, if it should be arranged how?
Should the output collapse the same form of term appropriately– add terms?
How should it deal with constant term – term with zero order?
Should we make abstract data type for it? That is, should we make constructor
and selectors for its result?

After playing with the expansion and reconstruction to canonical form, I found
that

it should ordered by priority of variable in decreasing order,
yes, it should collapse appropriately,
we should consider the zeroth term as place holder – just strip variable part,
it is plausible to have abstract data type but type tag.

would make ourself easier to implement that.

Data Abstraction

Here is the specification of the abstract data type:

(collapse-term-to-each term expansion-list): The motivation of this
procedure is following: (x \left( x y + 2 \right) = x^{2}y + 2x), i.e.
collapse-term-to-each '(x 1) '(((x 1) (y 1) (num 1)) ((num 2))) should
return (((x 2) (y 1) (num 1)) ((x 1) (num 2)))
(add-term-list-to-expansion termlist expansion-list): This procedure take
term list that represent each term in the expansion – (x^{2}y) in
(x^{2}y + 2x) to adjoin in the expansion list, in which each term list
ordered in decreasing priority.

With those procedure, we can implement recursive process of expansion:

(define (expand nested-poly)
  (cond (<base>)
	(else
	 (let ((x (variable nested-poly))
	       (L (term-list nested-poly)))
	   (let ((t (first-term L))
		 (tl (rest-terms L)))
	     (append-expansion
	      (collapse-term-to-each
	       (make-var-term x (order t))
	       (expand (coeff t)))
	      (expand (make-polynomial x tl))))))))

(define (append-expansion e1 e2)
  (if (empty-expansion? e1)
      e2
      (add-term-list-to-expansion (first-term-list e1)
				  (append-expansion (rest-expansion e1) e2))))

Or we could decompose expand procedure more granularly:

(define (expand nested-poly)
  (cond (<base>)
	(else
	 (expand-at-level (variable nested-poly) (term-list nested-poly)))))

(define (expand-at-level x L)
  (cond (<base>)
	(else
	 (let ((t (first-term L)) (tl (rest-terms L)))
	   (append-expansion
	    (collapse-term-to-each
	     (make-var-term x (order t))
	     (expand (coeff t)))
	    (expand-at-level x tl))))))

Now we have to consider the base case. Note that in the recursive process, we
pass coefficient of term to expand; so the only base case of it is not
polynomial case– number coefficient:

(define (expand nested-poly)
  (cond ((not (polynomial? nested-poly))
	 (add-term-list-to-expansion
	  (make-term-list-with-num nested-poly)
	  (the-empty-expansion)))
	(else
	 (expand-at-level (variable nested-poly) (term-list nested-poly)))))

For the expand-at-level, the base case is empty-termlist:

(define (expand-at-level x L)
  (cond ((empty-termlist? L) (the-empty-expansion))
	(else
	 (let ((t (first-term L)) (tl (rest-terms L)))
	   (append-expansion
	    (collapse-term-to-each (make-var-term x (order t))
				   (expand (coeff t)))
	    (expand-at-level x tl))))))

Are we implement all the specification that we started with? Aren't we missed
the constant clause? Well, no since we can deal with that in
collapse-term-to-each procedure.

We have introduced bunch of procedures that we didn't specified prior; this is
due to the power of data abstraction: We can add any procedure that we want and
defer the implementation later.

Implementation

Now we turn into implementation of representation that we abstracted out.
Let we code the straightforward parts first:

(define (collapse-term-to-each term expansion-list)
  (if (= 0 (order term))                ;constant clause
      expansion-list
      (map (lambda (term-list) (collapse-term term term-list)) expansion-list)))



;; predicate for polynomial
(define (polynomial? p) (eq? 'polynomial (type-tag p)))


;; representation for expansion
(define (the-empty-expansion) '())
;; predicate
(define (empty-expansion? e) (null? e))
;; selectors
(define (first-term-list e) (car e))
(define (rest-expansion e) (cdr e))
;; constructor
(define (add-term-list-to-expansion term-list expansion-list)
  (if (empty-expansion? expansion-list)
      (list term-list)
      (let ((L (first-term-list expansion-list)))
	(cond ((term-list<? L term-list) (cons term-list expansion-list))
	      ((term-list<? term-list L)
	       (cons L (add-term-list-to-expansion
			term-list
			(rest-expansion expansion-list))))
	      (else (add-term-list-to-expansion
		     (add-term-list term-list L)
		     (rest-expansion expansion-list)))))))

Then we should consider the term list representation:

Should we treat numeral term same as variable term?
That is, we should coerce numeral to polynomial term?
Or should we deal numeral term explicitly other than variable term?

This question leads different representation of term list. We could use multiple
representation as we did complex number and the earlier term list
representation. That means we can develop each representation independently. Let
we first consider the latter representation:

(define (add-term-list L1 L2)
  (make-term-list (var-terms L1) (add (num-term L1) (num-term L2))))

;; term-list representation
(define (the-empty-list-term) '())
;; predicate
(define (empty-var-term-list? L) (null? L))
(define (term-list<? L1 L2)
  (var-term-list<? (var-terms L1) (var-terms L2)))

(define (var-term-list<? L1 L2)
  (cond ((empty-var-term-list? L1) (not (empty-var-term-list? L2)))
	((empty-var-term-list? L2) false)
	(else
	 (let ((t1 (head-term L1)) (t2 (head-term L2)))
	   (cond ((variable<? (var t1) (var t2))
		  true)
		 ((variable<? (var t2) (var t1))
		  false)
		 ((< (order t1) (order t2)) true)
		 ((> (order t1) (order t2)) false)
		 (else
		  (var-term-list<? (tail-terms L1) (tail-terms L2))))))))
;; constructor
(define (make-term-list-with-num num-term) (make-term-list '() num-term))
(define (make-term-list var-terms num-term) (cons var-terms num-term))
(define (collapse-term var-term term-list)
  (make-term-list
   (collapse-var-term var-term (var-terms term-list))
   (num-term term-list)))
(define (collapse-var-term term term-list)
  (cond ((empty-var-term-list? term-list) (cons term (the-empty-list-term)))
	(else
	 (let ((t (head-term term-list)))
	   (cond ((variable<? (var t) (var term))
		  (cons term term-list))
		 ((variable<? (var term) (var t))
		  (cons t
			(collapse-var-term term
				       (tail-terms term-list))))
		 (else
		  (cons (make-var-term (var term)
				       (+ (order term)
					  (order t)))
			(tail-terms term-list))))))))

The rest is straightforward:

;; term representation
(define (make-var-term var order) (list var order))
;; predicate
(define (variable<? v1 v2)
  (symbol>? v1 v2))

;; selectors
(define (var term) (car term))
(define (order term) (cadr term))

Let's test it:

(expand '(polynomial x sparse
		     (term 3 (polynomial y dense (polynomial x dense 5 0 0) 0))
		     (term 1 (polynomial z dense 2 0))))
;Value: ((((x 5) (y 1)) . 5) (((x 1) (z 1)) . 2))

Yeah! We did half of our task.

Rearrange

We should reverse the expansion list to polynomial in canonical order. We could
accomplish the task that is almost analogous to our first half. As we already
constructed abstract data type in expansion, here we can focus on put together
existing code to make sense. Here is the final code:

(define (rearrange expansion-list)
  (cond ((number-expansion-list? expansion-list)
	 (get-number expansion-list))   ; => num
	(else
	 (let ((x (var (highest-priority-term expansion-list))))
	   (make-polynomial x (gather-termlist x expansion-list)))))) ; => polynomial

(define (highest-priority-term es)
  (head-term (var-terms (first-term-list es))))

(define (number-expansion-list? expansion-list)
  (and (empty-var-term-list?
	(var-terms (first-term-list expansion-list)))
       (empty-expansion? (rest-expansion expansion-list))))

(define (get-number e) (num-term (first-term-list e)))

;; dependency
(define (adjoin-term t L) (apply-generic 'adjoin-term t L))
(define (the-empty-termlist) (sparse-empty-termlist))
(define (sparse-empty-termlist) ((get 'the-empty-termlist 'sparse)))
(define (make-term order coeff) ((get 'make 'term) order coeff))

(define (gather-termlist v es)                       ;=> termlist
  (cond ((empty-expansion? es) (the-empty-termlist)) ;base case 1
	((number-expansion-list? es) (adjoin-term (make-term 0 (rearrange es)) ;base case 2
						  (the-empty-termlist)))
	(else
	 (let ((t (highest-priority-term es)))
	   (if (not (variable=? v (var t)))
	       (adjoin-term (make-term 0 (rearrange es)) ;base case 3
			    (the-empty-termlist))
	       (let ((unarranged-result (gather t es)))
		 (let ((gathered (car unarranged-result))
		       (rest (cadr unarranged-result)))
		   (adjoin-term (make-term (var-order t)
					   (rearrange gathered))
				(gather-termlist v rest)))))))))

(define (gather t es)
  (cond ((number-expansion-list? es)
	 (list (the-empty-expansion) es))
	((empty-expansion? es)
	 (list (the-empty-expansion) (the-empty-expansion)))
	(else
	 (let ((t1 (highest-priority-term es)))
	   (if (or (not (term=? t t1)))
	       (list (the-empty-expansion) es)
	       (let ((result (gather t (rest-expansion es))))
		 (list (adjoin-term-list-to-expansion
			(term-list-except-first-var
			 (first-term-list es))
			(car result))
		       (cadr result))))))))

(define (term-list-except-first-var ts)
  (make-term-list (tail-terms (var-terms ts))
		  (num-term ts)))

(define (term=? t1 t2)
  (and (variable=? (var t1) (var t2))
       (= (order t1) (order t2))))

Here we used the analogy with Exercise 2.58 when we dealt with AST. Also we
exploit the type analysis to design these procedure.

Test!

(define test
  (expand '(polynomial x sparse
		       (term 3 (polynomial y dense
					   (polynomial y dense 5 0 0) 0))
		       (term 1 (polynomial y dense
					   (polynomial x dense 3 0 0) 0 0 0)))))
;Value: ((((x 3) (y 3)) . 8))
(rearrange test)
;Value: (polynomial x dense (polynomial y dense 8 0 0 0) 0 0 0)

(define test
  (expand '(polynomial y sparse
		       (term 3 (polynomial y dense (polynomial y dense 5 0 0) 0))
		       (term 1 (polynomial y dense (polynomial x dense 3 0 0) 0 0 0)))))
(rearrange test)
;Value: (polynomial x dense (polynomial y sparse (term 4 3)) 0 (polynomial y sparse (term 6 5)))

Yes!

Addition

With these armamentarium, we can easily implement addition:

(define (mul-poly-add p1 p2)
  (rearrange (append-expansion (expand p1)
			       (expand p2))))

Multiplication

We need some auxiliary procedure that is analogous to union procedure in
previous section with collapse-term:

(define (collapse-term-list L1 L2)      ;provided that L1 L2 is not empty
  (make-term-list
   (collapse-var-term-list (var-terms L1)
			   (var-terms L2))
   (mul (num-term L1)
	(num-term L2))))

(define (collapse-var-term-list vs1 vs2)
  (cond ((empty-var-term-list? vs1) vs2)
	((empty-var-term-list? vs2) vs1)
	(else
	 (let ((t1 (head-term vs1))
	       (t2 (head-term vs2)))
	   (cond ((variable<? (var t1) (var t2))
		  (adjoin-var-term
		   t2
		   (collapse-var-term-list vs1 (tail-terms vs2))))
		 ((variable<? (var t2) (var t1))
		  (adjoin-var-term
		   t1
		   (collapse-var-term-list (tail-terms vs1) vs2)))
		 ((variable=? (var t1) (var t2))
		  (adjoin-var-term (make-var-term (var t1)
						  (+ (order t1)
						     (order t2)))
				   (collapse-var-term-list
				    (tail-terms vs1)
				    (tail-terms vs2)))))))))

This procedure collapse two term list (multiply two term list); using the
algorithm of mul-term-by-all-terms in our previous polynomial package, we can
accomplish the multiplication:

(define (mul-poly-mul p1 p2)
  (rearrange
   (mul-expansion (expand p1) (expand p2))))

(define (mul-expansion e1 e2)
  (if (empty-expansion? e1)
      (the-empty-expansion)
      (append-expansion (mul-term-list-by-all-term-lists
			 (first-term-list e1) e2)
			(mul-expansion (rest-expansion e1) e2))))

(define (mul-term-list-by-all-term-lists L1 e)
  (if (empty-expansion? e)
      (the-empty-expansion)
      (let ((L2 (first-term-list e)))
	(adjoin-term-list-to-expansion
	 (collapse-term-list L1 L2)
	 (mul-term-list-by-all-term-lists L1 (rest-expansion e))))))

Which conclude our example.

Deploy

All we have to do is wrap around what we built as pacakge that extends
polynomial pacakge:

(define (install-multivariate-polynomial-package)
  *** What we built
  ;; interface to rest of system
  (define (tag p) (attach-tag 'polynomial p)) ;for reattach the tag for working with this package
  (put 'add '(polynomial polynomial) (lambda (p1 p2) (mul-poly-add (tag p1) (tag p2))))
  (put 'mul '(polynomial polynomial) (lambda (p1 p2) (mul-poly-mul (tag p1) (tag p2))))
  (put 'sub '(polynomial polynomial) (lambda (p1 p2) (mul-poly-add (tag p1) (neg (tag p2))))) ;exploit generic operator, neg
  ;; test fragment
  ;; (define test '(polynomial x sparse (term 3 (polynomial y dense (polynomial y dense 5 0 0) 0)) (term 1 (polynomial y dense (polynomial x dense 3 0 0) 0 0 0))))
  ;; (define test1 '(polynomial y sparse (term 3 (polynomial y dense (polynomial y dense 5 0 0) 0)) (term 1 (polynomial y dense (polynomial x dense 3 0 0) 0 0 0))))
  ;; (add test test1)
  ;; (sub test test1)
  ;; (mul test test1)
 )

Lecture 4B: Generic Operators

In this section, 2.5, we built our system primarily relying on data-directed
programming; using this scheme, we were able to inherit automatically the
ability to compute multivariate polynomial (in limited sense, as we noted
before) by just implementing univariate polynomial arithmetic system and
integrate that in our generic arithmetic system.

In this programming style, we get rid of the "manager" and automated with
generic procedure called apply-generic. By doing that, we allowed to develop
our own package without consulting with other package developer; we only needed
to add appropriate procedure in operator table so that apply-generic look for
and dispatch on type appropriately.

So far, we are quite happy with our craft; however we start to realize there are
some unfortunate things even in this genuine strategy: As noted in the lecture,
the individual package procedures can freeze the higher level procedure by
adding some procedure that is constrained in some fashion. This "unfortunate"
due to the highly decentralized structure of our programming scheme; for
instance we couldn't decide where specific coercion procedure should be
included: We end up with making up other kind operator table that contains
coercion procedure and we had to modify apply-generic accordingly. Even with
that, our coercion scheme is limited in that we had to supply explicitly how our
arithmetic types related each other– tower. It's a very poorly structured
hierarchical system. An obvious example of the freezing generic operation by
user defined structure is exercise 2.94; previously we defined "simplifying
procedure"– drop – and integrated in our apply-generic. But as we (user)
extends the rational arithmetic system to accommodate all the object that
satisfy the rational arithmetic axioms (see below), the drop procedure, which
is specific to number system, start to not work at all. That root from our
crude handling for hierarchical structure with too immense flexibility that we
can not tether.

Further more, in following exercise, we are about to convert rational number to
generic rational object, which encompass all the object that has structure like
rational number– object that have numerator and denominator with satisfying
rational arithmetic axioms. That allows complex numbered rational object and
rational polynomials and so on, "automatically"; however obvious there is no
"GCD" operators for these. One way to deal with this problem is to give up to
reduce the numerator and denominator to its lowest term, which leads to our
rational number system also to be not the conventional rational number, which we
learned in elementary school.

On the other hand, this generic approach also leads some insight about the
abstract algebra: As polynomial has its own "GCD" like operation as its division
has a lot of analogy with integer division, we can abstract out the object that
we have considered in concrete manner in the more generic context, which can be
used in another specific field that have not considered previously. The other
method for this problem, as I hinted already, use the generic properties of
rational object, that is, to formulate the axioms objects should satisfy to have
rational type; also we have to impose that condition to our rational arithmetic
package to ensure the made rational object can be supplied to any other
arithmetic operations as expected.

Finally, the alternative approach have been adopted in many modern programming
language: OOP. In that approach we can solve the hierarchical structure
elegantly using super type and sub type relation. And more, the strictly typed
language exploit this paradigm to maximize the flexibility, which constrained by
the compile time type checking. Also this scheme capture the ADT concept as
special expression called class using that structure, we can achieve the guts
of ADT more elegantly. Now days, it seems like people found this scheme as most
practical one⁷.

Exercise 2.93

We can do what text indicated straightforwardly. Then we can test the given
code:

(define p1 (make-polynomial 'x '(sparse (term 2 1) (term 0 1))))
(define p2 (make-polynomial 'x '(sparse (term 3 1) (term 0 1))))
(define rf (make-rational p2 p1))
;Value: (rational (polynomial x dense 1 0 0 1) polynomial x dense 1 0 1)
(add rf rf)
;Value: (rational (polynomial x dense 2 0 2 2 0 2) polynomial x dense 1 0 2 0 1)

Exercise 2.94

We can support "GCD" procedure in univariate polynomial version by adding
following code to polynomial package:
```
(define (gcd-terms a b)
  (if (empty-termlist? b)
      a
      (gcd-terms b (remainder-terms a b))))

(define (remainder-terms a b)
  (cadr (div-terms a b)))

(define gcd-poly
  (arith-poly gcd-terms "GCD-POLY"))

(put 'gcd '(polynomial polynomial)
     (lambda (p1 p2) (tag (gcd-poly p1 p2))))
```
And we also implement GCD for integer number in scheme number package:
```
(define (gcd a b)
  (if (= b 0)
      a
      (gcd b (remainder a b))))

(put 'gcd '(integer integer) gcd)
```
Then rest is the add GCD procedure to our disposal:
```
(define greatest-common-divisor (make-generic-op 'gcd))
```
Make our rational arithmetic package to exploit this generic operator:
```
(define (make-rat n d)
  (let ((g (greatest-common-divisor n d)))
    (cons (div n g) (div d g))))
```
Then let we test this with given example:
```
(define p1 (make-polynomial 'x '(sparse (term 4 1) (term 3 -1) (term 2 -2) (term 1 2))))
(define p2 (make-polynomial 'x '(sparse (term 3 1) (term 1 -1))))
(greatest-common-divisor p1 p2)
```
That end up into infinite loop, which was due to the integer division in the
generic operator div: due to the ill-defined div-terms; however if we stick
our integer division operation in our generic division operation, we will end up
with above situation when we involves non-integer division in div-terms. So
for now let we prevent that circumstance by following discussion.
```
*** In scheme number package
(put 'div '(integer integer) quotient)
```
This would leads to zero coefficient in div-terms if we try to non-integer
division; in turn, mul-term-by-all-terms with that term is zero. As
consequence it end up looping with the same L1 and L2 in the div-terms.

This kind of error is hard to extract even with this relatively small project.
I should think this situation as chance to try bisection debugging method as
scheme's debugger can not work in this situation since this program does not
halt. This time, I've used display procedure to debug somewhat, but
systematically. I've tried to reason about the code rather than to approach the
bug with systematic using bisection search. If we encounter with next chance I
should try out the smarter debugging method rather than frustrating with the
behavior of program.

After fixing the bug, we can get result:
```
(greatest-common-divisor p1 p2)
;Value: (polynomial x dense -10 0)
```
Is it correct? Let we calculate the greatest common divisor of p1 and p2 by
hand:
- p1 = (x^{4} - x^{3} - 2x^{2} + 2x) = $\left( x² - 2 \right) \left( x² -
x \right) = \left( x² -2 \right) x \left( x - 1 \right)$
- p2 = (x^{3} - x) = (x \left( x + 1 \right) \left( x - 1 \right))
So, GCD of p1 and p2 should be (x \left( x - 1 \right)) not (-10 x) like our
program. Yeah! Another bug! As soon as I mentioned, it comes out! Let we try out
the bisection search method to debug.
1. Let we prepare test case, which we know what is the correct expected value at
  each step of computation. To do this in our GCD case, we use above test case
  for this; we should calculate each step that greatest-common-divisor
  process by hand.
2. Then add the probe procedure, display in gcd-terms:
```
(define (gcd-terms a b)
  (display a)
  (if (empty-termlist? b)
      a
      (gcd-terms b (remainder-terms a b))))
```
  It produces (dense 1 -1 -2 2 0)(dense 1 0 -1 0)(dense 1 3 0)(sparse (term 1 -10)).
3. Compare with the expected value. By hand calculation, we expect to have
  (dense -1 3 0) for the remainder of p1 and p2; however we got (dense 1 3 0). This means our remainder-terms malfunctions. As this function just
  select the relevant part from div-terms, in turn, it means the bug in div-terms.
4. As the remainder of div-terms produced by successive sub-terms, we can
  deduce that the divergence of the result from what we expected is due to
  sub-terms part. To inspect the value produced by successive subtraction we
  add probe code to div-terms:
```
(define (div-terms L1 L2)
  (if (empty-termlist? L1)
      (list (the-empty-termlist) (the-empty-termlist))
      (let ((t1 (first-term L1))
	    (t2 (first-term L2)))
	(if (> (order t2) (order t1))
	    (list (the-empty-termlist) L1)
	    (let ((new-c (div (coeff t1) (coeff t2)))
		  (new-o (- (order t1) (order t2))))
	      (let ((rest-of-result
		     (div-terms (sub-terms L1
					   (mul-term-by-all-terms
					    (make-term new-o new-c)
					    L2))
				L2)))
		(display L1)
		(list (adjoin-term (make-term new-o new-c)
				   (car rest-of-result))
		      (cadr rest-of-result))))))))
```
  Then remove the previous probe code in step 2. Let's run this code with our
  test code; it produces (dense -1 1 -2 0)(dense 1 -1 -2 2 0)(dense 3 -1 0)(dense 1 0 -1 0)(dense 3 0)(dense 1 3 0). It get to be obvious that
  the subtraction is the reason for this erroneous behavior.
5. We narrowed down the bug to sub-terms. We could run the bisection search
  until we end up single unit that compute just one step; but here we realized
  that the first clause in recursive process of sub-terms is ill-defined. We
  should code
```
(define (sub-terms L1 L2)
  (cond ((empty-termlist? L1) (neg-terms L2))
	((empty-termlist? L2) L1)
	(else
	 (let ((t1 (first-term L1)) (t2 (first-term L2)))
	   (cond ((< (order t1) (order t2))
		  (adjoin-term
		   (make-term (order t2)
			      (neg (coeff t2)))
		   (sub-terms L1
			      (rest-terms L2))))
		 ((> (order t1) (order t2))
		  (adjoin-term
		   t1
		   (sub-terms (rest-terms L1)
			      L2)))
		 (else
		  (adjoin-term
		   (make-term (order t1)
			      (sub (coeff t1) (coeff t2)))
		   (sub-terms (rest-terms L1)
			      (rest-terms L2)))))))))
```
  not
```
(define (sub-terms L1 L2)
  (cond ((empty-termlist? L1) (neg-terms L2))
	((empty-termlist? L2) L1)
	(else
	 (let ((t1 (first-term L1)) (t2 (first-term L2)))
	   (cond ((< (order t1) (order t2))
		  (adjoin-term
		   t2
		   (sub-terms L1
			      (rest-terms L2))))
		 ((> (order t1) (order t2))
		  (adjoin-term
		   t1
		   (sub-terms L2
			      (rest-terms L1))))
		 (else
		  (adjoin-term
		   (make-term (order t1)
			      (sub (coeff t1) (coeff t2)))
		   (sub-terms (rest-terms L1)
			      (rest-terms L2)))))))))
```
  I've not fully considered the difference between sub-terms and add-terms
  when I defining sub-terms using analogy with add-terms.
  
  After this fixing, our test code barfage
```
(greatest-common-divisor p1 p2)
;Value: (polynomial x dense -1 1 0)
```
  as we expected.
Exercise 2.95

We can easily encode given formula to our polynomial expression:
```
(define p1 '(polynomial x dense 1 -2 1))
(define p2 '(polynomial x dense 11 0 7))
(define p3 '(polynomial x dense 13 5))
(define q1 (mul p1 p2))
(define q2 (mul p1 p3))
```
And then, to inspect what's going to happen in the gcd-terms we insert the
probe code as we did before:
```
(define (gcd-terms a b)
  (newline)
  (display a)
  (if (empty-termlist? b)
      a
      (gcd-terms b (remainder-terms a b))))
```
Then let's run our code: (greatest-common-divisor q1 q2). And it produce
following:
```
(dense 11 -22 18 -14 7)
(dense 13 -21 3 5)
(sparse (term 2 8.627218934911243) (term 1 -17.254437869822485) (term 0 8.627218934911243))
;Value: (polynomial x dense 8.627218934911243 -17.254437869822485 8.627218934911243)
```
Intuitively we expected that the output would be same as p1 but not; it is due
to the non-integer operation– more precisely real division – in GCD
computation. Fortunately the output agree with our intuition in that given
output is differ in constant factor from our expectation; it was mainly due to
our previous amender to prevent to fall in infinite loop in div-terms.

Exercise 2.96

First, we can prove the fact involving the integerizing factor
c^1+O₁-O₂ using induction on O₁ - O₂. As we proved the fact that
if we multiply dividend by integerizing factor then the resulting polynomial can
be divided by divisor using the div-terms without introducing any fractions,
we can now use that fact to fix our previous malfunction.

a.

We can implement given task with the existing code⁸:

(define (pseudoremainder-terms L1 L2)
    (if (empty-termlist? L1)
	(the-empty-termlist)
	(let ((t1 (first-term L1)) (t2 (first-term L2)))
	  (if (> (order t2) (order t1))
	      L1                        ;do nothing
	      (remainder-terms
	       (mul-term-by-all-terms (make-term 0
						 (expt (coeff t2)
						       (+ 1
							  (- (order t1)
							     (order t2)))))
				      L1)
	       L2)))))

Then we should modify gcd-terms as follow

(define (gcd-terms a b)
  (if (empty-termlist? b)
      a
      (gcd-terms b (pseudoremainder-terms a b))))

Let's test:

(greatest-common-divisor q1 q2)
;Value: (polynomial x dense 1458 -2916 1458)

We progressed: It returns polynomial with integer coefficient

b.

First, let we extract common factor of given term list:

(define (map-terms f L)               ;term-list => list
  (if (empty-termlist? L)
      '()
      (cons (f (first-term L))
	    (map-terms f (rest-terms L)))))

(define (common-factor L)
  (if (empty-termlist? L)
      (error "invalid input term list -- COMMON-FACTOR" L)
      (let ((coeffs (map-terms coeff L)))
	(fold-left (lambda (x y) (greatest-common-divisor x y))
		   (car coeffs)
		   (cdr coeffs)))))

Using this, we can reduce term list to its lowest term:

(define (map-terms-using nil cons f L)
  (define (construct L)
    (if (empty-termlist? L)
	nil
	(cons (f (first-term L))
	      (construct (rest-terms L)))))
  (construct L))

(define (map-terms-to-list f L)               ;term-list => list
  (map-terms-using '() cons f L))

(define (common-factor L)
  (if (empty-termlist? L)
      (error "invalid input term list -- COMMON-FACTOR" L)
      (let ((coeffs (map-terms-to-list coeff L)))
	(fold-left (lambda (x y) (greatest-common-divisor x y))
		   (car coeffs)
		   (cdr coeffs)))))

(define (reduce-terms L)
  (let ((c (common-factor L)))
    (map-terms-using (the-empty-termlist) adjoin-term
		     (lambda (term)
		       (make-term (order term)
				  (div (coeff term) c)))
		     L)))

Here, we generalized map-terms to produce any list like structure type.

The rest:

(define (gcd-terms a b)
  (if (empty-termlist? b)
      (reduce-terms a)
      (gcd-terms b (pseudoremainder-terms a b))))

And it produce the expected output:

(greatest-common-divisor q1 q2)
;Value: (polynomial x dense 1 -2 1)

Exercise 2.97

a.

As the algorithm needed to implement already supplied by text book, all we need
to do is just encode that algorithm using scheme. When you really understand the
guts of specified algorithm, then you should easily implement that without trouble.

Here is the result:

(define (scalar-div-terms L c)
  (map-terms-using (the-empty-termlist) adjoin-term
		   (lambda (term)
		     (make-term (order term)
				(div (coeff term) c)))
		   L))

(define (reduce-terms n d)
  (if (or (empty-termlist? n) (empty-termlist? d)) ;do nothing
      (list n d)
      (let ((g (greatest-common-divisor n d)) ;step 1
	    (O1 (max (order (first-term n))
		     (order (first-term d)))))
	(let ((t2 (first-term g)))
	  (let (c (expt (coeff t2) (1+ (- O1 (order t2)))))
	    (let ((nn (div-terms (scalar-terms c n) g))
		  (dd (div-terms (scalar-terms c d) g))) ;step 2
	      (let ((common (gcd-terms
			     (common-factor nn)
			     (common-factor dd))))
		(list (scalar-div-terms nn common)
		      (scalar-div-terms dd common))))))))) ;step 3

b.

reduce-poly is straightforward:

(define (reduce-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
	(map (lambda (t) (make-poly (variable p1) t))
	     (reduce-terms (term-list p1)
			   (term-list p2)))
	(error "Polys not in the same var -- REDUCE-POLY" (list p1 p2))))

If we have done with the interfacing with the system, the left is modify
constructor of rational number:

(define (numer x) (car x))
(define (denom x) (cadr x))
(define (make-rat n d)
  (reduce n d))

Then our test code run as expected:

(define p1 (make-polynomial 'x '(sparse (term 1 1) (term 0 1))))
(define p2 (make-polynomial 'x '(sparse (term 3 1) (term 0 -1))))
(define p3 (make-polynomial 'x '(sparse (term 1 1))))
(define p4 (make-polynomial 'x '(sparse (term 2 1) (term 0 -1))))
(define rf1 (make-rational p1 p2))
;Value: (rational (polynomial x dense -1 -1) (polynomial x dense -1 0 0 1))
(define rf2 (make-rational p3 p4))
;Value: (rational (polynomial x dense -1 0) (polynomial x dense -1 0 1))
(add rf1 rf2)
;Value: (rational (polynomial x dense -1 -2 -3 -1) (polynomial x dense -1 -1 0 1 1))

but negated. It origin our crude gcd:

  (define (gcd a b)
    (if (= b 0)
	a
	(gcd b (remainder a b))))
(gcd 5 -1)
;Value: -1

To fix this unfortunate, we can just remove above code from scheme-number
package: Use primitive gcd. This fix our problem:

rf1
;Value: (rational (polynomial x dense 1 1) (polynomial x dense 1 0 0 -1))
rf2
;Value: (rational (polynomial x dense 1 0) (polynomial x dense 1 0 -1))
(add rf1 rf2)
;Value: (rational (polynomial x dense 1 2 3 1) (polynomial x dense 1 1 0 -1 -1))

Chapter 3 Modularity, Objects, and State

Assignment and Local State

We now introduce "state" in our programming language at length. By introduction
this concept, we get to model real world system more naturally and modularly
combining with message passing programming.

Local State Variables

To introduce the local state variable, we need to special expression that can
change the state of variable. More specifically, that expression has to update
value of the state variable. For this, scheme has special syntax called (set! <name> <new-value>).

Exercise 3.1

Using the general scheme that combines local variable with set! expression, we
can easily implement what we asked:
```
(define (make-accumulator sum)
  (lambda (num)
    (set! sum (+ sum num))
    sum))
```
Exercise 3.2

Let we first specify what the make-monitored should satisfy:
- It should use the message passing programming to dispatch on input to
  implement the special symbol input.
- It should have local variable, say count, to count the number of calls of its
  procedure argument f; it should use set! to change the value of its
  internal state variable.
Then we can encode that specification directly:
```
(define (make-monitored f)
  (let ((count 0))
    (define (dispatch m)
      (cond ((eq? m 'how-many-calls?) count)
	    ((eq? m 'reset-count) (set! count 0))
	    (else
	     (set! count (1+ count))
	     (f m))))))
```

Exercise 3.3

We can do what we should do by slightly amending the procedure defined in text:

(define (make-account balance password)
  (define (withdraw amount)
    (if (>= balance amount)
	(begin (set! balance (- balance amount))
	       balance)
	"Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (define (dispatch pd m)
    (if (eq? pd password)
	(cond ((eq? m 'withdraw) withdraw)
	      ((eq? m 'deposit) deposit)
	      (else (error "Unknown request -- MAKE-ACCOUNT"
			   m)))
	"Incorrect password")))

Unfortunately this code doesn't pass the test case ((acc 'some-other-password 'deposit) 50), which returns

;The object "Incorrect password" is not applicable.
;To continue, call RESTART with an option number:
; (RESTART 2) => Specify a procedure to use in its place.
; (RESTART 1) => Return to read-eval-print level 1.

not what expected:

"Incorrect password"

We can fix this by using type analysis: we should return procedure not the
primitive data:

(define (make-account balance password)
  (define (withdraw amount)
    (if (>= balance amount)
	(begin (set! balance (- balance amount))
	       balance)
	"Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (define (dispatch pd m)
    (if (eq? pd password)
	(cond ((eq? m 'withdraw) withdraw)
	      ((eq? m 'deposit) deposit)
	      (else (error "Unknown request -- MAKE-ACCOUNT"
			   m)))
	(lambda (x) "Incorrect password")))
  dispatch)

Then it pass all the test specified in text book.

Exercise 3.4

This problem can be solved conjunction with the two previous exercises: 3.2 with 3.3.

To implement what we requested, first let we code the test cases, which encodes
all the specifications it should satisfy:

;; Test code
;;; consequetive call case
(define acc (make-account 100 'secret-password))
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"call-the-cops"
;;; reset count
((acc 'secret-password 'withdraw) 40)
60
;;; interposed case
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'secret-password 'withdraw) 40)
20
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"Incorrect password"
((acc 'some-other-password 'deposit) 50)
"call-the-cops"

Then modify the code of exercise 3.3:

(define (make-account balance password)
  (define (withdraw amount)
    (if (>= balance amount)
	(begin (set! balance (- balance amount))
	       balance)
	"Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (let ((n-incorrect 0))
    (define (dispatch pd m)
      (if (eq? pd password)
	  (begin
	    (set! n-incorrect 0)        ;reset the counter
	    (cond ((eq? m 'withdraw) withdraw)
		  ((eq? m 'deposit) deposit)
		  (else (error "Unknown request -- MAKE-ACCOUNT"
			       m))))
	  (lambda (x)
	    (set! n-incorrect (1+ n-incorrect))
	    (if (>= n-incorrect 7)
		"call-the-cops"
		"Incorrect password"))))
    dispatch))

It passes all the test case.

The Benefits of Introducing Assignment

In the text book, it explane the benefits of introducing assignment expression
in our language taking Monte Carlo test as example. Without using assignment, we
should handle explicitly the state of each experiment that use random number;
it results into leaking the guts of state over the most higher level of
language: Monte Carlo test. No more general Monte Carlo test, only the specific
instance of that kind.

Exercise 3.5

We can implement this exercise directly or we can do using what we learned so
far, data abstraction:

;; top level
(define (estimate-integral P rect trials)
  (* (rect 'area)
     (monte-carlo trials
		  (lambda () (P (random-in-rect rect))))))
;; dependency
(define (monte-carlo trials experiment)
  (define (iter trials-remaining trials-passed)
    (cond ((= trials-remaining 0)
	   (/ trials-passed trials))
	  ((experiment)
	   (iter (- trials-remaining 1) (+ trials-passed 1)))
	  (else
	   (iter (- trials-remaining 1) trials-passed))))
  (iter trials 0))

Here we captured the upper and lower bounds as rectangle; also we exploit that
structure in generating random point in that rectangle. In this way, our program
start to self-document what we are trying to do. With this, we can test this
unit by

;;; test estimate-integral
(define p1 (make-point -1 -1))
(define p2 (make-point 1 1))
(define r (make-rect p1 p2))
(define (P pt) (<= (+ (square (x-coor pt))
		      (square (y-coor pt)))
		   1))
(estimate-integral P r 100)
;; it should converge to 3.141592...

It's true that we can not test this code until implement the lower level
language but it is important to note that we can write the unit test.

Then we can implement the other levels of language:

;; middle level
(define (random-in-rect rect)
  (let ((points (list (bottom-left rect) (top-right rect))))
    (make-point (random-in-range
		 (map exact->inexact (map x-coor points)))
		(random-in-range
		 (map exact->inexact (map y-coor points))))))
;; dependency
(define (random-in-range low high)
  (let ((range (- high low)))
    (+ low (random range))))

;;; test random-in-rect
(define p1 (make-point 3 4))
(define p2 (make-point 8 7))
(define r (make-rect p1 p2))
(random-in-rect r)
;; some float point in rect

… and so on

;; low-middle level
(define (make-rect bl tr)
  (define area
    (* (- (x-coor (tr) (bl)))
       (- (y-coor (tr) (bl)))))
  (define (dispatch m)
    (cond ((eq? m 'top-right) tr)
	  ((eq? m 'bottom-left) bl)
	  ((eq? m 'area) area)
	  (else (error "Undefined request -- MAKE-RECT" m))))
  dispatch)

(define (top-right rect) (rect 'top-right))
(define (bottom-left rect) (rect 'bottom-left))

;;; test rect
(define p1 (make-point 3 4))
(define p2 (make-point 8 7))
(define r (make-rect p1 p2))
(r 'area)
;; 15
(top-right rect)
;; (8 . 7)
(bottom-left rect)
;; (3 . 4)
(rect 'unknown-message)
;; Undefined request -- MAKE-RECT unknown-message

;; lowest level
(define (make-point x y)
  (cons x y))
(define (x-coor pt) (car pt))
(define (y-coor pt) (cdr pt))

;;; test point
(define a (make-point 5 3))
(x-coor a)
;; 5
(y-coor a)
;; 3

Then we start the unit tests from the bottom. We failed in the rect level:

(define r (make-rect p1 p2))
;The object (3 . 4) is not applicable.

As soon as we inspect the code of make-rect, we realize what the problem was.
We can fix this easily:

*** in make-rect
  (define area
    (* (- (x-coor tr) (x-coor bl))
       (- (y-coor tr) (y-coor bl))))

Run our test again: this time, we got by

(top-right rect)
;Unbound variable: rect

It was due to the test code itself: we defined r to be rectangle but we called
rect. Fix and run. Then again we caught by random-in-rect:

(random-in-rect r)
;The procedure #[compound-procedure 38 random-in-range] has been called with 1 argument; it requires exactly 2 arguments.

We should have used apply in the random-in-rect procedure to apply
random-in-range to argument list; after amending, it produce:

(random-in-rect r)
;Value: (5.225704578484133 . 5.665006074331469)

Looks fine.

Then we move up the top level. It produce:

(estimate-integral P r 100)
;Value: 76/25

If we convert that value to inexact number:

(exact->inexact 76/25)
;Value: 3.04

To produce the floating-point number at first, we need to give the x and y
coordinates with floating-point number. Let's do more trials:

(estimate-integral P r 1000)
;Value: 2.98
(estimate-integral P r 10000)
;Value: 3.158
(estimate-integral P r 100000)
;Value: 3.14068

It really slowly converge to 3.141592…, π.

Exercise 3.6

We can design what we requested using the message-passing programming strategy
as we did in make-rect. First let we code the test:

;;; test rend
(rand 'generate)
<some-random-number>
((rand 'reset) 5)
(rand 'generate)
<specific-random-number>
(rand 'generate)
<some-other-random-number>
((rand 'reset) 5)
(rand 'generate)
<specific-random-number>

Then implement:

(define rand
  (let ((x random-init))
    (define (dispatch m)
      (cond ((eq? m 'generate)
	     (set! x (rand-update x))
	     x)
	    ((eq? m 'reset)
	     (lambda (new-x)
	       (set! x new-x)))
	    (else
	     error "Unknown request -- RAND" m)))))

As soon as I run the test:

(rand 'generate)
;Unassigned variable: rand

I should have to return dispatch as its return value.

Let we run test again:

(rand 'generate)
;Value: 88
((rand 'reset) 5)
;Value: 88
(rand 'generate)
;Value: 34
(rand 'generate)
;Value: 55
((rand 'reset) 5)
;Value: 55
(rand 'generate)
;Value: 34

It works as expected.

The Costs of Introducing Assignment

Allowing assignment expression in our language, introduce more profound
complication namely, what is the object and what is the sameness. It is more
alike philosophical concept. As noted in the text, to identify the sameness we
experiment by changing one object and observe the other; however in turns, to
define the "change" of one object we should first define "sameness." As
consequence, we need a priori notion of sameness to identify whether the
objects that we are compare with is same.

Exercise 3.7

Let we first code the test:

;;; test make-joint
(define peter-acc (make-account 100 'open-sesame))
(define paul-acc (make-joint peter-acc 'open-sesame 'rosebud))
((paul-acc 'rosebud 'withdraw) 50)
;; 50
((peter-acc 'open-sesame 'deposit) 30)
;; 80
(define opaque (make-joint paul-acc 'open-sesame 'this-should-not-work?))

The last line is undefined because our specification does not regulate this
ambiguity. This looseness leads us to choose the implementation detail from
several possibilities:

Let the last line of the test be valid: This would imply to joint account,
all we need to do is add new password to password list and then make change
in make-account to check whether the password is correct use password
list instead single password.
Let the last line of the test be invalid: This means that only the balance
variable should be shared between the joint accounts, which also indicates
that
```
((peter-acc 'rosebug 'deposit) 30)
```
should not work.

Let we explore the two possibilities by implementing both version.

First version:

(define (make-account1 balance password)
  (define (withdraw amount)
    (if (>= balance amount)
	(begin (set! balance (- balance amount))
	       balance)
	"Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (let ((n-incorrect 0)
	(pw-list (list password)))
    (define (dispatch pd m)
      (if (mem? pd pw-list)
	  (begin
	    (set! n-incorrect 0)        ;reset the counter
	    (cond ((eq? m 'withdraw) withdraw)
		  ((eq? m 'deposit) deposit)
		  ((eq? m 'joint) (lambda (new-pw)
				    (set! pw-list (cons new-pw pw-list))
				    dispatch))
		  (else (error "Unknown request -- MAKE-ACCOUNT1"
			       m))))
	  (lambda (x)
	    (set! n-incorrect (1+ n-incorrect))
	    (if (>= n-incorrect 7)
		"call-the-cops"
		"Incorrect password"))))
    dispatch))

(define (make-joint acc old-pw new-pw)
  ((acc old-pw 'joint) new-pw))

;; general helper function
(define (mem? el S)
  (if (null? S) false
      (or (eq? el (car S))
	  (mem? el (cdr S)))))

Then let's test:

(define peter-acc (make-account1 100 'open-sesame))

;Value: peter-acc

(define paul-acc (make-joint peter-acc 'open-sesame 'rosebud))

;Value: paul-acc

((paul-acc 'rosebud 'withdraw) 50)

;Value: 50

((peter-acc 'open-sesame 'deposit) 30)

;Value: 80

(define opaque (make-joint paul-acc 'open-sesame 'this-should-not-work?))

;Value: opaque

((opaque 'this-should-not-work? 'withdraw) 80)

;Value: 0

For the second version, as it is more tricky than the first one, first we
should specify what we want. We want that the return account from make-joint
should not share the password state variable with the account, with which
make-joint called; yet want to share balance state variable among the
two account. To accomplish this, we should have make-account with the
following properties:

We make object with unprotected account.
Given that instance, we can convert that account to protected account with
password.

By restructuring make-account like this, we can easily implement the
make-joint:

(define (make-account balance)
  (define (withdraw amount)
    (if (>= balance amount)
	(begin (set! balance (- balance amount))
	       balance)
	"Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (define (make-protected password)
    (let ((n-incorrect 0))
      (define (protected-dispatch pd m)
	(if (eq? pd password)
	    (begin
	      (set! n-incorrect 0)      ;reset the counter
	      (cond ((eq? m 'withdraw) withdraw)
		    ((eq? m 'deposit) deposit)
		    ((eq? m 'joint) (lambda (new-pw)
				      ((dispatch 'make-protected) new-pw)))
		    (else (error "Unknown request -- MAKE-PROTECTED"
				 m))))
	    (lambda (x)
	      (set! n-incorrect (1+ n-incorrect))
	      (if (>= n-incorrect 7)
		  "call-the-cops"
		  "Incorrect password"))))
      protected-dispatch))
  (define (dispatch m)
    (cond ((eq? m 'withdraw) withdraw)
	  ((eq? m 'deposit) deposit)
	  ((eq? m 'make-protected) make-protected)
	  (else (error "Unknown request -- MAKE-ACCOUNT"
		       m))))
  dispatch)

(define (make-account2 balance password)
  (((make-account balance) 'make-protected) password))

And here is the test:

(define peter-acc (make-account2 100 'open-sesame))

;Value: peter-acc

(define paul-acc (make-joint peter-acc 'open-sesame 'rosebud))

;Value: paul-acc

((paul-acc 'rosebud 'withdraw) 50)

;Value: 50

((peter-acc 'open-sesame 'deposit) 30)

;Value: 80

(define opaque (make-joint paul-acc 'open-sesame 'this-should-not-work?))

;Value: opaque

opaque

;Value: "Incorrect password"

From this exercise, we can think procedure as an object in that notion of modern
programming language. Note that in second version of make-account, we used
procedure dispatch to call the parent object or the self in the modern
programming scheme.

Exercise 3.8

Note that to implement such f
- We should use assignment expression otherwise it doesn't depend on the
  evaluation order.
- As the arguments of + should be number and the procedure + is referential
  transparent, the specification can be divided as pure imperative part and pure
  functional part; that is, we can think the evaluation order left to right as
  imperative part:
```
evaluate (f 0) => a
evaluate (f 1) => b
```
  with functional part:
```
(+ a b) = 0
```
Here is the sample implementation such f:
```
(define f
  (let ((x 0))
    (lambda (n)
      (if (= n 0)
	  x
	  (begin (set! x n) 0)))))
```
Or more imperative-oriented version:
```
(define f
  (let ((x 0))
    (lambda (n)
      (let ((temp x))
	(begin (set! x n)
	       temp)))))
```
Then we can test the interpreter:
```
(+ (f 0) (f 1))

;Value: 1

*** reevaluate f

(+ (f 1) (f 0))

;Value: 0
```
So, our interpreter evaluate augend first.

Modeling with Mutable Data

Mutable List Structure

Exercise 3.16

(define (count-pairs x)
  (if (not (pair? x))
      0
      (+ (count-pairs (car x))
	 (count-pairs (cdr x)))))

(define list1 (list 1 2 3))
(define list2
  (let ((tList (list 1 2 3)))
    (let ((tPointer (cdr tList)))
      (set-car! tPointer (cdr tPointer))
      tList)))
(define list3
  (let ((tList (list 1 2 3)))
    (let ((tPointer (cdr tList)))
      (set-car! tPointer (cdr tPointer))
      (set-car! tList (cdr tList))
      tList)))
(define list4
  (let ((tList (list 1 2 3)))
    (set-car! tList tList)))

These list are all made up of exactly three pairs; but count-pairs returns
differently:

(count-pairs list1)

;Value: 3

(count-pairs list2)

;Value: 4

(count-pairs list3)

;Value: 7

(count-pairs list4)

;Aborting!: maximum recursion depth exceeded

Exercise 3.17

Then our version should solve the problem Ben Bitdiddle encountered.
We can implement either of the paradigm, functional or imperative.
Functional:

(define (count-pairs x)
  (define (without-loop x visited)
    (if (or (mem? x visited) (not (pair? x)))
	0
	(let ((new-visited (cons x visited)))
	  (+ (without-loop (car x) new-visited)
	     (without-loop (cdr x) new-visited)
	     1))))
  (without-loop x '()))

Unfortunately, this won't work:

(count-pairs1 list1)

;Value: 3

(count-pairs1 list2)

;Value: 4

(count-pairs1 list3)

;Value: 7

(count-pairs1 list4)

;Value: 3

The problem is that in the recursive branch, each of it doesn't share the
visited argument. We can fix it by using local variable with assignment:

(define (count-pairs2 x)
  (define recorded
    (let ((visited '()))
      (lambda (x)
	(if (or (mem? x visited)
		(not (pair? x)))
	    0
	    (begin (set! visited (cons x visited))
		   (+ (recorded (car x))
		      (recorded (cdr x))
		      1))))))
  (recorded x))

As expected, it solved the problem:

(count-pairs2 list1)

;Value: 3

(count-pairs2 list2)

;Value: 3

(count-pairs2 list3)

;Value: 3

(count-pairs2 list4)

;Value: 3

Let we revise our functional version. To fix that, we should traverse the tree
structure like depth first search; we one of the branch should wait until the
other branch terminate its search. We should access the visited argument from
returned value of one branch to propagate that argument to other branch. By
returning tuple that contains visited with the counter, we can do the right thing:

(define (count-pairs1 x)
  (define (without-loop x visited)
    (if (or (mem? x visited) (not (pair? x)))
	(list 0 visited)
	(let ((result-of-one
	       (without-loop (cdr x) (cons x visited))))
	  (let ((result-of-the-other
		 (without-loop (car x) (cadr result-of-one))))
	    (list (+ (car result-of-one)
		     (car result-of-the-other)
		     1)
		  (cadr result-of-the-other))))))
  (car (without-loop x '())))

(count-pairs1 list1)

;Value: 3

(count-pairs1 list2)

;Value: 3

(count-pairs1 list3)

;Value: 3

(count-pairs1 list4)

;Value: 3

Implicitly, we used the induction on depth of x to construct this algorithm.

Exercise 3.18

This algorithm should look like that of previous exercise. Let we first code the
test:

(define (make-cycle x)
  (set-cdr! (last-pair x) x)
  x)

(define (last-pair x)
  (if (null? (cdr x))
      x
      (last-pair (cdr x))))

(define list5 (make-cycle (list 1 2 3 4)))
(define list6 (append '(a b c d) list5))

(cycle? list1)
#f
(cycle? list2)
#f
(cycle? list3)
#f
(cycle? list4)
#f
(cycle? list5)
#t
(cycle? list6)
#t
(cycle? list7)
#t

Here is the code that exploits local state variable:

(define (cycle? x)
  (define iter
    (let ((visited '()))
      (lambda (x)
	(cond ((null? x) false)
	      ((mem? x visited) true)
	      (else
	       (set! visited (cons x visited))
	       (iter (cdr x)))))))
  (iter x))

… And test:

(cycle? list1)

;Value: #f

(cycle? list2)

;Value: #f

(cycle? list3)

;Value: #f

(cycle? list4)

;Value: #f

(cycle? list5)

;Value: #t

(cycle? list6)

;Value: #t

(cycle? list7)

;Value: #t

As we wrote our test to be as exhaustive as possible, we can be quite confidence
about our program: We tested the extremum case such as list7 with normal case
list6 and list5.

Exercise 3.19

The keyword is constant amount of space; it implies we should code our code
iterative. And also since we operate on list, we need to fully understand what
the properties list structure possesses. If we focus on the convention that we
traverse list structure one way only– cdr ing down, we could come up with the
"very clever" idea as noted in text book:
1. Send one person to stride one step further by cdr in each iteration where
2. Send the other one until the place where the first person stand checking
  whether the each pointer is same as of first person.
3. If it is, and if the two pointer located differently in examining list, then
  it is cycled list.
4. otherwise second person stride one step further.
5. If the second one reach the first one without trouble then first one stride
  one step further.
6. Loop from 2 to 5 until the first one reach nil pointer. If it reaches nil
  pointer then return false.
As this algorithm inherently evolve as iterative process, we got the algorithm
that we wanted. To implement the check algorithm that whether two pointer is
same but in different place, we could assign each pointer to number, namely the
step needed to get reached to that place. However, although it is subtle, this
strategy doesn't assure this assigned number doesn't grow in space: It would be
consume more space when the step get huge number. To cope with this situation we
can exploit the observation that, as our program return as soon as it found the
first cycle point, the different place but same pointer should have different
previous place where visited just before the current place.

Here is the code:
```
(define (cycle1? x)
  (define first-man
    (let ((prev '()))
      (lambda (current)
	(define second-man
	  (let ((prev2 '()))
	    (lambda (current2)
	      (if (eq? current current2)
		  (eq? prev prev2)
		  (begin (set! prev2 current2)
			 (second-man (cdr current2)))))))
	(cond ((null? current) false)
	      ((not (second-man x)) true)
	      (else
	       (set! prev current)
	       (first-man (cdr current)))))))
  (first-man x))
```
And the test:
```
(cycle1? list1)

;Value: #f

(cycle1? list2)

;Value: #f

(cycle1? list3)

;Value: #f

(cycle1? list4)

;Value: #f

(cycle1? list5)

;Value: #t

(cycle1? list6)

;Value: #t

(cycle1? list7)

;Value: #t
```
Or functional version:
```
(define (cycle2? x)
  (define (first-man prev current)
    (define (second-man prev2 current2)
      (if (eq? current current2)
	  (eq? prev prev2)
	  (second-man current2 (cdr current2))))
    (cond ((null? current) false)
	  ((not (second-man '() x)) true)
	  (else
	   (first-man current (cdr current)))))
  (first-man '() x))
```
We could use less define notation:
```
(define (cycle3? x)
  (let ((first-man
	 (lambda (prev current)
	   (let ((second-man
		  (lambda (prev2 current2)
		    (if (eq? current current2)
			(eq? prev prev2)
			(second-man current2 (cdr current2))))))
	     (cond ((null? current) false)
		   ((not (second-man '() x)) true)
		   (else
		    (first-man current (cdr current))))))))
    (first-man '() x)))
```
Unfortunately, this won't work:
```
(cycle3? list7)

;Unbound variable: first-man
```
To understand why, we can desugar (let ((<var> <val>)) body) expression as
((lambda (<var>) body) <val>): The lambda expression in the first let
notation, there is no way to reference first-man in the body of lambda
expression of right-hand side; we need define to abstract this.
Lecture 5A: Assignment, State, and Side-effects

I've got quite intrigued by that if we can replace all the set! expression
with define ? (well, we supposed to not to do)

Let's experiment:
```
(define t 1)

;Value: t

(define t (+ t 1))

;Value: t

t

;Value: 2
```
Seems like we could replace the use of set!; but:
```
(define test
  (let ((t 1))
    (define t (+ t 1))
    t))
```
This definition won't work:
```
(define test
  (let ((t 1))
    (define t (+ t 1))
    t))

;Unassigned variable: t
```
Do more experiment to grasp what's going on here:
```
(define test
  (let ((t 1))
    (define t1 (+ t 1))
    (define t1 (+ t1 1))
    t))

;duplicate internal definitions for (#[uninterned-symbol 38 t1]) in |#[let-procedure]|
```
From these sequence of experiments, we can deduce that the effect of define,
which is similar with set!, is only allowed to REPL; in other words, only in
global environment. Within the evaluation model we learned so far, we can not
understand fully the behavior of define.

In lecture, professor start to define what means by the word "bound":

We say that a variable, V, is "bound in an expression", E, if the meaning of E
is unchanged by the uniform replacement of a variable, W, not occurring in E,
for every occurrence of V in E.

And also "free variable":

We say that a variable, V, is "free in and expression", E, if the meaning of E
is changed by the uniform replacement of a variable, W, not occurring in E, for
every occurrence of V in E.

By consequence of this, we have concept named "scope":

If x is a bound variable in E then there is a lambda expression where it is
bound. We call the list of formal parameters of the lambda expression the "bound
variable list" and we say that the lambda expression "binds" the variables
"declared" in its bound variable list. In addition, those parts of the
expression where a variable has a value defined by the lambda expression which
binds it is called the "scope" of the variable.

The evaluation rule 1:

A procedure object is applied to a set of arguments by constructing a frame,
binding the formal parameters of the procedure to the actual arguments of the
call, and then evaluating the body of the procedure in the context of the new
environment constructed. The new fram has as its enclosing environment the
environment part of the procedure object being applied.

The evaluation rule 2:

A lambda-expression is evaluated relative to a given environment as follows: A
new procedure object is formed, combining the text (code) of the lambda
expression with a pointer to the environment of evaluation.

The terminologis about actions and identity:

We say that an action, A, had an effect on an object, X, (or equivalently, that
X was changed by A) if some property, P, which was true of X before A became
false of X after A.

We say that two objects, X and Y, are the same if any action which has an effect
on X has the same effect on Y.

Professor end the lecture with following quote:

Mr. Gilbert and Sullivan said,

Things are seldom what they seem,
Skim milk masquerades as cream…

He wanted to implies, I guess, the stream concept that would come up with following lecture;
if we consider the meaning of quote in this specific context but it will convolve a lot more
profound meaning I think.

Representing Queues

As we do usually, we build our data abstraction for our queue implementation:

a constructor: (make-queue) returns an empty queue.
two selectors: - (empty-queue? <queue>) tests if the queue is empty.
- (front-queue <queue>) returns the object at the front of the queue,
  signaling an error if the queue is empty; it does not modify the queue.
two mutators: - (insert-queue! <queue> <item>) inserts the item at the front of the
queue and returns the modified queue as its value.
- (delete-queue! <queue>) removes the item at the front of the queue and
  returns the modified queue as its value, signaling an error if the queue is
  empty before the deletion.

For the implementation restriction, all the operation should require Θ (1) steps.

In text book, they install additional layer, between manipulating queue
representation and implementing queue representation using list structure:

;;; wrapping around the queue representation
(define (front-ptr queue) (car queue))
(define (rear-ptr queue) (cdr queue))
(define (set-front-ptr! queue item) (set-car! queue item))
(define (set-rear-ptr! queue item) (set-cdr! queue item))

;;; selector -- predicate
(define (empty-queue? queue) (null? (front-ptr queue)))

;;; constructor
(define (make-queue) (cons '() '()))

;;; selector -- first element
(define (front-queue queue)
  (if (empty-queue? queue)
      (error "FRONT called with an empty queue" queue)
      (car (front-ptr queue))))

;;; mutator -- insert item
(define (insert-queue! queue item)
  (let ((new-pair (cons item '())))
    (cond ((empty-queue? queue)
	   (set-front-ptr! queue new-pair)
	   (set-rear-ptr! queue new-pair)
	   queue)
	  (else
	   (set-cdr! (rear-ptr queue)
		     new-pair)
	   (set-rear-ptr! queue new-pair)
	   queue))))

;;; mutator -- delete item
(define (delete-queue! queue)
  (cond ((empty-queue? queue)
	 (error "DELETE! called with an empty queue" queue))
	(else
	 (set-front-ptr! queue (cdr (front-ptr queue)))
	 queue)))

Exercise 3.21

Eva Lu Ator denotes that it is just reachable from two different pointer not
that insert-queue inserts item twice; recall the exercise 3.16, where all the
list has exactly three pairs in it but represented differently. (in both Ben
Bitdiddle's count-pairs and Lisp printer)

Here, to understand how the Lisp printer works, we implement the Lisp printer.
To implement that, we use nested induction – induction on depth of expression
and within that, we run induction on width of expression. To deduce the
specification of Lisp printer, we play with Lisp interpreter for a while:

(cons 1 2)

;Value: (1 . 2)

(list 1 2)

;Value: (1 2)

(cons 1 (cons 2 3))

;Value: (1 2 . 3)

(cons (cons 1 2) 3)

;Value: ((1 . 2) . 3)

(cons 1 (cons 2 '()))

;Value: (1 2)

And here is the implementation:

(define (print exp)
  (cond ((pair? exp) (print-exp exp))
	(else                           ;not compound
	 (display exp))))

(define (print-exp exp)
  (define (iter exp)
    (cond ((null? exp))
	  ((pair? exp)
	   (display " ")
	   (print (car exp))
	   (iter (cdr exp)))
	  (else
	   (display " . ")
	   (print exp))))
  (display "(")
  (print (car exp))
  (iter (cdr exp))
  (display ")"))

Here is the test:

(print (cons 1 2))
(1 . 2)
;Unspecified return value

(print (list 1 2))
(1 2)
;Unspecified return value

(print (cons 1 (cons 2 3)))
(1 2 . 3)
;Unspecified return value

(print (cons (cons 1 2) 3))
((1 . 2) . 3)
;Unspecified return value

(print (cons 1 (cons 2 '())))
(1 2)
;Unspecified return value

Then here is the examples for what the Ben Bitdiddle misunderstood:

(print list3)
(((3) 3) (3) 3)
;Unspecified return value

(print list2)
(1 (3) 3)
;Unspecified return value

Consequently we can conclude that the Lisp printer display all the element
recursively following given pointer.

Actually, what version I use for now as scheme interpreter is smarter than that:

(define q1 (make-queue))

;Value: q1

(insert-queue! q1 'a)

;Value: (#0=(a) . #0#)

(insert-queue! q1 'b)

;Value: ((a . #0=(b)) . #0#)

(delete-queue! q1)

;Value: (#0=(b) . #0#)

(delete-queue! q1)

;Value: (() b)

It recognize the same pointer using, I guess, memorize all the pointer it
encountered. But for now, let we stick the old version of printer in text book.

Return to our task, print-queue is really simple: Just print following the
first pointer of queue:

(define (print-queue queue)
  (display (front-ptr queue)))

Then test:

(define q1 (make-queue))
;Value: q1

(print-queue (insert-queue! q1 'a))
(a)
;Unspecified return value

(print-queue (insert-queue! q1 'b))
(a b)
;Unspecified return value

(print-queue (delete-queue! q1))
(b)
;Unspecified return value

(print-queue (delete-queue! q1))
()
;Unspecified return value

Ben Bitdiddle should satisfy what print-queue display.

Exercise 3.22

We can map our previous implementation to message passing style by

(front-ptr queue) → front-ptr in make-queue
(rear-ptr queue) → rear-ptr in make-queue
…

It get boring to jot down all the relation; let I just show the result:

(define (make-queue2)
  (let ((front-ptr '())
	(rear-ptr '()))
    ;; selector -- predicate
    (define (empty-queue?) (null? front-ptr))
    ;; selector -- first item
    (define (front-queue)
      (if (empty-queue?)
	  (error "FRONT called with an empty queue -- MAKE-QUEUE2" dispatch)
	  (car front-ptr)))
    (define (insert-queue! item)
      (let ((new-pair (cons item '())))
	(cond ((empty-queue?)
	       (set! front-ptr new-pair)
	       (set! rear-ptr new-pair)
	       dispatch)
	      (else
	       (set-cdr! rear-ptr new-pair)
	       (set! rear-ptr new-pair)
	       dispatch))))
    (define (delete-queue!)
      (cond ((empty-queue?)
	     (error "DELETE! called with an empty queue -- MAKE-QUEUE2" dispatch))
	    (else
	     (set! front-ptr (cdr front-ptr))
	     dispatch)))
    (define (dispatch m)
      (cond ((eq? m 'empty-queue?) empty-queue?)
	    ((eq? m 'front-queue) front-queue)
	    ((eq? m 'insert-queue!) insert-queue!)
	    ((eq? m 'delete-queue!) delete-queue!)
	    (else
	     (error "Unknown request -- MAKE-QUEUE2" m))))
    dispatch))

And here is how we should use:

(define q1 (make-queue2))

;Value: q1

((q1 'insert-queue!) 'a)

;Value: #[compound-procedure 44 dispatch]

((q1 'front-queue))

;Value: a

((q1 'insert-queue!) 'b)

;Value: #[compound-procedure 44 dispatch]

((q1 'front-queue))

;Value: a

((q1 'delete-queue!))

;Value: #[compound-procedure 44 dispatch]

((q1 'front-queue))

;Value: b

((q1 'delete-queue!))

;Value: #[compound-procedure 44 dispatch]

((q1 'front-queue))

;FRONT called with an empty queue -- MAKE-QUEUE2 #[compound-procedure 44 dispatch]

We can integrate print-queue to this procedure object:

(define (make-queue2)
  (let ((front-ptr '())
	(rear-ptr '()))
    ;; selector -- predicate
    (define (empty-queue?) (null? front-ptr))
    ;; selector -- first item
    (define (front-queue)
      (if (empty-queue?)
	  (error "FRONT called with an empty queue -- MAKE-QUEUE2" dispatch)
	  (car front-ptr)))
    (define (insert-queue! item)
      (let ((new-pair (cons item '())))
	(cond ((empty-queue?)
	       (set! front-ptr new-pair)
	       (set! rear-ptr new-pair)
	       (print-queue)
	       dispatch)
	      (else
	       (set-cdr! rear-ptr new-pair)
	       (set! rear-ptr new-pair)
	       (print-queue)
	       dispatch))))
    (define (delete-queue!)
      (cond ((empty-queue?)
	     (error "DELETE! called with an empty queue -- MAKE-QUEUE2" dispatch))
	    (else
	     (set! front-ptr (cdr front-ptr))
	     (print-queue)
	     dispatch)))
    (define (print-queue) (display front-ptr))
    (define (dispatch m)
      (cond ((eq? m 'empty-queue?) empty-queue?)
	    ((eq? m 'front-queue) front-queue)
	    ((eq? m 'insert-queue!) insert-queue!)
	    ((eq? m 'delete-queue!) delete-queue!)
	    (else
	     (error "Unknown request -- MAKE-QUEUE2" m))))
    dispatch))

((q1 'insert-queue!) 'a)
(a)
;Value: #[compound-procedure 45 dispatch]

((q1 'insert-queue!) 'b)
(a b)
;Value: #[compound-procedure 45 dispatch]

((q1 'delete-queue!))
(b)
;Value: #[compound-procedure 45 dispatch]

((q1 'delete-queue!))
()
;Value: #[compound-procedure 45 dispatch]

Note that with this local state paradigm, message passing style is more
succinctly encode the specification than the representation using concrete data
structure– here pair.

Exercise 3.23

Not only to traverse one way– cdr, we need means to traverse the opposite
way to implement deque. As we requested in implementation of queue, we need to
implement all the operation in Θ (1) steps.

Here we devise new data structure not only deque, also node with which we
represent deque. Node has many analogy with primitive data structure, pair;
it construct one chunk using several pointers together, but node has three
pointers in one chunk whereas pair has two pointers in it.

Here is the specification for node:

constructor: (make-node prev item next) returns node that has three
pointers, each of which points prev, item, next, respectively.
selectors: - (prev node) returns first pointer.
- (item node) returns second pointer.
- (next node) returns last pointer.
mutators: - (set-prev! node new-prev) resets its pointer that points prev to new-prev.
- (set-item! node new-item) resets its pointer that points item to new-item.
- (set-next! node new-next) resets its pointer that points next to new-next.

Here is the implementation for node:

;;; constructor
(define (make-node prev item next)
  (define (set-prev! new-prev) (set! prev new-prev))
  (define (set-item! new-item) (set! item new-item))
  (define (set-next! new-next) (set! next new-next))
  (define (dispatch m)
    (cond ((eq? m 'prev) prev)
	  ((eq? m 'item) item)
	  ((eq? m 'next) next)
	  ((eq? m 'set-prev!) set-prev!)
	  ((eq? m 'set-item!) set-item!)
	  ((eq? m 'set-next!) set-next!)
	  (else
	   (error "Unknown request -- MAKE-NODE" m))))
  dispatch)

;;; selectors
(define (prev node) (node 'prev))
(define (item node) (node 'item))
(define (next node) (node 'next))

;;; mutators
(define (set-prev! node new-prev) ((node 'set-prev!) new-prev))
(define (set-item! node new-item) ((node 'set-item!) new-item))
(define (set-next! node new-next) ((node 'set-next!) new-next))

Then we can implement deque using the analogy with queue. During
implementing node, queue, and the other massage passing style code, I got
intrigued by how am I going to implement the conventional array in scheme using
massage passing style; it should access its element with Θ (1) steps. So
far, in message passing style, we dealt with only fixed sized argument list.

One way to deal with unspecified argument list is use the primitive procedure
syntax, e.g. (x y . z); but the problem of this approach is that to access the
contents that stored in z, as it is list, needs Θ (n) steps where n is
the size of z. To deal with this unfortunate, if we believe that accessing any
variable in the frame require only Θ(1) steps, we need to register all the
argument of z (with x and y also) current environment of callee, for which
we don't have any method.

Let alone that problem let we conclude our original task. First let test our
node code:

(define n (make-node '() 2 '()))

;Value: n

(define n2 (make-node n 3 '()))

;Value: n2

(item n)

;Value: 2

(item n2)

;Value: 3

(item (prev n2))

;Value: 2

(define n3 (make-node '() 4 '()))

;Value: n3

(set-next! n2 n3)

;Value: ()

(set-prev! n3 n2)

;Value: ()

(item (prev (prev n3)))

;Value: 2

And this is straightforward implementation for deque:

;; constructor
(define (make-deque)
  (let ((front-ptr '())
	(rear-ptr '()))
    ;; selector -- predicate
    (define (empty-deque?) (or (null? front-ptr)
			       (null? rear-ptr)))
    ;; selector -- first item
    (define (front-deque)
      (if (empty-deque?)
	  (error "FRONT called with an empty deque -- MAKE-DEQUE" dispatch)
	  (item front-ptr)))
    (define (rear-deque)
      (if (empty-deque?)
	  (error "REAR called with an empty deque -- MAKE-DEQUE" dispatch)
	  (item rear-ptr)))
    (define (rear-insert-deque! item)
      (let ((new-node (make-node '() item '())))
	(cond ((empty-deque?)
	       (set! front-ptr new-node)
	       (set! rear-ptr new-node)
	       dispatch)
	      (else
	       (set-next! rear-ptr new-node)
	       (set! rear-ptr new-node)
	       dispatch))))
    (define (front-insert-deque! item)
      (let ((new-node (make-node '() item '())))
	(cond ((empty-deque?)
	       (set! front-ptr new-node)
	       (set! rear-ptr new-node)
	       dispatch)
	      (else
	       (set-prev! front-ptr new-node)
	       (set! front-ptr new-node)
	       dispatch))))
    (define (front-delete-deque!)
      (cond ((empty-deque?)
	     (error "FRONT-DELETE! called with an empty deque -- MAKE-DEQUE" dispatch))
	    (else
	     (set! front-ptr (next front-ptr))
	     dispatch)))
    (define (rear-delete-deque!)
      (cond ((empty-deque?)
	     (error "FRONT-DELETE! called with an empty deque -- MAKE-DEQUE" dispatch))
	    (else
	     (set! rear-ptr (prev rear-ptr))
	     dispatch)))
    (define (dispatch m)
      (cond ((eq? m 'empty-deque?) empty-deque?)
	    ((eq? m 'front-deque) front-deque)
	    ((eq? m 'rear-deque) rear-deque)
	    ((eq? m 'front-insert-deque!) front-insert-deque!)
	    ((eq? m 'rear-insert-deque!) rear-insert-deque!)
	    ((eq? m 'front-delete-deque!) front-delete-deque!)
	    ((eq? m 'rear-delete-deque!) rear-delete-deque!)
	    (else
	     (error "Unknown request -- MAKE-DEQUE" m))))
    dispatch))
;; selector -- predicate
(define (empty-deque? deque) ((deque 'empty-deque?)))
;; selector -- first item
(define (front-deque deque) ((deque 'front-deque)))
;; selector -- last item
(define (rear-deque deque) ((deque 'rear-deque)))
;; mutator -- insert front
(define (front-insert-deque! deque item) ((deque 'front-insert-deque!) item))
;; mutator -- insert rear
(define (rear-insert-deque! deque item) ((deque 'rear-insert-deque!) item))
;; mutator -- delete first
(define (front-delete-deque! deque) ((deque 'front-delete-deque!)))
;; mutator -- delete last
(define (rear-delete-deque! deque) ((deque 'rear-delete-deque!)))

Test for deque:

(define d (make-deque))

;Value: d

(empty-deque? d)

;Value: #t

(front-insert-deque! d 'a)

;Value: #[compound-procedure 38 dispatch]

(rear-deque d)

;Value: a

(front-deque d)

;Value: a

(rear-insert-deque! d 'b)

;Value: #[compound-procedure 38 dispatch]

(rear-deque d)

;Value: b

(front-deque d)

;Value: a

(front-delete-deque! d)

;Value: #[compound-procedure 38 dispatch]

(front-delete-deque! d)

;Value: #[compound-procedure 38 dispatch]

(empty-deque? d)

;Value: #t

Representing Tables

In chapter 2, we exploited a lot the data structure named table. Table was
the backbone our data-directed programming scheme. Table is so general data
structure to the extent many of the "practical" programming languages provides
table as one of the primitive data structure. In Lisp, we don't have any table
like structure for granted. But we can implement that data structure by our own
if we allowed to use assignment.

Then what is table? What data structure we think as table? Here we define what
we think as table informally:

We should be able to retrieve the registered value in the table by its key.
We should be able to insert new entry, which contains key value pair-like
structure, to the table.

More formally table should satisfy following axioms:

(lookup key (begin (insert! (make-entry key value) table) table))
returns value.

What value (lookup not-in-the-table table) should returns is implementation
detail. The implementor can choose whatever value we want unless the specifier
doesn't specify to that extent.

For the implementation detail, we need to use headed list as the backbone of
our table to insert given entry to the given table; without this, we couldn't
locate the locus of the table's contents.

Here is the sample implementation in text book:

;;; constructor
(define (make-table)
  (list '*table*))

;;; selector + predicate
(define (lookup key table)
  (let ((record (assoc key (cdr table))))
    (if record
	(cdr record)
	false)))
;;; dependency
;;; we represent contents of table as A-list
(define (assoc key records)
  (cond ((null? records) false)
	((equal? key (caar records)) (car records))
	(else (assoc key (cdr records)))))

;;; mutator
(define (insert! key value table)
  (let ((record (assoc key records)))
    (if record
	(set-cdr! record value)
	(set-cdr! table
		  (cons (cons key value)
			(cdr table)))))
  'ok)

Two-dimensional tables

We can extend one-dimensional table above to two-dimensional table by observing
that each value of one-dimensional table could be A-list. As the key of the
subtables performs as header, we don't need any auxiliary header as we did in
one-dimensional table.

As we noted above, all the left is to implement two dimensional lookup procedure
and insert accordingly:

(define (lookup key-1 key-2 table)
  (let ((subtable (assoc key-1 (cdr table))))
    (if subtable
	(let ((record (assoc key-2 (cdr subtable))))
	  (if record
	      (cdr record)
	      false))
	false)))

(define (insert! key-1 key-2 value table)
  (let ((subtable (assoc key-1 (cdr table))))
    (if subtable
	(let ((record (assoc key-2 (cdr subtable))))
	  (if record
	      (set-cdr! record value)
	      (set-cdr! subtable
			(cons (cons key-2 value)
			      (cdr subtable)))))
	(set-cdr! table
		  (cons (list key-1
			      (cons key-2 value))
			(cdr table)))))
  'ok)

Creating local tables

We can convert our concrete representation to message-passing:

(define (make-table2)
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
	(if subtable
	    (let ((record (assoc key-2 (cdr subtable))))
	      (if record
		  (cdr record)
		  false))
	    false)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
	(if subtable
	    (let ((record (assoc key-2 (cdr subtable))))
	      (if record
		  (set-cdr! record value)
		  (set-cdr! subtable
			    (cons (cons key-2 value)
				  (cdr subtable)))))
	    (set-cdr! local-table
		      (cons (list key-1
				  (cons key-2 value))
			    (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
	    ((eq? m 'insert-proc!) insert!)
	    (else (error "Unknown operation -- TABLE" m))))
    dispatch))

Exercise 3.24

It is way too easy to implement we get what we want by slightly amending above
implementation:

(define (make-table3 same-key?)

  (define (assoc key records)
    (cond ((null? records) false)
	  ((same-key? key (caar records)) (car records))
	  (else (assoc key (cdr records)))))

  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
	(if subtable
	    (let ((record (assoc key-2 (cdr subtable))))
	      (if record
		  (cdr record)
		  false))
	    false)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
	(if subtable
	    (let ((record (assoc key-2 (cdr subtable))))
	      (if record
		  (set-cdr! record value)
		  (set-cdr! subtable
			    (cons (cons key-2 value)
				  (cdr subtable)))))
	    (set-cdr! local-table
		      (cons (list key-1
				  (cons key-2 value))
			    (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
	    ((eq? m 'insert-proc!) insert!)
	    (else (error "Unknown operation -- TABLE" m))))
    dispatch))

Exercise 3.25

It is equivalent to prove the behavior of the specification: Induction on depth
of the table. If we persist with the A-list representation as before, and also
assume that all the generalized table structured appropriately, we can easily
extend the previous table to generalized one:

(define (lookup key-list table)
  (cond ((null? key-list)
	 (error "LOOKUP called with empty key-list"))
	((null? (cdr key-list))
	 (let ((record (assoc (car key-list) (cdr table))))
	   (if record
	       (cdr record)
	       false)))
	(else
	 (let ((subtable (assoc (car key-list) (cdr table))))
	   (if subtable
	       (lookup (cdr key-list table))
	       false)))))

(define (insert! key-list value table)
  (cond ((null? key-list)
	 (error "INSERT! called with empty key-list"))
	((null? (cdr key-list))
	 (let ((record (assoc (car key-list) records)))
	   (if record
	       (set-cdr! record value)
	       (set-cdr! table
			 (cons (cons (car key-list) value)
			       (cdr table))))))
	(else
	 (let ((subtable (assoc (car key-list) (cdr table))))
	   (if subtable
	       (insert! (cdr key-list) value table)
	       (set-cdr! table
			 (cons (make-table-with key-list value)
			       (cdr table)))))))
  'ok)

(define (make-table-with key-list value)
  (if (null? (cdr key-list))
      (cons (car key-list) value)
      (list (car key-list)
	    (make-table-with (cdr key-list) value))))

I didn't tested it but it would work only if we lookup the table that contains
entry with key list with which we lookup. Unfortunately, it is huge bug, since
the user of lookup doesn't know whether the table has such entry. To fix this,
we make our table using the strategy learned from lecture, Abstract Data Type.

In previous exercise, we only dealt with table of fixed dimension; we don't need
to check whether the value of given entry is table or not. Here we don't know
fore hand the dimension of table, and to deal with such situation, we treat
table as special value of one dimensional table. By induction on the depth on
the dimension of table, our result table would handle the unspecified dimension
of table without any trouble.

At our disposal, we have two candidates for implementation of this:
message-passing style with local state or dispatch on data type with concrete
data structure.

Here we first try out the message-passing style:

;; constructor
(define (make-table4)
  (let ((local-table (list '*table*)))
    (define (lookup-internal key-list)
      (let ((record (assoc (car key-list) (cdr local-table))))
	(if record
	    (let ((value (cdr record)))
	      (cond ((null? (cdr key-list)) value)
		    ((table? value)
		     (lookup (cdr key-list) value))
		    (else false)))
	    false)))
    (define (insert-internal! key-list value)
      (let ((record (assoc (car key-list) (cdr local-table))))
	(if record
	    (let ((value (cdr record)))
	      (cond ((null? (cdr key-list)) (set-cdr! record value))
		    ((table? value)
		     (insert! (cdr key-list) value))))
	    (set-cdr! local-table
		      (cons (make-table-with key-list value)
			    (cdr local-table)))))
      'ok)
    (define (make-table-with key-list value)
      (if (null? (cdr key-list))
	  (cons (car key-list) value)
	  (let ((tbl (make-table4)))
	    (insert! (cdr key-list)
		     value
		     tbl)
	    (cons (car key-list) tbl))))
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup-internal)
	    ((eq? m 'insert-proc!) insert-internal!)
	    ((eq? m 'table?) true)
	    (else (error "Unknown operation -- TABLE" m))))
    dispatch))

;; selector -- predicate
(define (table? t) (t 'table?))
(define (lookup ks t) ((t 'lookup-proc) ks))

;; mutator
(define (insert! ks v t) ((t 'insert-proc!) ks v))

Then test:

;; constructor
(define tbl (make-table4))

;Value: tbl

;; predicate
(table? tbl)

;Value: #t

;; mutator
(insert! '(1 2 3 4) 5 tbl)

;Value: ok

;; selector
(lookup '(1 2 3 4) tbl)

;Value: 5

(lookup '(1) tbl)

;Value: #[compound-procedure 39 dispatch]

(lookup '(2 3 4) (lookup '(1) tbl))

;Value: 5

The another way:

;; type tag
(define table-tag '*table*)
;; constructor
(define (make-table5)
  (list table-tag))

;; selector -- predicate
(define (table? t)
  (and (pair? t) (eq? (car t) table-tag)))

;; selector
(define (lookup key-list tbl)
  (let ((record (assoc (car key-list) (cdr tbl))))
    (if record
	(let ((value (cdr record)))
	  (cond ((null? (cdr key-list)) value)
		((table? value)
		 (lookup (cdr key-list) value))
		(else false)))
	false)))

;; mutator
(define (insert! key-list value tbl)
  (let ((record (assoc (car key-list) (cdr tbl))))
    (if record
	(let ((value (cdr record)))
	  (cond ((null? (cdr key-list)) (set-cdr! record value))
		((table? value)
		 (insert! (cdr key-list) value))))
	(set-cdr! tbl
		  (cons (make-table-with key-list value)
			(cdr tbl)))))
  'ok)

(define (make-table-with ks v)
  (if (null? (cdr ks))
      (cons (car ks) v)
      ;; (let ((tbl (make-table5)))
      ;;       (insert! (cdr key-list)
      ;;                value
      ;;                tbl)
      ;;       (cons (car key-list) tbl))))
      (cons (car ks) (list table-tag    ;more efficiently
			   (make-table-with (cdr ks) v)))))

To design make-table-with, I've exploit the opaque type. And here is the test:

(define tbl (make-table5))

;Value: tbl

(table? tbl)

;Value: #t

(insert! '(1 2 3 4) 5 tbl)

;Value: ok

(lookup '(1 2 3 4) tbl)

;Value: 5

(lookup '(2 3 4) (lookup '(1) tbl))

;Value: 5

Note that the latter one is more efficient than former one; also seems cleaner.
Object-oriented paradigm do not always win.

Exercise 3.26

As we already implemented the lookup procedure for binary tree in exercise 2.66.
All the left is to implement constructor and mutator of table.

With the same argument of headed list– our first backbone of table, we need to
tag a type to locate "place" to mutate table.

Here for simplicity, we don't consider the "balance" of tree structure; but that
issue can be dealt with using amortized algorithm.

Here's the result:

;; constructor
(define (make-table6)
  (cons table-tag '()))

;; selector
(define (lookup key table)
  (let ((entry (assoc-tree key (cdr table))))
    (if entry
	(value entry)
	false)))
(define (assoc-tree given-key tree)
  (if (null? tree)
      false
      (let ((hd (key (entry tree))))
	(cond ((= given-key hd) (entry tree))
	      ((< given-key hd) (assoc-tree given-key (left-branch tree)))
	      ((> given-key hd) (assoc-tree given-key (right-branch tree)))))))

;; mutator
(define (insert! key value table)
  (let ((tree (cdr table)))
    (if (null? tree)
	(set-cdr! table
		  (make-tree-with-entry (make-entry key value)))
	(insert-tree! key value tree))))

(define (insert-tree! aKey aValue tree)
  (let ((hd (key (entry tree))))
    (cond ((= aKey hd) (set-value! (entry tree) aValue))
	  ((< aKey hd)
	   (if (null? (left-branch tree))
	       (set-left-branch! tree (make-tree-with-entry (make-entry aKey aValue)))
	       (insert-tree! aKey aValue (left-branch tree))))
	  ((> aKey hd)
	   (if (null? (right-branch tree))
	       (set-right-branch! tree (make-tree-with-entry (make-entry aKey aValue)))
	       (insert-tree! aKey aValue (right-branch tree)))))))

(define (make-tree-with-entry entry) (make-tree entry '() '()))

;; backbone of table
;;; constructor
(define (make-tree entry left right)
  (list entry left right))
;;; selectors
(define (entry tree) (car tree))
(define (left-branch tree) (cadr tree))
(define (right-branch tree) (caddr tree))
;;; mutators
(define (set-left-branch! tree left-tree) (set-car! (cdr tree) left-tree))
(define (set-right-branch! tree right-tree) (set-car! (cddr tree) right-tree))

;; lowest layer entry language
(define (make-entry key value)
  (cons key value))
(define (key entry) (car entry))
(define (value entry) (cdr entry))
(define (set-value! entry value) (set-cdr! entry value))

Test:

(define tbl (make-table6))

;Value: tbl

(insert! 1 'a tbl)

;Unspecified return value

(lookup 1 tbl)

;Value: a

(insert! 5 'e tbl)

;Unspecified return value

(insert! -3 'z tbl)

;Unspecified return value

tbl

;Value: (*table* (1 . a) ((-3 . z) () ()) ((5 . e) () ()))

(lookup -3 tbl)

;Value: z

Exercise 3.27

I've drawed environment diagram in my personal digital paper. To analysis the
step complexity of memo-fib, let we assume that our memo-fib procedure does
not compute the result of the argument that previously called with – actually
this is the reason we use memoization for – by wishful thinking. Then note
that, for instance, if our entry point – the first procedure call – was made
by (memo-fib 7), depending on how our the interpreter works, it should compute
after some step (memo-fib 6) (or (memo-fib 5)) followed by (memo-fib 5)
(or (memo-fib 6)); observe when it comes to the latter point of computation
the result of that should already be in the local table of memo-fib by the
assumption. Nevertheless, in any circumstance, if we let (T(n)) denote the step
complexity of (memo-fib n) then we get [T(n) - T(n - 1) = \Theta(1)] from
which, we can conclude that [T(n) = \Theta(n)].

To prove our assumption, we need to argue in our environment model for
evaluation, which just complicate our discussion; yet we can grasp the taste of
it by simulating (drawing) the evaluation process using environment model.

A Simulator for Digital Circuits

Here we implement event-driven simulation; usually we encounter event-driven
programming in web developing – JavaScript, ruby on rails, and so on. For
instance, we develop language for digital circuits simulator.

As the name of our language, simulator, indicates that we model real world
object exploiting local state variable.

As a powerful language should consist of primitive elements, means of combination, means of
abstraction, our simulator language also composed by those:

primitive elements: Digital circuits constructed by combination of simple
logical function boxes:
- Inverter
- And-gate
- Or-gate
means of combination: We can construct more complex function boxes using
previous ones: Using wiring up the components.
means of abstraction: As we embed our language in scheme, we inherit
scheme's means of abstraction – define.

Note that we described above components using real world terminology since we
assumed that we mapped that concept to our language.

For instance, let we construct half-adder circuit:

;;; consturct half-adder
(define a (make-wire))
(define b (make-wire))
(define c (make-wire))
(define d (make-wire))
(define e (make-wire))
(define s (make-wire))
(or-gate a b d)
(and-gate a b c)
(inverter c e)
(and-gate d e s)

As this is general function box, it would be more appropriate to abstract this
as box:

(define (half-adder a b s c)
  (let ((d (make-wire)) (e (make-wire)))
    (or-gate a b d)
    (and-gate a b c)
    (inverter c e)
    (and-gate d e s)
    ))

Using this function box, we can construct more useful, complex function box:

(define (full-adder a b c-in sum c-out)
  (let ((s (make-wire))
	(c1 (make-wire))
	(c2 (make-wire)))
    (half-adder b c-in s c1)
    (half-adder a s sum c2)
    (or-gate c1 c2 c-out)
    'ok))

Primitive function boxes

The primitive function boxes works as force the wire get its signal changed. So
wire should provides appropriate operations for that:

(get-signal <wire>)
returns the current value of the signal on wire.
(set-signal <wire> <new value>)
changes the value of the signal on the wire to the new value.
(add-action! <wire> <procedure of no arguments>)
asserts that the designated procedure should be run whenever the signal on the
wire changes value. Such procedures are the vehicles by which changes in the
signal value on the wire are communicated to other wires.

Note that the first two operations should be familiar with us – selector and
mutator; but the last one is specific for the event-driven programming. By
this effect, the "force" propagates along with the wires.

In addition, to reflect the delay of logical function boxes, we need to make use
of a procedure after-delay that takes a time delay and a procedure to be run
and executes the given procedure after the given delay.

As we gathered all the components we need, let's define the primitive function
boxes:

inverter

(define (inverter input output)
  (define (invert-input)
    (let ((new-value (logical-not (get-signal input))))
      (after-delay inverter-delay
		   (lambda ()
		     (set-signal! output new-value)))))
  (add-action! input invert-input)
  'ok)

(define (logical-not s)
  (cond ((= s 0) 1)
	((= s 1) 0)
	(else (error "Invalid signal" s))))

Note that whenever the input signal changes invert-input executed by the
add-action!

and-gate

(define (and-gate a1 a2 output)
  (define (and-action-procedure)
    (let ((new-value
	   (logical-and (get-signal a1) (get-signal a2))))
      (after-delay and-gate-delay
		   (lambda ()
		     (set-signal! output new-value)))))
  (add-action! a1 and-action-procedure)
  (add-action! a2 and-action-procedure)
  'ok)
(define (logical-and s1 s2)
  (cond ((and (= s1 0) (= s2 0)) 0)
	((and (= s1 0) (= s2 1)) 0)
	((and (= s1 1) (= s2 0)) 0)
	((and (= s1 1) (= s2 1)) 1)
	(else (error "Invalid signals" (cons s1 s2)))))

or-gate

(define (or-gate a1 a2 output)
  (define (or-action-procedure)
    (let ((new-value
	   (logical-or (get-signal a1) (get-signal a2))))
      (after-delay or-gate-delay
		   (lambda ()
		     (set-signal! output new-value)))))
  (add-action! a1 or-action-procedure)
  (add-action! a2 or-action-procedure)
  'ok)
(define (logical-or s1 s2)
  (cond ((and (= s1 0) (= s2 0)) 0)
	((and (= s1 0) (= s2 1)) 1)
	((and (= s1 1) (= s2 0)) 1)
	((and (= s1 1) (= s2 1)) 1)
	(else (error "Invalid signals" (cons s1 s2)))))

Exercise 3.28

See the above or-gate part.

Exercise 3.29

We can use either De Morgan's law or truth table to deduce following logic:

(define (or-gate2 a1 a2 output)
  (let ((not-a1 (make-wire))
	(not-a2 (make-wire))
	(not-or (make-wire)))
    (inverter a1 not-a1)
    (inverter a2 not-a2)
    (and-gate not-a1 not-a2 not-or)
    (inverter not-or output)
    'ok))

or-gate-delay becomes 2 inverter-delay + and-gate-delay.

Exercise 3.30

Using induction on n, we can construct ripple-carry-adder. More
specifically, to connect each full-adder boxes, we should hand over the carry
wire to next full-adder box:
```
(define (ripple-carry-adder aAs aBs aSs C)
  (define (connect-and-return-carry Ak Bk Ck Sk)
    (let ((C_k-1 (make-wire)))
      (full-adder Ak Bk Ck Sk C_k-1)
      C_k-1))
  (define (connect-recursive As Bs Ss)
    (cond ((and (null? As) (null? Bs) (null? Ss))
	   (make-wire))                          ;C_n
	  ((or (null? As) (null? Bs) (null? Ss)) ;defensive programming
	   (error
	    "arguments do not agree in the number of elements --RIPPLE-CARRY-ADDER"
	    (list aAs aBs aSs)))
	  (else
	   (connect-and-return-carry
	    (car As) (car Bs)
	    (connect-recursive (cdr As) (cdr Bs) (cdr Ss))
	    (car Ss)))))
  (cond ((or (null? aAs) (null? aBs) (null? aSs))
	 (error "RIPPLE-CARRAY-ADDER cannot do connect with given arguemens"
		(list aAs aBs aSs)))
	(else (full-adder (car aAs)
			  (car aBs)
			  (connect-recursive ;C_1
			   (cdr aAs)
			   (cdr aBs)
			   (cdr aSs))
			  (car aSs)
			  C)
	      'ok)))
```
To estimate the whole delay of ripple carry adder, we exploit abstraction over
the delays of other simpler function boxes that constitute ripple carry adder.
Observe that the delay from C_k to C_k-1 accumulated; it would be the
bottle neck of propagation of signal in this function box. So we can conclude
that the whole delay of ripple carry adder would be approximately n ×
each of the delay that going to be accumulated.

In turns, to estimate the each delay of that part of full-adder, we need to do the same
process as above or we could "bottom up" approach to it; calculate from the
very lower level of function boxes from which full-adder constructed:
- From half-adder, we have or-gate-delay + and-gate-delay or 2
  and-gate-delay + inverter-delay to propagate the
  signal from inputs to the s.
- From full-adder, we have 2 (or-gate-delay + and-gate-delay) or 3
  and-gate-delay + inverter-delay + or-gate-delay to propagate from c-in
  to c-out.
So, if we stick with or-gate and and-gate combination only, we got n
× 2 (or-gate-delay + and-gate-delay) as whole. We will verify this when
we implemented all the parts of our language.

Representing wires

By wishful thinking, we just used wires to connect the components of our
primitive boxes until now; this time, we need to represent wires according to
our use of that – the specifications deduced from our use.

Our wire should have signal as its state variable from the use of that; i.e.
(get-signal <wire>) and (set-signal! <wire> <new value>). Also it should
have some way to save all the actions it should executes when it change its
signal according to (add-action! <wire> <procedure of no arguments>); the
name's bang of usage implies wire should have "action list" as its state
variable.

Here, in text book, we implement wire using the message passing style:

(define (make-wire)
  (let ((signal-value 0) (action-procedures '()))
    (define (set-my-signal! new-value)
      (if (not (= signal-value new-value))
	  (begin (set! signal-value new-value)
		 (call-each action-procedures))
	  'done))
    (define (accept-action-procedure! proc)
      (set! action-procedures (cons proc action-procedures))
      (proc))
    (define (dispatch m)
      (cond ((eq? m 'get-signal) signal-value)
	    ((eq? m 'set-signal!) set-my-signal!)
	    ((eq? m 'add-action!) accept-action-procedure!)
	    (else (error "Unknown operation -- WIRE" m))))
    dispatch))

(define (call-each procedures)
  (if (null? procedures)
      'done
      (begin
	((car procedures))
	(call-each (cdr procedures)))))

Then set up the interface for procedure calling style:

(define (get-signal wire)
  (wire 'get-signal))
(define (set-signal! wire new-value)
  ((wire 'set-signal!) new-value))
(define (add-action! wire action-procedure)
  ((wire 'add-action!) action-procedure))

The agenda

Only the after-delay left to complete our language. We need some data
structure that contains the schedule of things to do. For that structure we make
data structure called agenda. Here is the interface of agenda:
- (make-agenda)
  returns a new empty agenda
- (empty-agenda? <agenda>)
  is true if the specified agenda is empty.
- (first-agenda-item <agenda>)
  returns the first item on the agenda.
- (remove-first-agenda-item! <agenda>)
  modifies the agenda by removing the first item.
- (add-to-agenda! <time> <action> <agenda>)
  modifies the agenda by adding the given action procedure to be run at the
  specified time.
- (current-time <agenda>)
  returns the current simulation time.
We also used the wishful thinking to construct this interface. The particular
agenda that we use along the simulation is denoted as the-agenda. Using this
structure we can implement after-delay procedure:
```
(define (after-delay delay action)
  (add-to-agenda! (+ delay (current-time the-agenda))
		  action
		  the-agenda))
```
With this data structure, we are ready to implement the initiation of simulator:
```
(define (propagate)
  (if (empty-agenda? the-agenda)
      'done
      (let ((first-item (first-agenda-item the-agenda)))
	(first-item)
	(remove-first-agenda-item! the-agenda)
	(propagate))))
```

A sample simulation

Cool! Since we can start the simulation, and we got the all the components of
simulation, we are done only if we represent the agenda data structure? No! We
can't inspect the simulation: We only can inspect whether the simulation done by
propagate. To cope with this, we implement probe procedure that print out
all the events at given wire:

(define (probe name wire)
  (add-action! wire
	       (lambda ()
		 (newline)
		 (display name)
		 (display " ")
		 (display (current-time the-agenda))
		 (display "  New-value = ")
		 (display (get-signal wire)))))

We exploited the underlying operation for wire.

We are really ready to start the simulation. Here is the sample simulation:

;;; setup
(define the-agenda (make-agenda))
(define inverter-delay 2)
(define and-gate-delay 3)
(define or-gate-delay 5)
(define input-1 (make-wire))
(define input-2 (make-wire))
(define sum (make-wire))
(define carry (make-wire))
(probe 'sum sum)
(probe 'carry carry)

;;; set situation and start
(half-adder input-1 input-2 sum carry)
(set-signal! input-1 1)
(propagate)

;;; second situation and start
(set-signal! input-2 1)
(propagate)

Exercise 3.31

We can analyze this problem in two different ways (but not mutually
independent):
- Focus the mapping between real world situation, from which we modeled, with
  our resulting model.
- Experiment with the alternative and see what happen then evaluate its result
  (actually to estimate the result, we would use the first way).
Let we start with the latter method and then evaluate that with the first
method. As we did not complete our simulation language, we should simulate with
their definitions; in other word, we should evaluate each statement as if we
become a interpreter.

With the normal definition of accept-action-procedure!, already the result of
simulation texted in text book; so here we need only to simulate with the
following definition on our own:
```
*** in make-wire
(define (accept-action-procedure! proc)
  (set! action-procedures (cons proc action-procedures)))
```
Let's run our interpreter:
1. evaluate (half-adder input-1 input-2 sum carry); at this point
  (empty-agenda? the-agenda) returns true as we don't run the action since
  the input signals doesn't changed at all.
2. evaluate (set-signal! input-1 1); as referencing the half-adder diagram,
  the agenda should contains the schedule that looks like
```
(
 (3 (lambda ()
      (set-signal!
       carry
       (logical-and
	(get-signal input-1) (get-signal input-2)))))
 (5 (lambda ()
      (set-signal!
       d
       (logical-or (get-signal input-1) (get-signal input-2)))))
 )
```
  The first item of each element represent the scheduled time and the next is
  the action to be executed at that time.
  
  Here I've used the substitution model for evaluation; but it is not strictly
  correct – the value of evaluating logical-and or logical-or should be
  captured when the connection being made for instance.
3. evaluate (propagate);
```
(set-signal!
 carry
 (logical-and
  (get-signal input-1) (get-signal input-2)))
```
  evaluated to
```
(set-signal! carry 0)
```
  which cause no change at all.
  
  Next evaluate
```
(lambda ()
      (set-signal!
       d
       (logical-or (get-signal input-1) (get-signal input-2))))
```
  to
```
(set-signal! d 1)
```
  ; as d changed its signal, it causes further events:
```
(
 (8 (lambda ()
      (set-signal!
       sum
       (logical-and
	(get-signal d) (get-signal e)))))
 )
```
  As
```
(set-signal! sum 0)
```
  doesn't change the signal of sum, it finalize the simulation: 'done.
The evaluation of this simulation is different from previous: sum and carry
doesn't change its signal at all.

Now we evaluate the result of our simulation using the criterion of first
method:
Our real world situation indicates the previous one is correct: the modified one
is different from what "really" happens.

Let we conclude with the first method, in this time, it is irrelevant with the
second method. We observe in real world that as soon as we connect each
components of digital circuits, the signals of wires, which connect each
component, affected by its action – connecting. Therefore, the initialization
in the accept-action-procedure! is necessary when we really want to model that
situation.

Implementing the agenda

The agenda is made up of time segments; to reflect this structure, we provide
the backbone of agenda from which agenda constructed up:

(define (make-time-segment time queue)
  (cons time queue))
(define (seqment-time s) (car s))
(define (segment-queue s) (cdr s))

It doesn't do any special things except it indicates our strategy that we going
to use queue for accumulating action procedures to be executed at that time. In
fact, this is due to limitation of our programming language, as it does not
allow us to use concurrent process, we need to mimic the situation all the
procedures executed at once in our sequential language – using queue.

As we noted before, the agenda itself is a one-dimensional table of time
segments. It is ordered by increasing time, it has current time as its head:

;; constructor
(define (make-agenda) (list 0))
;; selector -- time
(define (current-time agenda) (car agneda))
;; mutator -- time
(define (set-current-time! agenda time)
  (set-car! agenda time))
;; selector -- segments
(define (segments agenda) (cdr agenda))
;; mutator -- segments
(define (set-segments! agenda segments)
  (set-cdr! agenda segments))
;; selector -- operating on segments
(define (first-segment agenda) (car (segments agenda)))
;; selector -- operating on segments
(define (rest-segments agenda) (cdr (segments agenda)))

;; predicate agenda
(define (empty-agenda? agenda)
  (null? (segments agenda)))

To add a new action to agenda, we choose to mutate our agenda structure. It
make us confront with some tricky situation, which would not occur in functional
programming. We need to maintain the structure to preserve its identity after
mutating the structure – as we did in table implementation. So we need to
follow somewhat more tricky algorithm specified in text book:

(define (add-to-agenda! time action agenda)
  (define (belongs-before? segments)
    (or (null? segments)
	(< time (segment-time (car segments)))))
  (define (make-new-time-segment time action)
    (let ((q (make-queue)))
      (insert-queue! q action)
      (make-new-time-segment time q)))
  (define (add-to-segments! segments)
    (if (= (segment-time (car segments)) time)
	(insert-queue! (segment-queue (car segments))
		       action)
	(let ((rest (cdr segments)))
	  (if (belongs-before? rest)
	      (set-cdr!
	       segments
	       (cons (make-new-time-segment time action)
		     rest))
	      (add-to-segments! rest)))))
  (let ((segments (segments agenda)))   ;handle the entry point
    (if (belongs-before? segments)
	(set-segments!
	 agenda
	 (cons (make-new-tiem-segment time action)
	       segments))
	(add-to-segments! segments))))

The remover:

(define (remove-first-agenda-item! agenda)
  (let ((q (segment-queue (first-segment agenda))))
    (delete-queue! q)
    (if (empty-queue? q)
	(set-segments! agenda (rest-segments agenda)))))

Finally the access to the agenda from the higher level user:

(define (first-agenda-item agenda)
  (if (empty-agenda? agenda)
      (error "Agenda is empty -- FIRST-AGENDA-ITEM")
      (let ((first-seg (first-segment agenda)))
	(set-current-time! agenda (segment-time first-seg)) ;first item access renew the time
	(front-queue (segment-queue first-seg))))) ;from the contract, queue is not empty

Then let's test with previous exercise, Exercise 3.31:

(half-adder input-1 input-2 sum carry)

;Value: ok

(set-signal! input-1 1)

;Value: done

(propagate)

;Value: done

(set-signal! input-2 1)

;Value: done

(propagate)

carry 11  New-value = 1
;Value: done

It is exactly what we expected.

Exercise 3.32

We reason as follows:
1. By the observation of previous exercise, each action stored in one wire
  executed when the signal of that wire has changed.
2. As queue is FIFO, even if it is same time at which the actions to be
  executed, it is important which one has added to agenda.
3. There are two possibilities in this particular situation:
  - 0,1 → 1,1 → 1,0 – abbreviated form of that first transit from 0,1 to
    1,1 (the first argument change its signal) and then transit from 1,1 to 1,0
    (the second argument change its signal).
  - 0,1 → 0,0 → 1,0
4. Case 1: output → 1 → 0 – output of and-gate transit from its initial
  signal (0) to 1 and then 0 at the same time point.
  Case 2: output is unchanged.
5. Case 1 would cause further event propagation; Case 2 would not. But with the
  current primitive function boxes, after done with propagation, we can't
  notice the difference between Case 1 from Case 2.
6. Now let we assume list structure not queue: LIFO; with the same reasoning as
  with queue, the order of action is important also.
7. Case 1 would be stacked as (1,1 → 1,0) (0,1 → 1,1) as and-gate-action
  capture the signals of wires when it called not the execution time of that action.
8. That cause output → unchanged → 1
9. Whereas, Case 2 stacked as follows: (0,0 → 1,0) (0,1 → 0,0), which cause
  the output unchanged at all.
10. Conclusion: If we use list instead of queue, new the order in which actions
  to be executed start to get mattered; also in the view point of modeling, it
  doesn't reflect well what behavior the real world takes.

Lecture 5B: Computational Objects

In this lecture, we are going to learn how we use computational object – the
object of message passing paradigm – to model the real world object; that is,
mapping the objects from the real world to our computational world as well as
all the relations between the objects. In lecture, it brings digital circuit
simulation as example of instantiation of outlined scheme.

The steps of the conversion, from model of real world to our computational
model, can be summarized as follows:

Capture the behavior of real world object that we want to map to our minds.
It requires more subtle steps for itself; the main concept of that steps is
to abstract the behavior as formally as possible.

In the digital circuit example, the primitive function boxes would be that –
inverter, and-gate, or-gate in addition to wire.
Then formalize captured behavior using the state and mutation languages (more
specifically using the wishful thinking!).

In the example of lecture, each the cloudy wire object has to have signal
"state" with action procedures list "state" which stores things to inform
when it has changed its own signal value.
Turn the language of state and mutation to the language of environment model.
Environment model can deal with the evaluation involving mutation and
assignment as well as the other expressions, we can safely map all the stuff
of the wishful thinking involving computational object as instantiation of
environment model.

In the example of digital circuit, wire is the environment which possess
signal and action procedures as variable in its first frame; the references
between the objects resolved as bindings in frame.
Convert the environment model to code which produce such environments. We
have learned the instance of environment model that given code produces; if
we approach backwards, we can get what we want as there is one to one mapping
between the environment diagram and that code.

In the example of the digital circuit, there are more than what we outlined
here: as we are going to code digital circuit "simulation", we need to code
the fragments to achieve simulation feature such as delay of propagation and
so on. The agenda data structure is one of the auxiliary parts we mentioned
above.

For the latter part of the example, it involves another key concept: Designing
ADT – in lecture, the agenda structure. To design and implement ADT,

By wishful thinking, come up with behaviors that we want to have.
Formalize the captured behavior as ADT.
Modeling that behavior using our environment model (or box and pointer
diagram if it can be done that way).
Convert that into code as there is direct mapping between code and model as
we specified above.

The only difference between this and above modeling of real world object is
that for designing ADT, there is no need to exist in the real world what we want
to capture; if we can imagine what we want, we can capture that in computational
object.

Propagation of Conlstraints

Here we implement the constraint-based programming – non-directional
computations. There are some mechanisms works in this way in the real world –
mechanics of material and so on. This constraint-based programming also known as
logical programming combined with pattern matching. In that paradigm, all the
constraints works as fact. Using such facts, deduce unknown things if
appropriate amounts of fact provided.

To implement such programming style, we apply what we learned in Lecture 5B: Computational Objects:

Capture the behavior of real world scheme.

We could start this using the mechanical example we described; but to begin, the
simpler example we use, the easier to capture the common behavior of those
scheme, which leads capturing the abstracted concept of those behavior.

So here, we use the conversion of temperature between of Fahrenheit and of
Celsius. The relationship can be formalize as
[9C = 5(F - 32)]
Then we have to capture that as frame of components of ADT or a programming language.

Here as we develop the programming style, we need to fit our
components into
- primitive elements:
  As we develop constraint-based programming our primitive elements would be
  primitive constraints – primitive adder, multiplier, and constant
  constraint
- means of combination:
  Analogous to the digital circuit simulation, we combine constraints
  connecting by connectors. Connectors work similarly with wires.
- means of abstraction:
  As we embedding this language into Scheme, it inherit the abstraction means
  of Scheme, namely lambda expression with the define.
Here we denote the result of connecting several constraints as network. As
example, the network of the conversion of temperatures given as Figure 3.28. To
deduce the cloudy objects in our computational world in terms of state and
references, we need to extract more information from the informal behavior of
simple examples. Let we inspect the above figure a little more specifically. The
conversion constraint network consists of primitive adder, multiplier, and
constant constraints. For that, please see the relevant discussion in the text
book.

The important concept is not the description of the behavior but how they
deduced that description. Our task is to trace back that process to apply our
own application in later. They nicely captured the common behavior of two
examples – mechanic law of material and conversion of temperatures – into
networks of primitive elements – constant, multiplier, and adder boxes. Then
as they simulation in their mind, they filled the details of the
requirement. All of these made by wishful thinking: They believe that the
real world system, such as mechanical system, can be mapped into our
computational world even though we only know rough behavior of real world
behavior.

With all the specification in the text book, we can deduce the cloudy objects
as connector should have state variable that holds the value of connector and
gconstraint list of all constraints to which the connector linked; in
addition, it should have informant as its state variable to achieve the
requirement. For the primitive constraint boxes, it should have references to
terminals to poll and set; it should possess identity to signature informant
part of the connector. It forms the cloudy objects.
To deduce the concrete environment diagram,

here we use test usages to make things more concretely.

So far, we developed the skeletons of our language, here we will develop more
concrete contents by specifying how we want to use the constraint system. The
temperature constraint network converted to
```
(define C (make-connector))
(define F (make-connector))
(celsius-fahrenheiit-converter C F)
```
The real works defined as
```
(define (celsius-farenheit-converter c f)
  (let ((u (make-connector))
	(v (make-connector))
	(w (make-connector))
	(x (make-connector))
	(y (make-connector)))
    (multiplier c w u)
    (multiplier v x u)
    (adder v y f)
    (constant 9 w)
    (constant 5 x)
    (constant 32 y)
    'ok))
```
As we did in digital circuit simulation, to see what is going on, we probe on
the connector that we want to know the value when it changed. It should work
as follows
```
(probe "Celsius temp" C)
(probe "Fahrenheit temp" F)

(set-value! C 25 'user)
Probe : Celsius temp = 25
Probe : Fahrenheit temp = 77
done
```
If we try to set F to a new value, say 212 it should behave as
```
(set-value! F 212 'user)
Error! Contradiction (77 212)
```
That is, the connector complains that it has sensed a contradiction: Its
value is 77, and someone is trying to set it to 212. If we really want to
reuse the network with new values, we should tell C to forget its old value
before setting to new value:
```
(forget-value! C 'user)
Probe: Celsius temp = ?
Probe: Fahrenheit temp = ?
done
```
C finds that the user, who set its value originally, is now retracting
that value, so C agrees to lose its value, as shown by the probe, and
informs the rest of the network of this fact. This information eventually
propagates to F, which now finds that it has no reason for continuing to
believe that its own value is 77. Thus, F also gives up its value, as shown
by the probe.

Now that F has no value, we can safely set it to 212:
```
(set-value! F 212 'user)
Probe: Fahrenheit temp = 212
Probe: Celsius temp = 100
done
```
Unfortunately, what we deduced from the lecture 5B was wrong!

You should notice something wrong is happening around the previous section or
process. What we tried to deduce is not just the environment diagram.
Environment diagram is not dynamic – it is static as its nature; but what we
tried to capture is dynamic thing – it evolves as time passes.

We can only convert the general pattern of the moment of object not the whole
behavior of particular object, that is the evolution of process, as we capture
the computation pattern using the substitution model.

To design the behavior of objects we need to consult our old method, wishful
thinking in terms of ADT or the core features that a powerful language should
have with the method of designing algorithm.

In fact it is not the unfortunate thing, as we have practiced enough to design
our own ADT (and algorithm) again and again so far. The only difference is that
now we have to consider the moment of evolution and capture that moment using
environment model; in the substitution model, we does not considered the moment
of evolution as there is no time in it. To summarize our abstract process of
designing what we want is unchanged but the tools have changed.
Implementing the constraint system

So far, we converted the behavior of sample objects into that of our
computational world. Now we turn our topic into implementing the primitive
constraints using the ADT of connector by wishful thinking as we did again and
again, that is we haven't got the resulting code of connector, that is, we
just "assume" we have one.

Here is the specifications for the operations on connectors:
- (has-value? <connector>)
  tells whether the connector has a value.
- (get-value <connector>)
  returns the connector's current value.
- (set-value! <connector> <new-value> <informant>)
  indicates that the informant is requesting the connector to set its value to
  the new value.
- (forget-value! <connector> <retractor>)
  tells the connector that the retractor is requesting it to forget its value.
- (connect <connector> <new-constraint>)
  tells the connector to participate in the new constraint.
The connectors communicate with the constraints by means of the procedures
inform-about-value, which tells the given constraint that the connector has a
value, and inform-about-no-value, which tells the constraint that the
connector has lost its value.

Note that by using the wishful thinking we could break down the massive
structure into smaller ones as we did in the Exercise 2.92. From this process,
we can learn how to expand our previous designing skill embracing mutation. The
only difference is that in previous we used to substitution model in conversion
from common computation to code, here we use environment model to convert the
picture of object at some moment to code.

Back to our discourse, adder constructs an adder constraint among summand
connectors a1 and a2 and a sum connector. To implement this object, we
think each part composing the whole object separately:
- To capture the state mutation, and references relations using the environment model,
- to capture the evolutions using procedure as we did before in the functional programming.
The behavior of our newly defined primitive constraints are similar of the
primitive function boxes of digital circuit but this constraint has to have
identity. That means it should be the procedure with the local state – object
in message passing style.

Using those observations we can produce code that do the right things:
```
(define (adder a1 a2 sum)
  (define (process-new-value)
    (cond ((and (has-value? a1) (has-value? a2))
	   (set-value! sum
		       (+ (get-value a1) (get-value a2))
		       me))
	  ((and (has-value? a1) (has-value? sum))
	   (set-value! a2
		       (- (get-value sum) (get-value a1))
		       me))
	  ((and (has-value? a2) (has-value? sum))
	   (set-value! a1
		       (- (get-value sum) (get-value a2))
		       me))))
  (define (process-forget-value)
    (forget-value! sum me)
    (forget-value! a1 me)
    (forget-value! a2 me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
	   (process-new-value))
	  ((eq? request 'I-lost-my-value)
	   (process-forget-value))
	  (else
	   (error "Unknown request -- ADDER" request))))
  (connect a1 me)
  (connect a2 me)
  (connect sum me)
  me)
```
The following "syntax interfaces" are used in conjunction with the dispatch:
```
(define (inform-about-value constraint)
  (constraint 'I-have-a-value))
(define (inform-about-no-value constraint)
  (constraint 'I-lost-my-value))
```
The adder's local procedure processs-new-value is called when the adder is
informed that one of its connectors has a value. It evolves as what the behavior
does. The only non-trivial process is the process-forget-value it works if the
adder is told that one of its connectors has lost a value, it requests that all
of its connectors now lose their value as desired but now it runs
process-new-value. In adder, we could not grasp the essence why it needs to
be done like that but it becomes somewhat more apparently when we consider the
multiplier constraint:
```
(define (multiplier m1 m2 product)
  (define (process-new-value)
    (cond ((or (and (has-value? m1) (= (get-value m1) 0))
	       (and (has-value? m2) (= (get-value m2) 0)))
	   (set-value! product 0 me))
	  ((and (has-value? m1) (has-value? m2))
	   (set-value! product
		       (* (get-value m1) (get-value m2))
		       me))
	  ((and (has-value? product) (has-value? m1))
	   (set-value m2
		      (/ (get-value product) (get-value m1))
		      me))
	  ((and (has-value? product) (has-value? m2))
	   (set-value m1
		      (/ (get-value product) (get-value m2))
		      me))))
  (define (process-forget-value)
    (forget-value! product me)
    (forget-value! m1 me)
    (forget-value! m2 me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
	   (process-new-value))
	  ((eq? request 'I-lost-my-value)
	   (process-forget-value))
	  (else
	   (error "Unknown request -- MULTIPLIER" request))))
  (connect m1 me)
  (connect m2 me)
  (connect product me)
  me)
```
Think about the situation where m1 equals to 0 and also m2 equals to 0
changed to m2 got changed its value to not 0; sum still have to hold 0 as
one of the multiplicand is 0. This is why we need to run process-new-value at
the end of process-forget-value. So, for the adder case, we think this
additional complexity is for consistency through whole system.

For the other primitives, please refer the contents of text book.

Representing connector

As we outlined above, connector is represented in our computational world as a
procedural object with local state variables value, the current value of the
connector; informant, the object that set the connector's value; and
constraints, a list of the constraints in which the connector participates.

(define (make-connector)
  (let ((value false) (informant false) (constraints '()))
    (define (set-my-value newval setter)
      (cond ((not (has-value? me))
	     (set! value newval)
	     (set! informant setter)
	     (for-each-except setter
			      inform-about-value
			      constraints))
	    ((not (= value newval))
	     (error "Contradiction" (list value newval)))
	    (else 'ignored)))
    (define (forget-my-value retractor)
      (if (eq? retractor informant)
	  (begin (set! informant false)
		 (for-each-except retractor
				  inform-about-no-value
				  constraints))
	  'ignored))
    (define (connect new-constraint)
      (if (not (memq new-constraint constraints))
	  (set! constraints
	    (cons new-constraint constraints)))
      (if (has-value? me)
	  (inform-about-value new-constraint))
      'done)
    (define (me request)
      (case request
	((has-value?) (if informant true false))
	((value) value)
	((set-value!) set-my-value)
	((forget) forget-my-value)
	((connect) connect)
	(else (error "Unknown operation -- CONNECTOR"
		     request))))
    me))

(define (for-each-except exception procedure list)
  (let loop ((items list))
    (cond ((null? items)
	   'done)
	  ((eq? (car items) exception) (loop (cdr items)))
	  (else (procedure (car items))
		(loop (cdr items))))))

Then syntax interfaces:

(define (has-value? connector)
  (connector 'has-value?))
(define (get-value connector)
  (connector 'value))
(define (set-value! connector new-value informant)
  ((connector 'set-value!) new-value informant))
(define (connect connector new-constraint)
  ((connector 'connect) new-constraint))

Exercise 3.33

We can easily implement requested that is analogous to temperature conversion
system:

(define (averager a b c)
  (let ((x (make-connector))
	(y (make-connector)))
    (adder a b x)
    (multiplier c y x)
    (constant 2 y)
    'ok))

Test:

(define a (make-connector))

;Value: a

(define b (make-connector))

;Value: b

(define c (make-connector))

;Value: c

(averager a b c)

;Value: ok

(probe 'average c)

;Value: #[compound-procedure 43 me]

(set-value! a 2 'user)

;Value: done

(set-value! b 3 'user)

Probe: average = 5/2
;Value: done

Exercise 3.34

We want to implement the squarer which is the constraint version of square
procedure. Louis Reasoner builds this constraint using the multipliter:

(define (squarer a b)
  (multiplier a a b))

Unfortunately, it does not work as desired: It only works from a to b not the
other way around:

(define a (make-connector))

;Value: a

(define b (make-connector))

;Value: b

(probe 'a a)

;Value: #[compound-procedure 42 me]

(probe 'b b)

;Value: #[compound-procedure 43 me]

(squarer a b)

;Value: #[compound-procedure 44 me]

(set-value! a 4 'user)

Probe: b = 16
Probe: a = 4
;Value: done

(forget-value! a 'user)

Probe: b = ?
Probe: a = ?
;Value: done

(set-value! b 16 'user)

Probe: b = 16
;Value: done

Exercise 3.35

(define (squarer a b)
  (define (process-new-value)
    (cond ((has-value? b)
	   (if (< (get-value b) 0)
	       (error "sqaure less than 0 -- SQUARER" (get-value b))
	       (set-value! a (sqrt b) me)))
	  ((has-value? a)
	   (set-value! b (square a) me))))
  (define (process-forget-value)
    (forget-value! a me)
    (forget-value! b me)
    (process-new-value))
  (define (me request)
    (case request
      ((I-have-a-value) (process-new-value))
      ((I-lost-my-value) (process-forget-value))
      (else
       (error "Unknown request -- SQUARER" request))))
  (connect a me)
  (connect b me)
  me)

Test:

(define a (make-connector))

;Value: a

(define b (make-connector))

;Value: b

(probe 'a a)

;Value: #[compound-procedure 39 me]

(probe 'b b)

;Value: #[compound-procedure 40 me]

(squarer a b)

;Value: #[compound-procedure 41 me]

(set-value! a 4 'user)

Probe: b = 16
Probe: a = 4
;Value: done

(forget-value! a 'user)

Probe: b = ?
Probe: a = ?
;Value: done

(set-value! b 4 'user)

Probe: a = 2
Probe: b = 4
;Value: done

Exercise 3.36

I've done this with my digital paper.

Exercise 3.37

Using the expression-oriented style of definition, we can rewrite the
celsius-fahrenheit-converter procedure as follows:

(define (celsius-fahrenheit-converter x)
  (c+ (c* (c/ (cv 9) (cv 5))
	  x)
      (cv 32)))
(define C (make-connector))
(define F (celsius-fahrenheit-converter C))

Here c+, c*, etc. are the "constraint" versions of the arithmetic
operations. For example, c+ takes two connectors as arguments and returns a
connector that is related to these by an adder constraint:

(define (c+ x y)
  (let ((z (make-connector)))
    (adder x y z)
    z))

Then, we can define c-, c*, c/, and cv (constant value) analogous to
c+:

(define (c- s x)
  (let ((y (make-connector)))
    (adder x y s)
    y))

(define (c* x y)
  (let ((z (make-connector)))
    (multiplier x y z)
    z))

(define (c/ z x)
  (let ((y (make-connector)))
    (multiplier x y z)
    y))

(define (cv num)
  (let ((x (make-connector)))
    (constant num x)
    x))

Test:

(define (celsius-fahrenheit-converter x)
  (c+ (c* (c/ (cv 9) (cv 5))
	  x)
      (cv 32)))
(define C (make-connector))
(define F (celsius-fahrenheit-converter C))

(set-value! f 212 'user)

;Value: done

(probe 'f f)

Probe: f = 212
;Value: #[compound-procedure 42 me]

(probe 'c c)

Probe: c = 100
;Value: #[compound-procedure 43 me]

Concurrency: Time Is of the Essence

The Nature of Time in Concurrent Systems

Exercise 3.38 ** a.

Note that as Peter → Paul results in same as Paul → Peter, There are only
four of cases that differs each other:
- M → P → P – $40;
- Peter → M → Paul – $35;
- Paul → M → Peter – $50;
- P → P → M – $45;
Here we abbreviated Marry as M, Peter or Paul as P when it doesn't matter
whether Peter or Paul.
- b.
  
  Note that the timing of the accessing the shared variable & mutating that only
  matters here. For simplicity (and for the discussion), we only consider the
  situation where mutation can not occur at the very same time – if we allow
  this, then the discussion would be bogged down to bit mutation level. Then our
  concurrent process can be grouped as
  - the three people accessing the same value (at the same timing) of the shared
    variable (the three people try to mutate the shared variable concurrently);
  - two of them accessing the same value (at the same timing) of the shared
    variable (two of them try to mutate concurrently);
  - each of them accessing the shared variable without interleaving with others
    (the a. cases).
  If we draw diagram relating these concurrent process, the first case of outlined
  above equivalent to only one person of them participate to the mutation, the
  second is two of them participate, and the last one participate all of them. As
  consequence the number of different situation here is 3 + 5 + 4 = 12. That is,
  - first case: - Peter: $110
    - Paul: $80
    - Marry: $50
  - second case: - P → P: $90
    - M → Peter: $60
    - M → Paul: $30
    - Paul → M: $40
    - Peter → M: $55
  - last case (a.): - M → P → P – ~~$40~~;
    - Peter → M → Paul – $35;
    - Paul → M → Peter – ~~$50~~;
    - P → P → M – $45;
  Here we stroke out the duplicated result; overall number of different result is 10.

Mechanisms for Controlling Concurrency

There are several strategy to control the concurrency. In the text book, they
implemented serializer, which works as station where issues permission to
operate. Then each of procedure who can mutate shared variable should be
registered by the same serializer to prevent the interleaving process. We can
implement this behavior following the steps of previous section.

There are several implementation details that we can choose for our own:

Serializer should have state variable that stores all the procedures that
registered to self? Actually the way of text book's have chosen reverse way –
the procedures have to reference the serializer to be controlled.
How the serializer permit specific procedure to run? We could have done this
using the massage-passing paradigm:

However it is not the way of the book's; they make the serializer
"busy-waiting". If we implement this asynchronous way, we can make our
serializing scheme more efficient. But, here we only consider what way the
book driving for the simplicity.
Exercise 3.39

Since s, now control only one of two execution, not the all of them, and the
controlled procedure never executed twice that are concurrently; thus the
serializer does not work in this situation – make no difference at all from the
previous unserialized version. Consequently remain all of the previous cases.
Exercise 3.40
```
(define x 10)
(parallel-execute (lambda () (set! x (* x x)))
		  (lambda () (set! x (* x x x))))
```
We can capture above situation abstractly:
- access x₁ → access x₂ → set x₃ to (* x₁ x₂); let we
  abbreviate this sequence of events as (x, y, z).
- access x¹ → access x² → access x³ → set x⁴ to (* x¹ x²
  x³); let we abbreviate this sequence of events as (a, b, c, d)
We used subscriptions or superscriptions to capture the times to access the
variable x. Then the resulting sequence of execution should be an sequence
that contains all of the elements of above sequences – x, y, z, a, b, c, d in
some order with constraints that elements of each sequence should be preserve
the relative order. And note that only mutation (assignment) make the context
different; that is, the number of cases that possibly produce different result
are the number of ways of organizing (0, 0, 0) with 1 plus (1, 1, 1, 1) with 0
minus 2 (duplicated cases among those – (1, 0) and (0, 1)) – 7 cases:
- (0, 0, 0, 1): 10⁶
- (0, 0, 1, 0): 10²
- (0, 1, 0, 0): 10⁴
- (1, 0, 0, 0): ~~10⁶~~
- (1, 1, 1, 0, 1): 10³
- (1, 1, 0, 1, 1): ~~10⁴~~
- (1, 0, 1, 1, 1): 10⁵
We represented the (x, y, z) sequence as (0, 0, 0) similarly (1, 1, 1, 1) for
(a, b, c, d); so the last element of each sequence represent the assignment
statement. Also in the combined sequences, we only noted one element of other
sequence such as (0, 0, 0, 1) – here 1 represent the assignment of latter
sequence. – as only assignment make context different.

If we use the serializer here, the only two case survives – (0, 1) and (1, 0)
both results to 10⁶.
Exercise 3.41

The Ben Bitdiddle's observation is not correct: As the balance method only
access to the shared state variable not mutating it, this method calling could
not make any different context (can not alter the environment) at all; recall
that the anomalous behavior we concerned here is the interleaving processes
which do access the shared variable and based on that, mutate that variable.
Exercise 3.42

To answer this question, we need to inspect the behavior of serializer more
formally. If we interpret the informal specification described in the text book
as only one of evaluation can be processed among the set of procedures
associated with that serializer, then the modification made by Ben Bitdiddle
results to the same behavior as previous one.

On the other hand, if it means only one of procedure, whose instance gets
permission from the serializer, allowed to be executed, then it results in the
instances (processes) of that procedure allowed to be processed concurrently.
That causes the chaos in the banking system cause it will allow interleaving
processes.

So it is good convention to define the banking account procedure as original one
since it does not depend on the interpretation of the specification, which is
the implementation details.
Exercise 3.43

As it is evaluated sequentially, all we need to show is that if before
sequential execution specific condition holds, then after which it still holds.
And this assertion can be proved as choose arbitrary one of the execution of
element of sequence; then prove if the a specific condition holds before that
execution, it still holds after that.

By setting the specific condition as the account balances should be $10, $20,
and $30 after the sequential execution, we got what we want.

This condition can be violated allowing the interleaving exchange. I've drawn
the figure describing this situation in the digital paper.

Now we try to prove even this situation, the total balance of accounts are
conserved. Basically, the structure of our proof is same as outlined above. We
decompose the goal into about the each exchange execution, and then into the
individual execution of withdraw or deposit. About the decomposed goal, we
have the lemma-like specification in the book, so if we formalize that
observation, we are done – completion of proof. To prove the final decomposed
goal, we need to incorporate the user – the caller of exchange – to interact
or possess the balance – difference.

For the last request, I've drawn diagram in the digital paper.
Exercise 3.44

As we noted in exercise 3.42, the anomalous behavior can be introduced only by
consequent access to value & mutating that variable. In the previous exchange
procedure, we accessed each account to calculate the difference of those
balances then mutated each account appropriately. That is, the anomaly involved each
account as shared variable. Whereas in our situation, we do not access the
values to mutate the account; in other word our mutation does not depend on the
shared variable. So our execution sequence does not satisfy the condition of
anomalous behavior.
Exercise 3.45

Ben Bitdiddle's introduces not halting process – due to the so called
"deadlock": Our serialized exchange process locks the serializer until it
terminates all of the statement of its body; however the withdrawal (or deposit)
process also require the permission of the same serializer otherwise it can not
proceed, which would be free after that withdrawal (or deposit) process
terminate. This situation end up with interlocked process, does not terminate at all.
Exercise 3.46

I've drawn required in my digital paper.

Exercise 3.47

a.

To implement the semaphore using the mutex, here we modify the definition of
mutex not to make the caller of acquire method of that to busy wait.

;; modifed mutex -- to fit in the semaphore
(define (make-mutex)
  (let ((cell (list false)))
    (define (the-mutex m)
      (case m
	((acquire) (test-and-set! cell))
	((release) (clear! cell))))
    the-mutex))
(define (clear! cell)
  (set-car! cell false))
(define (test-and-set! cell)
  (without-interrupts
   (lambda ()
     (if (car cell)
	 true
	 (begin (set-car! cell true)
		false)))))

Then the previous make-serializer can be implemented as

(define (make-serializer)
  (let ((mutex (make-mutex)))
    (lambda (p)
      (define (serialized-p . args)
	(if (mutex 'acquire)
	    (mutex 'acquire))           ;retry
	(let ((val (apply p args)))
	  (mutex 'release)
	  val))
      serialized-p)))

Armed with this modified mutex, we can implement semaphore:

(define (make-semaphore n)
  (define (make-mutex-chain n)
    (if (zero? n)
	'()
	(cons (make-mutex)
	      (make-mutex-chain (-1+ n)))))
  (let ((mutexes (make-cycle (make-mutex-chain n))))
    (define (the-semaphore request)
      (case request
	((acquire)
	 (let loop ((current-cycle mutexes))
	   (let ((mutex (car current-cycle)))
	     (if (mutex 'acquire)
		 (loop (cdr current-cycle))
		 mutex))))
	(else (error "Unknown request -- MAKE-SEMAPHORE" request))))
    the-semaphore))

Then the serializer with n concurrent procedure:

(define (make-semaphore n)
  (define (make-mutex-chain n)
    (if (zero? n)
	'()
	(cons (make-mutex)
	      (make-mutex-chain (-1+ n)))))
  (let ((mutexes (make-cycle (make-mutex-chain n))))
    (define (the-semaphore request)
      (case request
	((acquire)
	 (let loop ((current-cycle mutexes))
	   (let ((mutex (car current-cycle)))
	     (if (mutex 'acquire)
		 (loop (cdr current-cycle))
		 mutex))))
	(else (error "Unknown request -- MAKE-SEMAPHORE" request))))
    the-semaphore))

b.

With atomic test-and-set! it becomes more concise – the semaphore only need
to keep track the number of current concurrent procedures:

(define (make-semaphore2 n)
  (let ((cell (list 0)))
    (define (test-and-set!)
      (without-interrupts
       (lambda ()
	 (if (< (car cell) n)
	     (begin (set-car! cell (1+ (car cell)))
		    false)
	     true))))
    (define (clear!)
      (without-interrupts
       (lambda ()
	 (set-car! cell (-1+ (car cell))))))
    (define (the-semaphore request)
      (case request
	((acquire)
	 (test-and-set!))
	((release)
	 (clear!))
	(else
	 (error "Unknown reuqest -- MAKE-SEMAPHORE2" request))))
    the-semaphore))

(define (make-serializer-with2 n)
  (let ((the-semaphore (make-semaphore2 n)))
    (lambda (p)
      (define (serialized-p . args)
	(if (the-semaphore 'acquire)
	    (the-semaphore 'acquire))
	(let ((val (apply p args)))
	  (the-semaphore 'release)
	  val))
      serialized-p)))

Exercise 3.48

As noted in the text, deadlock occur in the situation where each process needs
to get permission of every permission from specified serializer set to execute,
but each permission doesn't have to be acquired in specific order. Thus several
process can get some number of permissions concurrently, which leads interlocked
processes.

The given deadlock-avoidance method constrain each process needs to get
permission in specific order; that means the interlocked situation can not occur
at all since to occur such situation, one should break the ordering constraint.

To implement this idea, first we need to modify make-account-and-serializer to
issue identification number to each account:

(define make-account-and-serializer
  (let ((id 0))
    (lambda (balance)
      (let ((id (begin (set! id (1+ id))
		       id)))
	(define (withdraw amount)
	  (if (>= balance amount)
	      (begin (set! balance (- balance amount))
		     balance)
	      "Insufficient funds"))
	(define (deposit amount)
	  (set! balance (+ balance amount))
	  balance)
	(let ((balance-serializer (make-serializer)))
	  (define (dispatch m)
	    (case m
	      ((withdraw) withdraw)
	      ((deposit) deposit)
	      ((balance) balance)
	      ((serializer) balance-serializer)
	      ((id) id)
	      (else (error "Unknown request -- MAKE-ACCOUNT" m))))
	  dispatch)))))

Then test the id feature:

(define a (make-account-and-serializer 100))
(define b (make-account-and-serializer 100))
(a 'id)
;Value: 1

(b 'id)
;Value: 2

(define (serialized-exchange account1 account2)
  (let ((id1 (account1 'id))
	(id2 (account2 'id))
	(serializer1 (account1 'serializer))
	(serializer2 (account2 'serializer)))
    (if (< id1 id2)
	((serializer1 (serializer2 exchange))
	 account1
	 account2)
	((serializer2 (serializer1 exchange))
	 account2
	 account1))))

Exercise 3.49

Such scenario should satisfy the selection of the other account depends on the
value of the shared resource of first account and also it should mutate the
depending resource in that process.

We can think of the joint account situation a bit screwed from what discussed in
the text book – jointing accounts results to making each account reference the
other account in their state variable. Then now think of the situation where we
want to exchange the account's balance of ones with the joint account's. It
cannot be avoided by outlined procedure in exercise 3.48.
Concurrency, time, and communication

Let we conclude this section quoting the last paragraph of the text's this
section:

The basic phenomenon here is that synchronizing different processes,
establishing shared state, or imposing an order on events requires communication
among the processes. In essence, any notion of time in concurrency control must
be intimately tied to communication. It is intriguing that a similar connection
between time and communication also arises in the Theory of Relativity, where
the speed of light (the fastest signal that can be used to synchronize events)
is a fundamental constant relating time and space. The complexities we encounter
in dealing with time and state in our computational models may in fact mirror a
fundamental complexity of the physical universe.

Streams

Here we approach the modeling of real world in different angle: We try to
capture time as sequence of instants; that is analogous to the physical
interpretation of world as 4 dimension – time axis with 3D space.

With this view point, we can use our sequence processing interface to process
the streams. In fact, this stream processing is powerful model which enables us
to deal the state without ever using assignment or mutable data.

On the other hand, the stream framework raises difficulties of its own, and the
question of which modeling technique leads to more modular and more easily
maintained systems remains open.

Streams Are Delayed Lists

Exercise 3.50

Use type contract:

;; (A,...,A -> B), List<Stream<A>> -> Stream<B>
(define (stream-map proc . argstreams)
  (if (empty-stream? (car argstreams))
      the-empty-stream
      (cons-stream
       (apply proc (map stream-car argstreams))
       (apply stream-map
	      (cons proc (map stream-cdr argstreams))))))

Exercise 3.51

It should

(define x (stream-map show (stream-enumerate-interval 0 10)))
;display 0
(stream-ref x 5)
;display 1, 2, 3, 4, 5
(stream-ref x 7)
;display 6, 7

And it did:

(define x (stream-map show (stream-enumerate-interval 0 10)))

0
;Value: x

(stream-ref x 5)

1
2
3
4
5
;Value: 5

(stream-ref x 7)

6
7
;Value: 7

Exercise 3.52

Mentally calculated:

(define seq (stream-map accum (stream-enumerate-interval 1 20)))
;sum = 1
(define y (stream-filter even? seq))
;sum = 6
(define z (stream-filter (lambda (x) (= (remainder x 5) 0))
			 seq))
;sum = 10
(stream-ref y 7)
;136
;sum = 136
(display-stream z)
;10, 15, 45, 55, 105, 120, 190, 210
;sum = 210

Actual response:

(stream-ref y 7)

;Value: 136

(display-stream z)

10
15
45
55
105
120
190
210
;Unspecified return value

For the latter question: Yes it'll produce different result, since it now the
duplicated evaluation aggregate the value of sum by the computation result of
that additional evaluation.

Infinite Streams

The important aspect of streams that differs from previous processes –
iterative, recursive – is that streams unfolds the specified process while the
others folding the given argument; that is, streams make more complex things as
it evolves, whereas the others simplifying those.

Observe that procedure dealing with streams usually capture the differential
equation as we'll learn from 6.01.

Exercise 3.53

This stream captures the differential equation given by

\begin{matrix} s[n] =& s[n-1] + s[n-1] =& 2s[n-1]\ s[0] =& 0 \end{matrix}

So, by solving the deduced equation, we got (s[n] = 2^{n}).

Exercise 3.54

The differential equation we want:

\begin{matrix} f[n] =& f[n-1] \times int[n + 1]\ f[0] =& 1 \end{matrix}

The converted code:

(define (mul-streams s1 s2)
  (stream-map * s1 s2))

(define factorials (cons-stream 1 (mul-streams (integers-starting-from 2)
					       factorials)))

Exercise 3.55

The differential equation we want:

\begin{matrix} f[n] =& f[n-1] + s[n]\ f[0] =& s[0] \end{matrix}

Then the code:

(define (partial-sums s)
  (define partials
    (cons-stream (stream-car s)
		 (add-streams (stream-cdr s) partials)))
  partials)

Then test:

(define test-partial-sums (partial-sums integers))

(display-stream test-partial-sums)

1
3
6
10
15
21
28
36
45
55
...

Exercise 3.56

We need to merge all of (scale-stream s 2), (scale-stream s 3),
(scale-stream s 5):

(define S (cons-stream 1
		       (merge (scale-stream s 2)
			      (merge (scale-stream s 3)
				     (scale-stream s 5)))))

Then test:

(stream-ref s 100)

;Value: 1600

s

;Value: {1 2 3 4 5 6 8 9 10 12 15 16 18 20 24 25 27 30 32 36 ...

Exercise 3.57

We answers to the questions in order:
1. The number of additions results to (n-2) since
  - base case: 3th fibs needs one addition.
  - inductive case: nth fibs needs # of additions of n-1th fibs + 1.
2. The number of the latter would be greater than 2^{n/2 - 1} since
  - [T(3) = 1]
  - [T(n) = T(n-1) + T(n-2) + 1]
  These equation can be deduced as it does not involve any assignment
  explicitly & implicitly; so the evaluation does not depends on context, that
  is to the result of (T(n-2)) after evaluating (T(n-1)) same as (T(n-2))
  before evaluating (T(n-1)).

Exercise 3.58

(define (expand num den radix)
  (cons-stream
   (quotient (* num radix) den)
   (expand (remainder (* num radix) den) den radix)))

It produce the sequence representing radix point number expansion of rational
number (\frac{num}{den}).

Tests:

(define 1over7 (expand 1 7 10))

;Value: |1over7|

1over7

;Value: {1 ...}

(stream-ref 1over7 10)

;Value: 5

1over7

;Value: {1 4 2 8 5 7 1 4 2 8 5 ...}

(define 3over8 (expand 3 8 10))

;Value: |3over8|

(stream-ref 3over8 10)

;Value: 0

3over8

;Value: {3 7 5 0 0 0 0 0 0 0 0 ...}

Exercise 3.59

a.

The code do the right things:

(define (integrate-series s)
  (stream-map (lambda (s i) (/ s i)) s integers))

And test:

(define test-integrate-series
  (integrate-series ones))
test-integrate-series

;Value: {1 1/2 1/3 1/4 1/5 1/6 1/7 1/8 1/9 1/10 1/11 ...}

b.

Here we using following observation:

(cons-stream (stream-car series), (integrate-series (deriv series))) = series

So, the answers can be implemented as

(define cosine-series
  (cons-stream 1 (integrate-series (stream-map - sine-series))))

(define sine-series
  (cons-stream 0 (integrate-series cosine-series)))

Exercise 3.60

Let S₂ be ({a_{0}, a_{1}, \ldots}) then (mul-series S1 S2) should equals
to (a_{0} S_{1} + x S_{1} \times {a_{1}, a_{2}, \ldots}).

From above observation, we can deduce

(mul-series s1 s2)
= (add-series (scale-stream s1 (stream-car s2))
				 (shift (mul-series s1 (stream-cdr s2))))
= (let ((a0s1 (scale-stream s1 (stream-car s2))))
    (cons-stream
     (stream-car a0s1)
     (add-series (stream-cdr a0s1)
		 (mul-series s1 (stream-cdr s2)))))

Then the result:

(define (mul-series s1 s2)
  (let ((a0s1 (scale-stream s1 (stream-car s2))))
    (cons-stream
     (stream-car a0s1)
     (add-series (stream-cdr a0s1)
		 (mul-series s1 (stream-cdr s2))))))

Then test:

;; test for sine, cosine series with mul-series
(define (square-series s)
  (mul-series s s))
(define test-trigonometric-stream
  (add-series (square-series sine-series)
	      (square-series cosine-series)))

test-trigonometric-stream

;Value: {1 0 0 0 0 0 ...}

Exercise 3.61

The straight forward implementation:

(define (invert-unit-series s)
  (define X (cons-stream
	     (stream-car s)
	     (mul-series
	      (stream-cdr s)
	      (stream-map - X))))
  X)

Then test:

(define test-invert-series
  (invert-unit-series test-integrate-series))
test-invert-series

;Value: {1 -1/2 -1/12 -1/24 -19/720 -3/160 -863/60480 -275/24192 -33953/3628800 -8183/1036800 -3250433/479001600 ...}

The problem is I don't know the result of the test case is right. Let this test
delegate to next exercise.

Exercise 3.62

Here we use following observation:

\begin{align*} &{n_{0}, n_{1}, \ldots} / {d_{0}, d_{1}, \ldots}\ =&\frac{{n_{0}, n_{1}, \ldots}/d_{0}}{{1, d_{1}/d_{0}, d_{2}/d_{0}, \ldots}} \end{align*}

It results into

(define (div-series ns ds)
  (let ((d0 (stream-car ds)))
    (cond ((zero? d0)
	   (error "Zero division -- DIV-SERIES" ds))
	  (else
	   (let ((ns/d0 (stream-map (lambda (n) (/ n d0)) ns))
		 (ds/d0 (stream-map (lambda (d) (/ d d0)) ds)))
	     (mul-series
	      ns/d0
	      (invert-unit-series ds/d0)))))))

Then test:

(define test-div-series
  (div-series sine-series sine-series))
;Zero division -- DIV-SERIES {0 1 0 -1/6 0 ...}
(define test-div-series
  (div-series cosine-series cosine-series))

test-div-series

;Value: {1 0 0 0 0 0 0 0 0 0 0 ...}

;; tangent-series
(define tangent-series
  (div-series sine-series cosine-series))

tangent-series

;Value: {0 1 0 1/3 0 2/15 0 17/315 0 62/2835 0 ...}

Exploiting the Stream Paradigm

Exercise 3.63

The modified version need to recalculate the subsequent call of (sqrt-stream x) within the body of sqrt-stream whereas the original one just refer the
precalculated result.

If we just use call-by-name not call-by-need, the two different version of these
procedure would hardly differ each other since both should recalculate recursive
call of expression.

I've deduced this result using environment diagram. You should also draw by
yourself.

Exercise 3.64

This procedure should involve conditional branch:

(define (stream-limit s tolerance)
  (let ((x (stream-car s))
	(y (stream-car (stream-cdr s))))
    (if (< (abs (- x y)) tolerance)
	y
	(stream-limit (stream-cdr s) tolerance))))

Exercise 3.65

It is analogous to pi-stream in text book:

(define (ln2-summands n)
  (cons-stream (/ 1.0 n)
	       (stream-map -
			   (ln2-summands (1+ n)))))

(define ln2-stream
  (accelerated-sequence
   euler-transform (partial-sums (ln2-summands 1))))

Then let's test it together with previous exercise:

(define ln2 (stream-limit ln2-stream 1e-8))

ln2

;Value: .6931471805604039

It seems reasonable.

Exercise 3.66

To answer the question, we need to formulate the mapping rule of pairs, that
is, the relation between the pair of index of s with t and that the index of
(pairs s t). That, in turns, involves the mapping rule of interleave.

Let we start with the easy one: The mapping rule of interleave. Let we denote
i as the i-th element of S₁ and similarly j for j-th element of
S₂. Then we deduce the relation between i or j and the index of that
element in the (interleave s1 s2) as

\begin{equation*} \left{ \begin{matrix} i \to& 2i - 1\ j \to& 2j \end{matrix} \right. \end{equation*}

Using this, we can construct the mapping rule of pairs:

\begin{equation*} f(x,y) = \left{ \begin{matrix} 1,1 &\to& 1\ 1,i+1 &\to& (2i - 1) + 1\ j+1, k+1 &\to& 2 f(j,k) +1 \end{matrix} \right. \end{equation*}

By solving this equation, we can deduce the closed form of that:

\begin{align*} f(n, n+m) &= 2^{n-1}f(1, 1 + m) + 2^{n-1} - 1\ &= 2^{n-1} (2m + 1) -1 \end{align*}

Consequently, we got the precise mathematical statements about the order mapping
rule of pairs. Using this, we can calculate the given test cases as

\begin{align*} f(1,100) &= 2^{0} (2\times 99 + 1) - 1\ &= 198\ f(99,100) &= 2^{98} (2\times 1 + 1) - 1\ &= 2^{98}\times 3 - 1\ f(100, 100) &= 2^{100} -1 \end{align*}

Let's verify above results:
```
(define test-order-of-pairs (pairs integers integers))

(stream-ref test-order-of-pairs (-1+ 198))

;Value: (1 100)

(stream-ref test-order-of-pairs (-1+ (-1+ (* 3 (expt 2 8)))))

;Value: (9 10)

(stream-ref test-order-of-pairs (-1+ (-1+ (expt 2 10))))

;Value: (10 10)
```
Here we replaced last two cases as (f(9, 10)) and (f(10, 10)) respectively
since, as we computed the order of given pair order, the input order number
turns out so enormous that we can not wait the calculation.

Exercise 3.67

It is analogous to pairs:

(define (all-pairs s t)
  (cons-stream
   (list (stream-car s) (stream-car t))
   (interleave
    (stream-map (lambda (x) (list (stream-car s) x))
		(stream-cdr t))
    (interleave
     (stream-map (lambda (x) (list x (stream-car t)))
		 (stream-cdr s))
     (all-pairs (stream-cdr s) (stream-cdr t))))))

Then test:

(define test-all-pairs (all-pairs integers integers))
test-all-pairs

;Value: {(1 1) (1 2) (2 1) (1 3) (2 2) (1 4) (3 1) (1 5) (2 3) (1 6) (4 1) (1 7) (3 2) (1 8) (5 1) (1 9) (2 4) (1 10) (6 1) (1 11) (3 3) ...}

Exercise 3.68

The implementation of Reasoner would fall into infinite loop since evaluating the
pairs, in turns, execute another pairs with different arguments but without
delay, which execute another pairs, and so on.

Why this version execute pairs successively whereas the original one didn't?
It is due to the evaluation order: Applicative order is default in Scheme.

Exercise 3.69

Let we simply the problem as we did in designing pairs; let we think integer
triples. If we could implement the integer triples generally enough then that
process automatically cope with the stream of triples of S, T, U.

Observe the all the elements after ((i,j)) of int-pairs satisfy that each part of
pair is greater than or equals to i. Using this observation we can implement
int-triples as follows

(define int-triples
  (define (make-int-triples integers int-pairs)
    (cons-stream
     (cons (stream-car integers) (stream-car int-pairs))
     (interleave
      (stream-map (lambda (x) (cons (stream-car integers) x))
		  (stream-cdr int-pairs))
      (make-int-triples (stream-cdr integers) (stream-cdr int-pairs)))))
  (make-int-triples integers int-pairs))

You should notice the similarity with pairs since I've used that structure
here. Given that we can generalize as

(define (triples s t u)
  (define pair-s (pairs t u))
  (cons-stream
   (cons (stream-car s) (stream-car pair-s))
   (interleave
    (stream-map (lambda (x) (cons (stream-car s) x))
		(stream-cdr pair-s))
    (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))

Then the final request can be achieved as

(define pythagorean-triples
  (stream-filter
   (lambda (t)
     (let ((squared-triple (map square t)))
       (= (+ (car squared-triple)
	     (cadr squared-triple))
	  (caddr squared-triple))))
   (triples integers integers integers)))

Then test:

(display-stream pythagorean-triples)

(3 4 5)
(6 8 10)
(5 12 13)
(9 12 15)
(8 15 17)
(12 16 20)

Exercise 3.70

Merge-weighted is like merge except the weight:

(define (merge-weighted weight s1 s2)
  (cond ((stream-null? s1) s2)
	((stream-null? s2) s1)
	(else
	 (let ((s1car (stream-car s1))
	       (s2car (stream-car s2)))
	   (let ((s1w (apply weight s1car))
		 (s2w (apply weight s2car)))
	     (cond ((< s1w s2w)
		    (cons-stream s1car (merge-weighted weight (stream-cdr s1) s2)))
		   (else
		    (cons-stream s2car (merge-weighted weight s1 (stream-cdr s2))))))))))

Then weighted-pairs is just pairs using different combiner:

(define (weighted-pairs weight s t)
  (cons-stream
   (list (stream-car s) (stream-car t))
   (merge-weighted
    weight
    (stream-map (lambda (x) (list (stream-car s) x))
		(stream-cdr t))
    (weighted-pairs weight (stream-cdr s) (stream-cdr t)))))

Then

a.

(define weighted-as-i+j
  (weighted-pairs + integers integers))

(display-stream weighted-as-i+j)

(1 1)
(1 2)
(2 2)
(1 3)
(2 3)
(1 4)
(3 3)
(2 4)
(1 5)
(3 4)
(2 5)
(1 6)
(4 4)
(3 5)
(2 6)
(1 7)

b.

(define weighted-filtered-2-3-5
  (let ((2-3-5-filtered-integers
	 (stream-filter
	  (lambda (i)
	    (not (or (divisible-by? 2 i)
		     (divisible-by? 3 i)
		     (divisible-by? 5 i))))
	  integers)))
    (weighted-pairs
     (lambda (i j)
       (+ (* 2 i)
	  (* 3 j)
	  (* 5 i j)))
     2-3-5-filtered-integers
     2-3-5-filtered-integers)))

(display-stream weighted-filtered-2-3-5)

(1 1)
(1 7)
(1 11)
(1 13)
(1 17)
(1 19)
(1 23)
(1 29)
(1 31)
(7 7)
(1 37)
(1 41)
(1 43)
(1 47)
(1 49)
(1 53)
(7 11)
(1 59)

Exercise 3.71

Here is the procedures that do the right things:

(define (merge-consecutive-weight s weight merger)
  (let ((x (stream-car s))
	(y (stream-car (stream-cdr s))))
    (let ((a (apply weight x))
	  (b (apply weight y)))
      (if (= a b)
	  (cons-stream
	   (merger x y)
	   (merge-consecutive-weight
	    (stream-cdr s)
	    weight
	    merger))
	  (merge-consecutive-weight
	   (stream-cdr s)
	   weight
	   merger)))))

(define ramanujans
  (let* ((weight
	  (lambda (i j)
	    (+ (cube i)
	       (cube j))))
	 (merger
	  (lambda (x y) (apply weight x))))
    (merge-consecutive-weight
     (weighted-pairs weight integers integers)
     weight
     merger)))

I've implemented merge-consecutive-weight general enough to cover next exercise.

Here is the first 5 numbers:

ramanujans

;Value: {1729 4104 13832 20683 32832 ...}

You should draw Henderson diagram of merge-consecutive-weight to understand
the process of design.

Exercise 3.72

Here is the a little convolved coding:

(define ramanujan-likes
  (let ((weight
	 (lambda (i j)
	   (+ (square i) (square j)))))
    (merge-consecutive-weight
     (merge-consecutive-weight
      (weighted-pairs weight integers integers)
      weight
      list)
     (lambda (p1 p2) (apply weight p1))
     (lambda (x y)
       (append x (cdr y))))))

Then the results:

(display-stream ramanujan-likes)

((10 15) (6 17) (1 18))
((13 16) (8 19) (5 20))
((17 19) (11 23) (5 25))
((14 23) (10 25) (7 26))
((19 22) (13 26) (2 29))
((15 25) (11 27) (3 29))
((21 22) (14 27) (5 30))
((20 25) (8 31) (1 32))
((23 24) (12 31) (9 32))
((12 31) (9 32) (4 33))
((25 25) (17 31) (5 35))
((20 30) (12 34) (2 36))
((22 29) (13 34) (10 35))
((22 31) (17 34) (1 38))
((19 33) (15 35) (9 37))
((25 30) (9 38) (2 39))
((28 29) (20 35) (16 37))
((20 35) (16 37) (5 40))
...

Exercise 3.73

(define (RC R C dt)
  (lambda (I v0)
    (add-streams
     (scale-stream I R)
     (integral (scale-stream I (/ 1.0 C))
	       v0
	       dt))))

Then test using the example required:

(define RC1 (RC 5 1 0.5))
(define zeros (cons-stream 0 zeros))
(define emulate-currents
  (stream-append
   (list->stream '(0 0.5 1 1 1 1 1 0.5 0))
   zeros))
(display-stream (RC1 emulate-currents 1))

1
3.5
6.25
6.75
7.25
7.75
8.25
6.25
4.
4.
4.
4.
4.
4.
4.
4.
4.

Exercise 3.74

First we implement sign-change-detector, which was supposed to be implemented
by Alyssa.

(define (sign-change-detector current last-value)
  (cond ((negative? last-value)
	 (if (negative? current)
	     0
	     ;; 0 is also treated as positive
	     1))
	(else
	 ;; 0 is also treated as positive
	 (if (negative? current)
	     -1
	     0))))

Then test:

(define test-data
  (stream-append
   (list->stream '(1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4))
   zeros))

(define test-crossings
  (make-zero-crossings test-data 0))

test-crossings

;Value: {0 0 0 0 0 -1 0 0 0 0 1 0 0 0 ...}

It correspond to what jotted in the text.

Then the main task:

(define zero-crossings
  (stream-map sign-change-detector
	      test-data
	      (cons-stream 0 test-data)))

zero-crossings

;Value: {0 0 0 0 0 -1 0 0 0 0 1 0 0 0 ...}

Exercise 3.75

In the given implementation, it use last-value in mixed sense: In one place it
works as last averaged value – previous avpt –; in the others it works as
last element of sense-data.

Thus, we can fix the problem by specifying what value the place expect:

(define (make-zero-crossings input-stream last-value last-avpt)
  (let ((avpt (/ (+ (stream-car input-stream) last-value) 2)))
    (cons-stream (sign-change-detector avpt last-avpt)
		 (make-zero-crossings (stream-cdr input-stream)
				      (stream-car input-stream)
				      avpt))))

Test:

(define test-crossings2
  (make-zero-crossings2 test-data 0 0))

test-crossings2

;Value: {0 0 0 0 0 0 -1 0 0 0 0 1 0 0 ...}

Exercise 3.76

(define (smooth s)
  (stream-map average s (stream-cdr s)))

Then

(define (make-smoothed-zero-crossings input-stream last-value)
  (let ((smooted (smooth input-stream)))
    (stream-map sign-change-detector
		smooted
		(cons-stream
		 last-value
		 smooted))))

Exercise 3.77

(define (integral delayed-integrand initial-value dt)
  (cons-stream initial-value
	       (let ((integrand (force delayed-integrand)))
		 (if (stream-null? integrand)
		     the-empty-stream
		     (integral (delay (stream-cdr integrand))
			       (+ (* dt (stream-car integrand))
				  initial-value)
			       dt)))))

Exercise 3.78

(define (solved-2nd a b dt y0 dy0)
  (define y (integral (delay dy) y0 dt))
  (define dy (integral (delay ddy) dy0 dt))
  (define ddy
    (add-streams
     (scale-stream dy a)
     (scale-stream y b)))
  y)

Exercise 3.79

(define (solved-2nd f dt y0 dy0)
  (define y (integral (delay dy) y0 dt))
  (define dy (integral (delay ddy) dy0 dt))
  (define ddy
    (stream-map f dy y))
  y)

Exercise 3.80

(define (RLC R L C dt)
  (lambda (vC0 iL0)
    (define vC
      (integral (delay dvC) vC0 dt))
    (define iL
      (integral (delay diL) iL0 dt))
    (define dvC
      (scale-stream iL (/ -1.0 C)))
    (define diL
      (add-streams
       (scale-stream vC (/ 1.0 L))
       (scale-stream iL (/ (- R) L))))
    (cons vC iL)))

Then the test accomplishing the example:

(define RLC1s ((RLC 1 1 0.2 0.1) 10 0))

(display-stream (car RLC1s))

10
10
9.5
8.55
7.220000000000001
5.5955
3.77245
1.8519299999999999
-.0651605000000004
-1.8831384500000004
-3.5160605800000004
-4.8915335745
-5.95365624055
-6.66498996127
-7.0075074978905
-6.982523782785449
-6.609663064296379
-5.924962228516943
-4.978248323100632
-3.829957696800105
...

(display-stream (cdr RLC1s))

0
1.
1.9
2.66
3.249
3.6461
3.84104
3.834181
3.6359559
3.2658442599999997
2.750945989
2.1242453320999997
1.4226674414399998
.6850350732409998
-4.9967430210100305e-2
-.7457214369781403
-1.3694016715588713
-1.893427810832622
-2.296581252601054
-2.5647479596510117
-2.691268933365921
-2.676900411726789
-2.529405295583274
...

Modularity of Functional Programs and Modularity of Objects

Exercise 3.81

This is the message passing paradigm in stream:

(define (rand-generator messages rand-seed)
  (if (empty-stream? messages)
      the-empty-stream
      (let* ((message (stream-car messages))
	     (msg (car message))
	     (args (cdr message)))
	(case msg
	  ((generate)
	   (let ((new-seed (rand-update rand-seed)))
	     (cons-stream new-seed
			  (rand-generator (stream-cdr messages)
					  new-seed))))
	  ((reset)
	   (cons-stream 'done
			(rand-generator (stream-cdr messages)
					(first args))))
	  (else
	   (error "Unknown request -- RAND-GENERATOR" message))))))

Then let's test it:

(define test-rand-generator
  (rand-generator
   (list->stream '((generate) (reset 0) (generate) (reset 0)))
   2))

(display-stream test-rand-generator)

80
done
26
done
26
;Unspecified return value

Exercise 3.82

We could have implemented the monte-carlo-stream using stream processing
convention:

(define (monte-carlo-stream2 experiments)
  (stream-map
   (lambda (p) (/ (car p) (+ (car p) (cdr p))))
   (stream-cdr
    (stream-fold-left
     (lambda (acc successed?)
       (if successed?
	   (cons (1+ (car acc))
		 (cdr acc))
	   (cons (car acc)
		 (1+ (cdr acc)))))
     (cons 0 0)
     experiments))))

(define (stream-fold-left procedure initial stream)
  (cons-stream initial
	       (stream-fold-left procedure
				 (procedure initial (stream-car stream))
				 (stream-cdr stream))))

Anyway, we can implement estimate-integral in stream version as follows

(define (estimate-integral P rect)
  (scale-stream
   (stream-map P (randoms-in-rect rect))
   (area rect)))

(define (randoms-in-rect rect)
  (cons-stream
   (random-in-rect rect)
   (randoms-in-rect rect)))

Here we used random-in-rect, which implicitly use the assignment; so
canonically it is not the stream version we expected. To implement
randoms-in-rect in stream, we need randoms in real number version between
0 and 1. It is George's problem; here we assume that we have that one. Then we
can make randoms-in-rect that is analogous to cesaro-stream:

(define (randoms-in-rect rect)
  (let ((points (list (bottom-left rect) (top-right rect))))
    (map-successive-pairs
     (lambda (r1 r2)
       (make-point
	((apply map-in-range
		(map x-coor points))
	 r1)
	((apply map-in-range
		(map y-coor points))
	 r2)))
     randoms-in-unit-range)))

(define (map-in-range low high)
  (lambda (number-over-unit-range)
    (let ((range (- high low)))
      (+ low (* range number-over-unit-range)))))

It is unfortunate that we should explicitly manipulate random number stream to
get updated random number by the help of map-successive-pairs.

A functional-programming view of time

In text, they noted that to formulate or deal with the concurrency problem of
Paul and Peter's that we encountered with in section 3.1.3 we need to
reintroduce the notion of time into our language – which functional style was
meant to eliminate. I thought to deal with this specific problem with making
that affection regional so that it does not leak over all the other components,
we should stamp the "time" when the user typed the input implicitly so that the
merge procedure can fairly merger the joint input stream by using the time as
weight.

Chapter 4: Metalinguistic Abstraction

Metalinguistic Abstraction – establishing new languages – plays an important
role in all branches of engineering design. It is particularly important to
computer programming, because in programming not only can we formulate new
languages but we can also implement these languages by constructing evaluators.

The Metacircular Evaluator

The Core of the Evaluator

In this section we use the syntax operations (the representation for the syntax
of language being implemented) to implement the eval and apply process. Our
evaluator uses several ADTs each for syntax for language being implemented and the
internal representations for internal evaluation model – environment.

Exercise 4.1

We can force the order by using let statement – since it is just syntactic
sugar for lambda application, the value of each bindings of let expression
evaluated before evaluating the body of it.

;;; Left to Right
(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (let ((first (eval (first-operand exps) env)))
	(cons first
	      (list-of-values (rest-operands exps) env)))))
;;; Right to Left
(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (let ((rest (list-of-values (rest-operands exps) env)))
	(cons (eval (first-operand exps) env)
	      rest))))

Representing Expressions

It is reminiscent of the symbolic differentiation program discussed in section
2.3.2; each expression has its own type tag in it, so our evaluator dispatch on
this type and recursively evaluate the nested expression.

Exercise 4.2
- a.
  
  It will deal the assignment expression as if it is procedure application since
  procedure application expression doesn't have any type for specifying it so any
  the pairs not sifted by the cond clauses before that clause treated as
  procedure application. So (define x 3) are treated procedure application and,
  in turn, evaluator lookup the define variable; since it couldn't find any it
  will signal error – undefined variable.
- b.
  
  Here is the fix:
```
(define (application? exp) (tagged-list? exp 'call))
```

Exercise 4.3

We can rely on the data-directed style only for the tagged expressions:

(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
	((variable? exp) (lookup-variable-value exp env))
	(else
	 (let ((op (and (tagged-exp? exp)
			(get 'eval (type-tag exp)))))
	   (cond (op (op exp env))
		 ((application? exp)
		  (apply (eval (operator exp) env)
			 (list-of-values (operands exp) env)))
		 (else
		  (error "Unknown expression type -- EVAL" exp)))))))

The procedures of tagged-exp ADT:

(define (type-tag exp)
  (car exp))
(define (tagged-exp? exp)
  (pair? exp))

Then install the contents:

(define (install-eval-clauses)
  (put 'eval 'quote (lambda (exp env) (text-of-quotation exp)))
  (put 'eval 'set! eval-assignment)
  (put 'eval 'define eval-definition)
  (put 'eval 'if eval-if)
  (put 'eval 'lambda (lambda (exp env)
		       (make-procedure (lambda-parameters exp)
				       (lambda-body exp)
				       env)))
  (put 'eval 'begin (lambda (exp env)
		      (eval-sequence (begin-actions exp) env)))
  (put 'eval 'cond (lambda (exp env)
		     (eval (cond->if exp) env)))
  'done)

I've implemented the type tags directly for simplicity.

Exercise 4.4

As special expression

(define (install-eval-and-or-direct)
  ;; and eval
  (define (eval-and exp env)
    (eval-and-subs (subexps exp) env))
  (define (eval-and-subs subs env)
    (cond ((null? subs) (eval 'true env))
	  ((last-sub? subs) (eval (first subs) env))
	  (else
	   (if (true? (eval (first-sub subs) env))
	       (eval-and-subs (rest-subs subs) env)
	       (eval 'false env)))))

  ;; or eval
  (define (eval-or exp env)
    (eval-or-subs (subexps exp) env))
  (define (eval-or-subs subs env)
    (cond ((null? subs) (eval 'false env))
	  ((last-sub? subs) (eval (first subs) env))
	  (else
	   (let ((current
		  (eval (first-sub subs) env)))
	     (if (false? current)
		 (eval-or-subs (rest-subs subs) env)
		 current)))))

  ;; selector on And or Or expression
  (define (subexps exp) (cdr exp))
  ;; sub ADT
  (define (last-sub? subs)
    (and (pair? subs) (null? (cdr subs))))
  (define first-sub car)
  (define rest-subs cdr)

  ;; interface with eval procedure
  (put 'eval 'and eval-and)
  (put 'eval 'or eval-or)
  'done)

Here we used data-directed style eval from ex 4.3.

Then setup for test:

(define eval-table (make-hash-table))
(define (put op type item)
  (if (eq? op 'eval)
      (hash-table-set! eval-table type item)
      (error "Unallowed operation -- PUT" op)))
(define (get op type)
  (if (eq? op 'eval)
      (hash-table-ref eval-table type (lambda () #f))
      (error "Unknown operation -- GET" op)))

Let's run!

1 ]=> (install-eval-clauses)

;Value: done

1 ]=> (install-eval-and-or-direct)

;Value: done

1 ]=> (driver-loop)

;;; M-Eval input:
(and)

;;; M-Eval value:
#t

;;; M-Eval input:
(and 5)

;;; M-Eval value:
5

;;; M-Eval input:
(and false)

;;; M-Eval value:
#f

;;; M-Eval input:
(and false 5 2)

;;; M-Eval value:
#f

;;; M-Eval input:
(and 5 2)

;;; M-Eval value:
2

;;; M-Eval input:
(and 5 false)

;;; M-Eval value:
#f

;;; M-Eval input:
(or)

;;; M-Eval value:
#f

;;; M-Eval input:
(or 5)

;;; M-Eval value:
5

;;; M-Eval input:
(or false 5 false flase)

;;; M-Eval value:
5

;;; M-Eval input:
(or false 5 false)

;;; M-Eval value:
5

;;; M-Eval input:
(or false false 5)

;;; M-Eval value:
5

Or we could test this in unit:

(install-eval-clauses)

;Value: done

(install-eval-and-or-direct)

;Value: done

(eval '(and 5) the-global-environment)

;Value: 5

(eval '(and false 5) the-global-environment)

;Value: #f

(eval '(or 5 false) the-global-environment)

;Value: 5

As derived expression

This is analogous to cond:

define (install-eval-and-or-derived)
  (define (expand-or-subs subs)
    (cond ((null? subs) 'false)
	  ((null? (cdr subs)) (car subs))
	  (else
	   (let ((first (car subs)))
	     (make-let
	      (list (list 'first first))
	      (list (make-if 'first
			'first
			(expand-or-subs (cdr subs)))))))))
  (define (expand-and-subs subs)
    (cond ((null? subs) 'true)
	  ((null? (cdr subs)) (car subs))
	  (else
	   (make-if (car subs)
		    (expand-and-subs (cdr subs))
		    'false))))

  (define (and->if exp)
    (expand-and-subs (cdr exp)))

  (define (or->if exp)
    (expand-or-subs (cdr exp)))

  (put 'eval 'and (lambda (exp env)
		    (eval (and->if exp) env)))
  (put 'eval 'or (lambda (exp env)
		   (eval (or->if exp) env)))
  'done)

For or, we used make-let to reuse the result of evaluation of first
subexpression in case where it turns out true.

Here is make-let syntax procedure that is analogous to make-lambda

;; List<binding>, List<expression> -> Let
(define (make-let bindings body)
  (cons 'let (cons bindings body)))

Then test!

(install-eval-and-or-derived)

;Value: done

(eval '(and 5) the-global-environment)

;Value: 5

(eval '(and false 5) the-global-environment)

;Value: #f

(eval '(and true 2 true) the-global-environment)

;Value: #t

For the or part, we delegate the test until we implement the let expression
in our evaluator (ex 4.6)

Exercise 4.5

We can support this new feature through either special form or derived form. The
key issue is that is it okay re-evaluate the <test> expression twice?

If it is okay, the only change that we should make is the sequence->exp part
of expand-clauses into

(define (expand-clauses clauses)
  (if (null? clauses)
      'false                          ; no else clause
      (let ((first (car clauses))
	    (rest (cdr clauses)))
	(if (cond-else-clause? first)
	    (if (null? rest)
		(sequence->exp (cond-actions first))
		(error "ELSE clause isn't last -- COND->IF"
		       clauses))
	    (make-if (cond-predicate first)
		     (cond-actions->exp first)
		     (expand-clauses rest))))))

(define (cond-actions->exp clause)
  (let ((actions (cond-actions clause)))
    (if (eq? (car actions) '=>)
	(if (and (pair? (cdr actions))
		 (null? (cddr actions)))
	    (list (cadr actions) (cond-predicate clause))
	    (error "Illformed expression -- COND-MAP" clause))
	(sequence->exp actions))))

Then test:

(eval '(cond ((cons 3 4) => cdr)
			 (else false)) the-global-environment)

;Value: 4

(eval '(cond ((cons 3 4) => cdr 3)
			 (else false)) the-global-environment)

;Illformed expression -- COND-MAP ((cons 3 4) => cdr 3)
;To continue, call RESTART with an option number:
; (RESTART 1) => Return to read-eval-print level 1.

If it is not, in other word, we are constrained to evaluate the cond-predicate
only once, we do use make-let as we did in the previous exercise.

(define (expand-clauses clauses)
  (if (null? clauses)
      'false                          ; no else clause
      (let ((first (car clauses))
	    (rest (cdr clauses)))
	(if (cond-else-clause? first)
	    (if (null? rest)
		(sequence->exp (cond-actions first))
		(error "ELSE clause isn't last -- COND->IF"
		       clauses))
	    (let ((pred (cond-predicate first)))
	      (make-let
	       (list (list 'pred pred))
	       (list (make-if 'pred
			      (map-or-sequence->exp
			       (cond-actions first) 'pred)
			      (expand-clauses rest)))))))))

(define (map-or-sequence->exp actions pred)
  (if (eq? (car actions) '=>)
      (if (and (pair? (cdr actions))
	       (null? (cddr actions)))
	  (list (cadr actions) pred)
	  (error "Illformed expression -- COND-MAP" clause))
      (sequence->exp actions)))

Exercise 4.6

(define (install-eval-let)
  (define (let->combination exp)
    (let* ((bindings (bindings exp))
	   (unziped-b
	    (fold-right
	     (lambda (var-exp vars-exps)
	       (cons (cons (car var-exp) (car vars-exps))
		     (cons (cadr var-exp) (cdr vars-exps))))
	     (cons '() '())
	     bindings))
	   (params (car unziped-b))
	   (exps (cdr unziped-b)))
      (cons (make-lambda params (body exp))
	    exps)))

  (define bindings cadr)
  (define body cddr)
  (put 'eval 'let (lambda (exp env)
		    (eval (let->combination exp) env)))
  'done)

Then test:

(eval '(let ((x 1)) (cons x 2)) the-global-environment)

;Value: (1 . 2)

(eval '(let ((x 1)) (cons x 2) (cons 2 x)) the-global-environment)

;Value: (2 . 1)

Then now we can test the or of derived version:

(install-eval-and-or-derived)

;Value: done

(eval '(or 5 false) the-global-environment)

;Value: 5

(eval '(or false 5 false) the-global-environment)

;Value: 5

And derived cond's new feature:

(eval '(cond ((cons 3 4) => cdr)
			 (else false)) the-global-environment)

;Value: 4

(eval '(cond ((cons 3 4) => cdr 3)
			 (else false)) the-global-environment)

;Unbound variable: clause

By test it we found the bug in our previous error handling. It is easy to fix.
After fixing,

(eval '(cond ((cons 3 4) => cdr 3)
			 (else false)) the-global-environment)

;Illformed expression -- COND-MAP (=> cdr 3)

It works as expected.

Exercise 4.7

(define (install-eval-let*)
  (define (let*->let exp)
    (define (expand-let* bindings)
      (if (null? bindings)
	  (body exp)
	  (let ((first (car bindings))
		(rest (cdr bindings)))
	    (make-let
	     (list first)
	     ((if (null? rest)
		  identity-procedure
		  list) ;for the type contraction of make-let
	      (expand-let* rest))))))
    (expand-let* (bindings exp)))
  (define bindings cadr)
  (define body cddr)
  (put 'eval 'let* (lambda (exp env)
		     (eval (let*->let exp) env)))
  'done)

It suffices to define let* as derived expression since subsequent derived
expression reduced to non-derived expression by eval and apply loop, which
in turn reduced to primitive expressions.

Then test:

(install-eval-let*)

;Value: done

(eval
 '(let* ((x 3)
	 (y (+ x 2))
	 (z (+ x y 5)))
    (* x z))
 the-global-environment)

;Value: 39

Exercise 4.8

First let we code the test:

(eval
 '(define (fib n)
    (let fib-iter ((a 1)
		   (b 0)
		   (count n))
      (if (= count 0)
	  b
	  (fib-iter (+ a b) a (- count 1)))))
 the-global-environment)
;; ok
(eval
 '(fib 3)
 the-global-environment)
;; 1

And note that by using the environment model, we can deduce named let expression
(let <var> <bindings> <body>) is equivalent to

(let ((<var> undef))
  (set! <var>
    (lambda <params of bindings> body))
  (apply <var> <exps of bindings>))

So we convert named let expression above equivalent expression.

Here is the result:

(define (install-eval-let-with-named)
  ;; ADT for named
  (define (named? exp)
    (and (pair? exp)
	 (pair? (cdr exp))
	 (symbol? (cadr exp))))

  (define (named exp)
    (cadr exp))

  (define (except-name-let exp)
    (cdr exp))

  (define (let->combination exp)
    (let* ((bindings (bindings exp))
	   (unziped-b
	    (fold-right
	     (lambda (var-exp vars-exps)
	       (cons (cons (car var-exp) (car vars-exps))
		     (cons (cadr var-exp) (cdr vars-exps))))
	     (cons '() '())
	     bindings))
	   (params (car unziped-b))
	   (exps (cdr unziped-b)))
      (cons (make-lambda params (body exp))
	    exps)))

  (define (named->let-combination exp)
    (let ((var (named exp))
	  (comb (let->combination
		 (except-name-let exp))))
      (let ((lambda-part (car comb))
	    (exps (cdr comb)))
	(make-let
	 (list (list var (list 'quote undef)))
	 (list
	  (make-assignment var
			   lambda-part)
	  (cons var
		exps))))))

  (define bindings cadr)
  (define body cddr)
  (put 'eval 'let (lambda (exp env)
		    (eval (if (named? exp)
			      (named->let-combination exp)
			      (let->combination exp)) env)))
  'done)

And the auxiliary parts:

(define undef '*unassigned*)
(define (make-assignment var val)
  (list 'set! var val))

Then let's test:

(install-eval-let-with-named)

;Value: done

(eval
 '(define (fib n)
    (let fib-iter ((a 1)
		   (b 0)
		   (count n))
      (if (= count 0)
	  b
	  (fib-iter (+ a b) a (- count 1)))))
 the-global-environment)

;Value: ok

(eval
 '(fib 3)
 the-global-environment)

;Unbound variable =

Huh, we should set = (and also -) as primitive procedure in our environment.
Do that and re-run:

(install-eval-clauses)

;Value: done

(install-eval-let-with-named)

;Value: done

(eval
 '(define (fib n)
    (let fib-iter ((a 1)
		   (b 0)
		   (count n))
      (if (= count 0)
	  b
	  (fib-iter (+ a b) a (- count 1)))))
 the-global-environment)

;Value: ok

(eval
 '(fib 3)
 the-global-environment)

;Value: 2

(eval
 '(fib 2)
 the-global-environment)

;Value: 1

Oh-huh there are good news and bad news:

Our test code was wrong! (fib 3) should return 2 not 1 as it count from 0!
Our code works right!

Exercise 4.9

For example, here we try to implement typical imperative control structure,
while. Let us think about the what syntax should it be? Analogous to any other
imperative programming language, let we make our syntax as follows:

(while <pred>
  <exp1>
  ...
  <expN>)

The semantic of this control structure are followings:

Evaluate <pred> first.
If it true, execute from <exp1> until <expN> sequentially; Then go to 1.
If it was false, then return the control to consequent structure (return
undefined value).

All of the above expressions should be evaluated in a same environment; we don't
need to extend the given environment.

Then here is the code:

(define (install-eval-while)
  (define pred cadr)
  (define body cddr)
  (define (eval-while exp env)
    (let ((bexp (sequence->exp (body exp))))
      (let loop ()
	(if (true? (eval (pred exp) env))
	    (begin (eval bexp env)
		   (loop))
	    'done))))
  (put 'eval 'while eval-while)
  'done)

Then here is the test code:

(eval '(begin
	 (define x 5)
	 (define sum 0)
	 (while (> x 0)
	   (set! sum (+ x sum))
	   (set! x (-1+ x)))
	 sum)
      the-global-environment)
;Should return 15

And run:

(eval '(begin
	 (define x 5)
	 (define sum 0)
	 (while (> x 0)
	   (set! sum (+ x sum))
	   (set! x (-1+ x)))
	 sum)
      the-global-environment)

;Value: 15

Sweet!

Exercise 4.10

Here we will use dispatch on type rather than data-directed style since we are
going to mix the infix expressions with prefix expressions. Specifically we will
transform the assignment notation and that of definition into infix notation:

From (set! <var> <exp>) to (<var> <- <exp>);
From (define <var> <exp>) to (<var> = <exp>).

All we need to change is the detectors and selectors:

From

;; detector
(define (assignment? exp)
  (tagged-list? exp 'set!))

;; selectors
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))

to

;; detector
(define (assignment? exp)
  (infix-tag-list? exp '<-))

;; selectors
(define (assignment-variable exp) (car exp))
(define (assignment-value exp) (caddr exp))

From

;; detector
(define (definition? exp)
  (tagged-list? exp 'define))

;; selectors
(define (definition-variable exp)
  (if (symbol? (cadr exp))
      (cadr exp)
      (caadr exp)))
(define (definition-value exp)
  (if (symbol? (cadr exp))
      (caddr exp)
      (make-lambda (cdadr exp)
		   (cddr exp))))

to

;; detector
(define (definition? exp)
  (infix-tag-list? exp '=))

;; selectors
(define (definition-variable exp)
  (if (symbol? (car exp))
      (car exp)
      (caar exp)))
(define (definition-value exp)
  (if (symbol? (car exp))
      (caddr exp)
      (make-lambda (cdar exp)
		   (cddr exp))))

Then the test code:

;; Test infix defintion
(eval '(begin (x = 2)
	      x)
      the-global-environment)
;; 2
;; procedure definition
(eval
 '((factorial n) = (if (= n 1)
		       1
		       (* n (factorial (-1+ n)))))
 the-global-environment)
;; ok
(eval '(factorial 3) the-global-environment)
;; 6


;; test infix assignment
(eval '(begin (x <- 5)
	      x)
      the-global-environment)
;; 5

Then let's run

(eval '(begin (x = 2)
	      x)
      the-global-environment)

;Value: 2

(eval
 '((factorial n) = (if (= n 1)
		       1
		       (* n (factorial (-1+ n)))))
 the-global-environment)

;Value: ok

(eval '(factorial 3) the-global-environment)

;Value: 6

(eval '(begin (x <- 5)
	      x)
      the-global-environment)

;Value: 5

Evaluator Data Structures

Exercise 4.11

This is same as replace our frame data structure with table as we did in section
3.3. Then the changes are trivial:

;; For extend-environment
(define (make-frame vars vals)
  (let ((bindings
	 ;; provided that the length of both arguments match
	 (fold-right
	  (lambda (var val bindings)
	    (cons (list var val) bindings))
	  '()
	  vars
	  vals))
	(tbl (make-table)))
    (set-bindings! tbl bindings)
    tbl))

;; Table ADT
;; constructor
(define (make-table)
  (list '*table*))
;; mutator
(define set-bindings! set-cdr!)
;; selector
(define bindings cdr)

;; For lookup-variable-value
(define (lookup-variable-value var env)
  (let env-loop ((env env))
    (if (eq? env the-empty-environment)
	(error "Unbound variable" var)
	(let ((frame (first-frame env)))
	  (cond ((assoc var (bindings frame)) => cadr)
		(else (env-loop
		       (enclosing-environment env))))))))

;; For set-variable-value!
(define (set-variable-value! var val env)
  (let env-loop ((env env))
    (if (eq? env the-empty-environment)
	(error "Unbound variable -- SET!" var)
	(let ((frame (first-frame env)))
	  (cond ((assoc var (bindings frame))
		 => (lambda (b) (set-car! (cdr b) val)))
		(else (env-loop
		       (enclosing-environment env))))))))

;; For define-variable!
(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (cond ((assoc var (bindings frame))
		 => (lambda (b) (set-car! (cdr b) val)))
	  (else (set-bindings! frame
			       (cons (list var val)
				     (bindings frame)))))))

By using the built in procedures about the alist structure, we could write our
procedures more succinctly; this leads that we recognize the common patterns in
above procedures more obviously, which we revisit in the next exercise.

Return to our discourse, let we code the test:

;; test definition
(eval '(define test-def 0) the-global-environment)
;; ok

;; test assignment in nested frame
(eval '(define (test-assignment) (set! test-def 5))
      the-global-environment)
;; ok

(eval 'test-def the-global-environment)
;; 0

(eval '(test-assignment) the-global-environment)
;; ok

;; test lookup-variable-value
(eval 'test-def the-global-environment)
;; 5

;; verify that we using the new data structure for frame
(caar the-global-environment)
;; *table*

Then run:

(eval '(define test-def 0) the-global-environment)

;Value: ok

(eval '(define (test-assignment) (set! test-def 5))
      the-global-environment)

;Value: ok

(eval 'test-def the-global-environment)

;Value: 0

(eval '(test-assignment) the-global-environment)

;Value: ok

(eval 'test-def the-global-environment)

;Value: 5

(caar the-global-environment)

;Value: *table*

Exercise 4.12

We can capture the common pattern first by recognizing the same code in those
code and then refine them with their role of behavior, namely traversing given
frame and traversing given environment:

;; Var, (Vals -> Any) -> FrameOp
(define (find-var-and-apply-in-frame var vals-op)
  (lambda (null-op frame)
    (let scan ((vars (frame-variables frame))
	       (vals (frame-values frame)))
      (cond ((null? vars)
	     (null-op))
	    ((eq? var (car vars))
	     (vals-op vals))
	    (else (scan (cdr vars) (cdr vals)))))))

;; FrameOp, void -> Any, Env
;; -> Any
(define (traverse-env-using frame-op empty-env-op env)
  (if (eq? env the-empty-environment)
      (empty-env-op)
      (frame-op (first-frame env)
		(lambda () (traverse-env-using frame-op empty-env-op
					       (enclosing-environment env))))))

Here we, for interfacing the traverser on environment with traverser on frame,
defined new data type, namely FrameOp – FrameOp := Frame, NullOp -> Any,
NullOp := void -> Any.

Then our operations on environments get

(define (lookup-variable-value var env)
  (traverse-env-using
   (find-var-and-apply-in-frame var car)
   (lambda () (error "Unbound variable" var))
   env))

(define (set-variable-value! var val env)
  (traverse-env-using
   (find-var-and-apply-in-frame
    var
    (lambda (vals) (set-car! vals val)))
   (lambda () (error "Unbound variable -- SET!" var))
   env))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    ((find-var-and-apply-in-frame
      var
      (lambda (vals) (set-car! vals val)))
     (lambda ()
       (add-binding-to-frame! var val frame))
     frame)))

Then test using the test code of previous exercise:

...
(eval 'test-def the-global-environment)

;The object #[compound-procedure 38], passed as the first argument to cdr, is not the correct type.
;To continue, call RESTART with an option number:
; (RESTART 2) => Specify an argument to use in its place.
; (RESTART 1) => Return to read-eval-print level 1.

2 error> (pp #@38)
(lambda ()
  (traverse-env-using frame-op empty-env-op (enclosing-environment env)))
;Unspecified return value

Got error! It is due to the ill-ordered argument in traverse-env-using. After
fixing that we got:

(eval '(define test-def 0) the-global-environment)

;Value: ok

(eval '(define (test-assignment) (set! test-def 5))
      the-global-environment)

;Value: ok

(eval 'test-def the-global-environment)

;Value: 0

(eval '(test-assignment) the-global-environment)

;Value: ok

(eval 'test-def the-global-environment)

;Value: 5

Our code got more cleaner and easier for us to read.

Exercise 4.13

As we can think of this new special form as counter expression against define,
let we make make-unbound! remove only the binding in the first frame of the
environment. To implement this feature, that is to remove specific binding in the
frame, we need to do nearly what we did in remove-first-item in agenda data
structure. So, we would not reuse the abstract procedure of previous exercise,
find-var-and-apply-in-frame; but the resulting procedure would be nearly same
as that.

To encompass this pattern, we extend find-var-and-apply-in-frame with:

(define (find-var-and-apply-to-bindings var find-op bindings-op)
  (lambda (null-op frame)
    (let scan ((vars (frame-variables frame))
	       (vals (frame-values frame)))
      (cond ((null? vars)
	     (null-op))
	    ((eq? var (find-op vars))
	     (bindings-op vars vals))
	    (else (scan (cdr vars) (cdr vals)))))))

Then we can define

(define (find-var-and-apply-in-frame var vals-op)
  (find-var-and-apply-to-bindings
   var car (lambda (vars vals) (vals-op vals))))

Or it would better to refine our frame data structure by making the
frame-variables and frame-values to be headed list respectively to encompass
make-unbound! in our scheme uniformly.

As we defined our frame data structure abstractly, all we need to change is the
representation of frame:

;; Change the representation of frame
(define (make-frame variables values)
  (cons (cons '*variables* variables)
	(cons '*values* values)))

(define (frame-variables frame) (cdar frame))
(define (frame-values (cddr frame)))

Then we exploit this idea by amending the find-var-and-apply-to-bindings
allowing even the selectors and detector for frame:

(define (find-var-and-apply-to-bindings
	 var find-op bindings-op frame-vars frame-vals empty-vars?)
  (lambda (null-op frame)
    (let scan ((vars (frame-vars frame))
	       (vals (frame-vals frame)))
      (cond ((empty-vars? vars)
	     (null-op))
	    ((eq? var (find-op vars))
	     (bindings-op vars vals))
	    (else (scan (cdr vars) (cdr vals)))))))

(define (find-var-and-apply-in-frame var vals-op)
  (find-var-and-apply-to-bindings
   var car (lambda (vars vals) (vals-op vals))
   frame-variables frame-values null?))

Then we can define what we wanted:

(define (unbound-variable! var val env)
  (let ((frame (first-frame env)))
    ((find-var-and-apply-to-bindings
      var cadr
      (lambda (h-vars h-vals)
	(set-cdr! h-vars (cddr h-vars))
	(set-cdr! h-vals (cddr h-vals)))
      car cdr (lambda (h-vars) (null? (cdr h-vars))))
     (lambda ()
       (error "Unbound variable in the given frame -- MAKE-UNBOUND!" var))
     frame)))

(define (install-eval-make-unbound)
  (define var cadr)
  (define val caddr)
  (put 'eval 'make-unbound!
       (lambda (exp env)
	 (unbound-variable! (var exp)
			    (val exp)
			    env))))

Then let we first test the new frame data structure:

(eval '(test-assignment) the-global-environment)

;Unbound variable test-assignment

Error! This is due to the add-binding-to-frame! as we did not updated that
procedure, which is mutator of frame structure!

Then refine the data structure for frame:

;; Change the representation of frame
(define (make-frame variables values)
  (cons (cons '*variables* variables)
	(cons '*values* values)))

;; selectors for frame
(define (frame-variables frame) (cdar frame))
(define (frame-values frame) (cddr frame))

;; mutators of frame
(define (add-binding-to-frame! var val frame)
  (set-cdr! (car frame) (cons var (frame-variables frame)))
  (set-cdr! (cdr frame) (cons val (frame-values frame))))

(define (remove-binding-from-frame! var frame exception)
  ((find-var-and-apply-to-bindings
      var cadr
      (lambda (h-vars h-vals)
	(set-cdr! h-vars (cddr h-vars))
	(set-cdr! h-vals (cddr h-vals)))
      car cdr (lambda (h-vars) (null? (cdr h-vars))))
     exception
     frame))

Then our procedure get clarified as

(define (unbound-variable! var env)
  (remove-binding-from-frame!
   var
   (first-frame env)
   (lambda ()
     (error "Unbound variable in the given frame -- MAKE-UNBOUND!" var))))

Re-run our test code:

(eval '(define test-def 0) the-global-environment)

;Value: ok

(eval '(define (test-assignment) (set! test-def 5))
      the-global-environment)

;Value: ok

(eval 'test-def the-global-environment)

;Value: 0

(eval '(test-assignment) the-global-environment)

;Value: ok

(eval 'test-def the-global-environment)

;Value: 5

(eval '(make-unbound! test-def) the-global-environment)

;ok

(eval '(make-unbound! test-def) the-global-environment)

;Unbound variable in the given frame -- MAKE-UNBOUND! test-def

Works sweetly!

Running the Evaluator as a Program

Exercise 4.14
1. It is because our evaluator uses data abstraction for decouple the semantics
  from syntaxes of language.
2. Combined with the 1., it is due to the difference of how evaluator treats
  application of compound procedure from that of primitive procedure.
3. Map needs to apply evaluated procedure to the each element of given list;
  but the value of that procedure is wrapped around by type-tag and it handled
  underlying Scheme's evaluator which don't know how to handle our type-tagged data.
4. So namely, it is not the procedure, which handed over to map, in
  implementation language but in language being implemented.

Data as Programs

Exercise 4.15

We can prove this by case analysis with reductio ad absurdum:
- (try try) → 'halted:
  By definition of try, it implies that (halts? try try) evaluated as
  false. Which in turn means (try try) raises error or run forever by the
  definition of halts?; this is contradiction with our assumption – (try try) returns 'halted, which means it halted.
- (try try) → run forever or raise error:
  With the same argument from the previous one, it leads to contradiction with
  assumption in any case – whether it evaluated as run forever or raise error.

Internal Definitions

Exercise 4.16

a.

(define (lookup-variable-value var env)
  (traverse-env-using
   (find-var-and-apply-in-frame
    var
    (lambda (vals)
      (let ((val (car vals)))
	(if (eq? val undef)
	    (error "Unassigned variable" var)
	    val))))
   (lambda () (error "Unbound variable" var))
   env))

b.

I've designed in the text book with my digital paper:

(define (scan-out-defines proc-body)
  (let ((extrated-exps
	 ;; List<Exp> (proc-body) -> List<Exp> x List<Exp>
	 ;; We implement this a little bit complicate procedure since
	 ;; we want to examine possible user error --
	 ;; defenstive programming.
	 (fold-right
	  (lambda (exp extracted)
	    (if (definition? exp)
		(cons (cons exp (car extracted)) (cdr extracted))
		(if (null? (car extracted))
		    (cons (car extracted) (cons exp (cdr extracted)))
		    ;; intertwined internal definitions with others
		    (error "Internal defintions intertwins with others" proc-body))))
	  (cons '() '())
	  proc-body)))
    (let ((internal-defs (car extrated-exps))
	  (rest-body (cdr extrated-exps)))
      (let ((vars (map definition-variable internal-defs))
	    (exps (map definition-value internal-defs)))
	(let ((bindings
	       (map (lambda (var) (list var (list 'quote undef)))
		    vars))
	      (set-exps
	       (map (lambda (var val)
		      (make-assignment var val))
		    vars
		    exps)))
	  (make-let bindings (append set-exps rest-body)))))))

Then let's test:

;; test for scan-out-defines
(scan-out-defines
 '((define u <e1>)
   (define v <e2>)
   <e3>))
;; should return
(let ((u '*unassigned*)
      (v '*unassigned*))
  (set! u <e1>)
  (set! v <e2>)
  <e3>)

Then the results:

(pretty-print (scan-out-defines
	       '((define u <e1>)
		 (define v <e2>)
		 <e3>)))
(let ((u '*unassigned*) (v '*unassigned*))
  (set! u <e1>)
  (set! v <e2>)
  <e3>)
;Unspecified return value

as expected.

c.

The construction time is better. Note that it is analogous to the choice we made
when we comes with rational number arithmetic package. Since procedure is
"captured common computational process," it is supposed to be applied more than
defining ones; so by make scan-out-defines run in the construction time, we'll
get more efficient implementation dynamically.

Then here is the code:
```
(define (make-procedure parameters body env)
  (list 'procedure parameters
	(scan-out-defines body)
	env))
```

Exercise 4.17

I've drawn the required diagram with my digital paper.

For the second question, first we need to recognize what the correct program is;
as jotted in the text book, correct program means what program obeyed the
described restriction – the defined variables' values can be evaluated without
using any of variables' values. Then we can answer given question: Variables
that can be looked up in evaluating <e3> is same in both environment
structure; as an evaluation of any statement can not inspect the environment
directly, the behavior of both should equals among both. More formally, we can
prove the argument using the structure induction on eval/apply; that is,
evaluation of statement achieved by eval/apply, so we need to prove if all the
behavior of the program before the transformation are same, then after that
transformation the evaluation result of each clause should results in same as
before the transformation.

Lastly, we can fix this different environment structure by transforming the
internal definitions into

Define the variables of them with *unassigned* then set! the value by
corresponding expressions afterward, which would do not make any extra frame
and also satisfy all the specifications described above.
Note that this fixation does not involve any ill-defined procedure, that is
the infinite loop where calls itself again and again.

The code:

(define (scan-out-defines2 proc-body)
  (let ((extrated-exps
	 ;; List<Exp> (proc-body) -> List<Exp> x List<Exp>
	 ;; We implement this a little bit complicate procedure since
	 ;; we want to examine possible user error --
	 ;; defenstive programming.
	 (fold-right
	  (lambda (exp extracted)
	    (if (definition? exp)
		(cons (cons exp (car extracted)) (cdr extracted))
		(if (null? (car extracted))
		    (cons (car extracted) (cons exp (cdr extracted)))
		    ;; intertwined internal definitions with others
		    (error "Internal defintions intertwines with others" proc-body))))
	  (cons '() '())
	  proc-body)))
    (let ((internal-defs (car extrated-exps))
	  (rest-body (cdr extrated-exps)))
      (let ((vars (map definition-variable internal-defs))
	    (exps (map definition-value internal-defs)))
	(let ((def-vars
	       (map (lambda (var) (make-definition var (list 'quote undef)))
		    vars))
	      (set-exps
	       (map (lambda (var val)
		      (make-assignment var val))
		    vars
		    exps)))
	  (append def-vars (append set-exps rest-body)))))))

(define (make-definition var val)
  (list 'define var val))

Then test again:

(pretty-print (scan-out-defines2
	       '((define u <e1>)
		 (define v <e2>)
		 <e3>)))
((define u '*unassigned*) (define v '*unassigned*) (set! u <e1>) (set! v <e2>) <e3>)

Exercise 4.18

This new version would not work; whereas the version in the text works. We can
reason this as follows:
```
(define (solve f y0 dt)
  (define y (integral (delay dy) y0 dt)) ;does not evaluate dy until it need
  ;; ↑ in this block structure it never needed.
  (define dy (stream-map f y))          ;does evaluate y
  y)
```
1. As noted above annotation, the value expression of dy involves y and need
  to evaluate that to return the value.
2. Since in this transformation strategy does not change all the occurrence of
  u and v into a and b respectively in the <e1> and <e2> as it
  assume the restriction is obeyed, when it comes to evaluate y it lookup and
  signal error as it found *unassigned*.
3. This malfunction is due to the modification of the name of definition without
  changing all the expressions that depend on the name of internal definitions
  as we noted above.
Exercise 4.19
1. I myself couldn't yet be convinced by why we need to treat internal
  definitions especially; so I support Ben's view since it make me (and
  possibly other people too) easy to understand the behavior of internal
  definition in consistent manner.
  
  However it is trickier than it seems since the difference between procedure
  and other data. And because of the limitation of text editor environment: We
  are forced to write code in sequential manner; so it forces us to think as if
  we are dealing with sequential events. But it isn't as we discuss below.
  
  The above discussion is not consistent with that of mutual recursive
  procedures – it works as if the defines evaluated simultaneously. So in
  theory Eva's view point is the most consistent one.
2. For the second question; yes, we can but it should be implemented in a error
  handling manner: If we got into unassigned value error, then try to delegate
  the execution of that assignment statement (to stack another place and try
  each of them when we reach the end of assignment statement; if there are no
  reduction in stack after one-loop finally it should raise an error – give
  up!). This algorithm is expensive since it recursively reduces the stacked
  statements until there is no change.

Exercise 4.20

a.

Here we implement the strategy written in text book. That is, to transform from

(letrec ((u <e1>)
	 (v <e2>))
  <e3>)

to

(let ((u '*unassigned*)
      (v '*unassigned*))
  (set! u <e1>)
  (set! v <e2>)
  <e3>)

So we can code the test code using above example:

(pretty-print (letrec->let-assignment
	       (letrec ((u <e1>)
			(v <e2>))
		 <e3>)))
(let ((u '*unassigned*)
      (v '*unassigned*))
  (set! u <e1>)
  (set! v <e2>)
  <e3>)
;Unspecified return value

Then code:

(define (install-eval-letrec)
  (define bindings cadr)                ;((u <e1>) (v <e2>))
  (define body cddr)                    ;<e3>
  (define (letrec->let-assignment exp)
    (let ((binds (bindings exp))
	  (rest-body (body exp)))
      (let ((vars (map car binds))
	    (exps (map cadr binds)))
	(make-let
	 (map (lambda (var) (list var (list 'quote undef)))
	      vars)
	 (append
	  (map (lambda (var exp) (make-assignment var exp))
	       vars exps)
	  rest-body)))))
  (put 'eval 'letrec
       (lambda (exp env)
	 (eval (letrec->let-assignment exp) env)))
  ;; test
  (letrec->let-assignment
   '(letrec ((u <e1>)
	     (v <e2>))
      <e3>)))

And test!

(pretty-print (install-eval-letrec))
(let ((u '*unassigned*) (v '*unassigned*))
  (set! u <e1>)
  (set! v <e2>)
  <e3>)
;Unspecified return value

b.

Solely let, we cannot express recursive process within the body of procedure.
I've drawn the environment diagram reasoning about this assertion.

Exercise 4.21

a.
```
((lambda (n)
   ((lambda (fact)
      (fact fact n))
    (lambda (ft k)
      (if (= k 1)
	  1
	  (* k (ft ft (- k 1)))))))
 10)

;Value: 3628800
```
It works well. By using this technique – specifically the lambda calculus by
Alonzo Church – we can reason our program's behavior using, back to our old
friend, substitution model.

Fibonacci number can be calculated by using this strategy:
```
((lambda (n)
   ((lambda (fibo)
      (fibo fibo n))
    (lambda (fib k)
      (if (< k 2)
	  k
	  (+ (fib fib (- k 1))
	     (fib fib (- k 2)))))))
 4)

;Value: 3
```
The common pattern in above procedures is that the inner procedure, which do all
the serious process, take additional parameter. We can think of this parameter
as self reference; as soon as we calculate the type contract of this self
parameter, we realize this is same as that type of the procedure of discourse.

b.

(define (f x)
  ((lambda (even? odd?)
     (even? even? odd? x))
   (lambda (ev? od? n)
     (if (= n 0) true (od? ev? od? (-1+ n))))
   (lambda (ev? od? n)
     (if (= n 0) false (ev? ev? od? (-1+ n))))))

then test:

(f 5)

;Value: #f

(f 4)

;Value: #t

Separating Syntactic Analysis from Execution

Exercise 4.22

We can get what we want by mapping the expression part to let->combination to
analyze-application. First let we make our analyzer to be data-directed
style, which is analogous to ex 4.3:

(define (analyze exp)
  (cond ((self-evaluating? exp)
	 (analyze-self-evaluating exp))
	((variable? exp) (analyze-variable exp))
	(else
	 (let ((op (and (tagged-exp? exp)
			(get 'analyze (type-tag exp)))))
	   (cond (op (op exp))
		 ((application? exp)
		  (analyze-application exp))
		 (else
		  (error "Unknown expression type -- ANALYZE" exp)))))))

Then extend our eval ad-hoc table into more general 2 dimensional
hash-table:

(define operation-table (make-hash-table))
(define (put op type item)
  (let ((type-table (hash-table-ref operation-table op (lambda () #f))))
    (if type-table
	(hash-table-set! type-table type item)
	(let ((type-table (make-hash-table)))
	  (hash-table-set! type-table type item)
	  (hash-table-set! operation-table op type-table)))))
(define (get op type)
  (let ((type-table
	 (hash-table-ref operation-table op (lambda () #f))))
    (and type-table
	 (hash-table-ref type-table type (lambda () #f)))))

And then

(define (install-analyze-clauses)
  (put 'analyze 'quote analyze-quoted)
  (put 'analyze 'set! analyze-assignment)
  (put 'analyze 'define analyze-definition)
  (put 'analyze 'if analyze-if)
  (put 'analyze 'lambda analyze-lambda)
  (put 'analyze 'begin (lambda (exp) (analyze-sequence (begin-actions exp))))
  (put 'analyze 'cond (lambda (exp) (analyze (cond->if exp))))
  'done)

Finally we can return our original task:

(define (install-analyze-let)
  (define let->combination
    (cadr (assq 'let->combination (install-eval-let))))
  (put 'analyze 'let (lambda (exp) (analyze-application (let->combination exp)))))

To make available the let->combination procedure, which is defined in
install-eval-let, I've made following change to the end of install-eval-let:

*** the last line of install-eval-let
  `((let->combination ,let->combination))

That is, the alist of procedures, which we want to export. And you may find
Scheme manual about quasi-quote useful.

Exercise 4.23

The procedure of Alyssa's version start to link all the sequence expressions
into one analyzed expression in execution time; whereas the version of text do
link the sequence in the analysis time. As consequence, the number of steps it
needs when it executed are quite different among both. I've wrote the sample
execute in my digital paper using the substitution model since the execution
does not involve any side effect (the side effect of executed statement does not
affect the behavior of this level of abstraction).

Exercise 4.24

Compare Execution Time

Here we compare the time it needs to execute application of test procedure. For
the test procedure we use procedure which calculate Fibonacci number using multi
recursive process (since it is expensive, we can measure the time more
apparently).

The definition of test procedure:

(define (fib n)
  (cond ((= n 0) 0)
	((= n 1) 1)
	(else (+ (fib (- n 1))
		 (fib (- n 2))))))

And we can extract only the execution of application not the definition by
using eval, namely

(eval '(fib 33) the-global-environment)

Then we can time it needs to execute whole of this process the variation from
project 3:

(define (timed proc)
  (let ((start (runtime)))
    (let ((val (proc)))
      (newline)
      (display "time expended: ")
      (display (- (runtime) start))
      val)))

Then we can use this as

(timed (lambda () (eval '(fib 33) the-global-environment)))

As we designed the experiments, now let's run those:

;;; Analysis
(install-analyze-clauses)
(eval
 '(define (fib n)
    (cond ((= n 0) 0)
	  ((= n 1) 1)
	  (else (+ (fib (- n 1))
		   (fib (- n 2))))))
 the-global-environment)
(timed (lambda () (eval '(fib 20) the-global-environment)))

time expended: 1.6300000000000026
;Value: 6765

Turns out (fib 33) way more expensive to wait.

Then without analysis version:

(install-eval-clauses)
(eval
 '(define (fib n)
    (cond ((= n 0) 0)
	  ((= n 1) 1)
	  (else (+ (fib (- n 1))
		   (fib (- n 2))))))
 the-global-environment)
(timed (lambda () (eval '(fib 20) the-global-environment)))

time expended: 3.21
;Value: 6765

With analysis, we halved the time it takes. Quite impressive isn't it?

For curiosity, let we run also the primitive evaluator of our Scheme!

(define (fib n)
    (cond ((= n 0) 0)
	  ((= n 1) 1)
	  (else (+ (fib (- n 1))
		   (fib (- n 2))))))

;Value: fib

(timed (lambda () (fib 20)))

time expended: .02999999999999936
;Value: 6765

Huge difference!

Compare the time spent by analysis versus by execution

Here is the previous fib procedure's:

(timed
 (lambda ()
   (repeat 1000 (lambda ()
		  (eval '(fib 2)
			the-global-environment)))))

time expended: .20000000000000018
;Value: done

And that of simple execution:

(timed
 (lambda ()
   (repeat 1000 (lambda ()
		  (eval '(fib 1)
			the-global-environment)))))

time expended: .07000000000000028
;Value: done

Or simple recursive execution:

(timed
 (lambda ()
   (repeat 1000 (lambda ()
		  (eval '(fib 2)
			the-global-environment)))))

time expended: .20000000000000018
;Value: done

Here we used repeat to measure the time otherwise unable to estimate:

(define (repeat n proc)
  (let loop ((k n))
    (if (> k 0)
	(begin (proc)
	       (loop (-1+ k)))
	'done)))

Or let us test the sequential statements:

;; Or those of sequential statements
(define test-sequential
  '(define (test-sequential)
     (define x 0)
     (set! x (1+ x))
     (set! x (1+ x))
     (set! x (1+ x))
     (set! x (1+ x))
     (set! x (1+ x))
     x))
;; analysis time
(timed (lambda () (repeat 1000 (lambda () (analyze test-sequential)))))

time expended: .08999999999999986
;Value: done

;; execution time
(eval test-sequential the-global-environment)
(timed (lambda ()
	 (repeat 1000 (lambda ()
			(eval '(test-sequential) the-global-environment)))))

time expended: .17000000000000015
;Value: done

Variations on a Scheme – Lazy Evaluation

Normal Order and Applicative Order

Exercise 4.25

It will falls into infinite loop since what ever argument we hand over, it
should call itself with different argument to pass the unless procedure as
parameter – as our underlying Scheme evaluate in applicative order, evaluator
first evaluate the operands of application of compound procedure and then apply.

And yes, our procedure will work in normal-order language since in normal-order
language, expressions only got evaluated when the expression is operation in
application or the operation part unwound into primitive procedure.

If we apply above discussion into our factorial application, it unwound into
application of unless, which in turn got into if expression that is special
form; by the rule of if evaluation, now the predicate part evaluated and
depending on that value, in turn, whether consequent part of alternative part
got evaluated and so on.
Exercise 4.26

Here is the unless as derived form:
```
(define (unless->if exp)
  (make-if (unless-pred exp)
	   (unless-alter exp)
	   (unless-conseq exp)))
(define unless-pred cadr)
(define unless-conseq caddr)
(define unless-alter cadddr)
```
Let us think the discussion using more simple example – not unless itself –
the and or or special form. It has the ability to be used as "short circuit" the
code. I couldn't count the number of times if I had or as non-special form so
that I can code up with higher order function like fold-right.

Back to the original question, we can think about the possibilities if we
allowed to use unless with combination of stream processing frame work. By
using that combination, we could code event driven system in functional
programming style as we use the unless to control the input stream.

Well, in any case, if we allowed to use unless not as special form, we can
pass that as argument of another higher order procedures; or as the value of
application.

An Interpreter with Lazy Evaluation

Exercise 4.27

The first <response> should be 1 and that of second <response> and third
would be 10 and 2 respectively since
1. The value expression of w is evaluated by eval-definition but as it's
  application of compound procedure, it will evaluate the body of given
  compound procedure with delayed arguments.
2. Since the first statement of the body is special form with application of
  primitive procedure, it will change the value of count from 0 to 1.
3. The last statement of that is variable, it will lookup in the extended
  environment and return the delayed value, that is the promise to evaluate
  (id 10) in that environment.
Here is the verification:
```
;;; L-Eval input:
(define count 0)

;;; L-Eval value:
ok

;;; L-Eval input:
(define (id x)
  (set! count (+ count 1))
  x)

;;; L-Eval value:
ok

;;; L-Eval input:
(define w (id (id 10)))

;;; L-Eval value:
ok

;;; L-Eval input:
count

;;; L-Eval value:
1

;;; L-Eval input:
w

;;; L-Eval value:
10

;;; L-Eval input:
count

;;; L-Eval value:
2
```
Exercise 4.28

The example should be the case where the evaluated value is thunk and then it
used as operator in combination.

Generally, we need this extra complexity for dealing with the case where the
expression is itself result of combination of applying compound procedure where
it participate as argument.

We can deduce this using the previous exercise as example. Observe that in the
previous exercise that the arguments in the application (of compound procedure)
are made thunk by list-of-delayed-args. By using this observation, we can make
the situation where satisfy the property outlined above:
```
(((lambda (x) x) +) 2 4)
```
Then verification:
```
(thunk? (eval '((lambda (x) x) +) the-global-environment))

;Value: #t
```
So we need the actual-value to get the value, which in turn applied to given
operands:
```
(thunk? (actual-value '((lambda (x) x) +) the-global-environment))

;Value: #f
```
Exercise 4.29

The good example of such program should exhibit the situation where some object
evaluated more than once; so
```
(factorial (factorial 20))
```
would make huge difference between with memoization and without that.

And for the second question, we can reason about this as follows:
- For with memoization:
  1. Evaluate (square (id 10)), which in turn
  2. extend the environment with binding x: (thunk (id 10) env)
    and evaluate (* x1 x2) (here we used x1 and x2 instead x since
    we need to take the time when we accessed to that variable since
    memoization introduce assignment implicitly);
  3. force x₁, which in turn evaluate (id 10); it leads to set count to
    be 1 and in the environment set x to be evaluated thunk with value 10;
  4. force x₂, which already evaluated by force x₁, so it just return 10;
  5. returned to (* x1 x2), as now the values are obtained, it return 100 as
    final value.
- For without memoization:
  1. Evaluate (square (id 10)), which in turn
  2. extend the environment with binding x: (thunk (id 10) env)
    and evaluate (* x1 x2);
  3. force x₁, which in turn evaluate (id 10); it leads to set count to
    be 1;
  4. force x₂, which in turn evaluate (id 10); it leads to set count to
    be 2;
  5. returned to (* x1 x2), as now the values are obtained, it return 100 as
    final value.
So the first response is same in both as 100; the second are 1, 2 in with
memoization and without that respectively.
Exercise 4.30
- a.
  
  Since
  - as this is application of compound procedure;
  - it evaluate the body of for-each with delayed arguments;
  - in turn, if-predicate force items to be actual value;
  - by the first statement of begin of for-each is application so proc got
    forced;
  - it leads the body of proc evaluated with thunked (car items) – 57 in this
    example;
  - as all of the statement of proc is application of primitive procedures the
    argument, x, is forced and evaluated – 57 is displayed at this moment;
  - now another for-each is evaluated same as above since all the conditions are
    same for applying the above argument.
  By above argument all the statements in the sequence got forced.
- b.
  
  As we noted in ex 4.28, the thunked expression is not evaluated as value without
  forcing it – by actual-value –, in turn, user can thunk the expression only
  via application of compound procedure.
  
  So by applying this observation to the given Cy's examples with original
  eval-sequence, we got (p1 1) → (1 2) and (p2 1) → 1; since while the
  first does not involve any application of compound procedure; the second
  assignment thunked and that, in turn, evaluated without forcing it. But with
  Cy's modified version return (1 2) in both cases since now all the
  intermediate statement forced.
- c.
  
  Since already forced value can not be changed by additional force-it. As we
  noted in a. each statement of in the sequence already fully evaluated –
  forced, so the modification does not affect at all to that specific example.
- d.
  
  Whatever choice we made, the evaluation of sequence being made in unexpected or
  hard to be estimated time. It is totally due to the nature of normal-order
  evaluation rule: By choosing the normal-order evaluation, we decoupled the time
  when the expression got assembled from the time the expression actually got
  evaluated. However, using assignment, we are meant to control the "time"
  explicitly in the computer, that is when the evaluation is being carried out,
  which mirrored the real world. The time is "state." So those – the assignment
  and normal-order rule – are incompatible in themselves; we shouldn't expect to
  use sequence of expressions per se side-effects.

Exercise 4.31

We need to change list-of-delayed-args to encompass this new extension. And
also we need to change the force-it and add additional data structure that is
analogous to thunk – memo-thunk.

We decide thunk to represent the delayed object without memoized; memo-thunk
for delayed object with memoization.

Let us code what we designed using digital paper!

(define (apply procedure arguments env)
  (cond ((primitive-procedure? procedure)
	 (apply-primitive-procedure
	  procedure
	  (list-of-arg-values arguments env))) ; changed
	((compound-procedure? procedure)
	 (eval-sequence
	  (procedure-body procedure)
	  (let ((params (procedure-parameters procedure)))
	    (extend-environment
	     (map param-name params)
	     (list-if-delayed-args
	      arguments (map param-type params) env) ; changed
	     (procedure-environment procedure)))))
	(else
	 (error
	  "Unknown procedure type -- APPLY" procedure))))

;; param ADT
(define (typed-param? param)
  (and (pair? param)
       (pair? (cdr param))))
(define (param-type param)
  (if (typed-param? param)
      (cadr param)
      'strict))
(define (param-name param)
  (if (typed-param? param)
      (car param)
      param))

(define (list-if-delayed-args exps types env)
  (cond ((no-operands? exps) '())
	((null? types)
	 (error "the number of arguments do not agree with procedure"
		;; actually whether we should use more sophisticated error message
		;; or should delegate the error raise to extend-environment
		;; current error message is not informative enough to be useful.
		exps))
	(else
	 (cons
	  ((case (first types)
	     ((strict) actual-value)
	     ((lazy) delay-it)
	     ((lazy-memo) delay-memo-it)
	     (else (error "Unknown parameter type")))
	   (first-operand exps)
	   env)
	  (list-if-delayed-args (rest-operands exps)
				(cdr types)
				env)))))

;; memo-thunk ADT
(define (delay-memo-it exp env)
  (list 'memo-thunk exp env))
(define (memo-thunk? obj)
  (tagged-list? obj 'memo-thunk))

(define (force-it obj)
  (cond ((thunk? obj)
	 (actual-value (thunk-exp obj) (thunk-env obj)))
	((memo-thunk? obj)
	 (let ((result (actual-value
			(thunk-exp obj)
			(thunk-env obj))))
	   (set-car! obj 'evaluated-thunk)
	   (set-car! (cdr obj) result)  ; replace exp with its value
	   (set-cdr! (cdr obj) '())     ; forget unneeded env
	   result))
	((evaluated-thunk? obj)
	 (thunk-value obj))
	(else obj)))

Then test! Here we use ex 4.29 for test:

;;; L-Eval input:
(define count 0)

;;; L-Eval value:
ok

;;; L-Eval input:
(define count-memo 0)

;;; L-Eval value:
ok

;;; L-Eval input:
(define (id-memo (x lazy-memo))
  (set! count-memo (+ count-memo 1))
  x)

;;; L-Eval value:
ok

;;; L-Eval input:
(define (id-lazy (x lazy))
  (set! count (+ count 1))
  x)

;;; L-Eval value:
ok

;;; L-Eval input:
(define (square-memo (x lazy-memo))
  (* x x))

;;; L-Eval value:
ok

;;; L-Eval input:
(define (square-lazy (x lazy))
  (* x x))

;;; L-Eval value:
ok

;;; L-Eval input:
(square-memo (id-memo 10))

;;; L-Eval value:
100

;;; L-Eval input:
count-memo

;;; L-Eval value:
1

;;; L-Eval input:
(square-lazy (id-lazy 10))

;;; L-Eval value:
100

;;; L-Eval input:
count

;;; L-Eval value:
2

Works!

Exercise 4.32

Now we can construct reversed stream, that is, we use car to traverse and
cdr to store elements. With this extra concept combined with original stream,
we can now manipulate line not only ray! – what we defined as integers in
stream was actually just natural numbers not integers, strictly speaking. More
over, we can manipulate tree operations lazily as well as list structure. So
until this point, to manipulate tree in combination with stream, we needed to
first construct whole tree strictly and then convert that into stream. If we
represent the graph in lazy tree structure, conceptually it equivalent to the
non-deterministic programming, which decomposed automatic search from
computation. We can think this differently: By allowed to manipulate not only
future – cdr part – but also past – car part; so we can now traverse the
time branches back and forth freely.

Exercise 4.33

The reason it produce an error is as follows:

Quoted expression processed by the read procedure, by which we get the
input from terminal, of underlying Lisp language; it is "list" in
implementation language not that in language being implemented.
So we need transform from list structure of implementation language into that
of language being implemented.

Here is the code do the right thing:

(define (list->list lst)
  (fold-right (lambda (item ->list)
		`(cons ,item ,->list))
	      '(quote ())
	      lst))
(define (text-of-quotation exp)
  (let ((contents (cadr exp)))
    (if (list? contents)
	(eval (list->list contents) the-global-environment)
	contents)))

Then let's test!

;;; setup
(eval cons-def the-global-environment)
(eval car-def the-global-environment)
(eval cdr-def the-global-environment)
;;; test quotation
(actual-value '(car '(a b c)) the-global-environment)
�
;Quit!

Unfortunately, it doesn't return the control! It turns out due to the test
list? since

(list? '())

;Value: #t

So

(actual-value '(quote ()) the-global-environment)
�
;Quit!

runs forever!

Fix the procedure as

(define (text-of-quotation exp)
  (let ((contents (cadr exp)))
    (if (and (not (null? contents))
	     (list? contents))
	(eval (list->list contents) the-global-environment)
	contents)))

Then re-run:

(actual-value '(car '(a b c)) the-global-environment)

;Unbound variable a

Now the problem is that list->list does not quote the element! Let's fix:

(define (list->list lst)
  (fold-right (lambda (item ->list)
		`(cons ',item ,->list))
	      '(quote ())
	      lst))

Now it produces right result:

(actual-value '(car '(a b c)) the-global-environment)

;Value: a

Exercise 4.34

To print the pair, we need to recognize whether given object is pair by pair?
We can exploit the message passing paradigm:

Then (define (pair? x) (x 'pair?))
This will work if we request only to pair object; but predicate meant to
check whether given argument satisfy specific condition. So predicate should
not signal error unless it provided certain condition should be satisfied but
violated by user (although it is not appropriate to assume informal
contraction without verification).
So we'd better to take another way: Make cons, car, cdr non-strict
primitive procedure; by including pair? as primitive (strict) procedure, we
got what we wanted.

So we need to modify apply to cope with primitive non-strict application, and
the new syntax procedure for non-strict primitive procedures, finally the
setup-environment:

 (define (apply procedure arguments env)
  (cond ((primitive-procedure? procedure) ;strict primitive
	 (apply-primitive-procedure
	  procedure
	  (list-of-arg-values arguments env)))
	((non-strict-primitive-procedure? procedure) ;non-strict primitive
	 (apply-primitive-procedure
	  procedure
	  (list-of-delayed-args arguments env)))
	((compound-procedure? procedure)
	 (eval-sequence
	  (procedure-body procedure)
	  (extend-environment
	   (procedure-parameters procedure)
	   (list-of-delayed-args arguments env)
	   (procedure-environment procedure))))
	(else
	 (error
	  "Unknown procedure type -- APPLY" procedure))))

(define (non-strict-primitive-procedure? proc)
  (tagged-list? proc 'non-strict))

(define (non-strict-procedure-names)
  (map car
       non-strict-procedures))

(define (non-strict-procedure-objects)
  (map (lambda (proc) (list 'non-strict (cadr proc)))
       non-strict-procedures))

(define (setup-environment)
  (let ((initial-env
	 (extend-environment
	  (non-strict-procedure-names)
	  (non-strict-procedure-objects)
	  (extend-environment (primitive-procedure-names)
			      (primitive-procedure-objects)
			      the-empty-environment))))
    (define-variable! 'true true initial-env)
    (define-variable! 'false false initial-env)
    initial-env))
;; initialize the startup environment
(define primitive-procedures
  (append (list
	   (list 'pair? (lambda (p) (tagged-list? p 'pair)))
	   (list 'car cadr)
	   (list 'cdr cddr))
	  primitive-procedures))

(define non-strict-procedures
  `((cons ,(lambda (x y) (cons 'pair (cons x y))))))

We need to make pair as tagged list to discern with other data structure. Also
note that we made only cons non-strict; but not the car and cdr since
there is no need to make those non-strict and further more, if we make them so,
it only make the implementation complicate to select the part appropriately! You
need to reason this by experimenting with non-strict car and cdr.

Then test!

(actual-value '(car (cons 2 4)) the-global-environment)

;Value: 2

(thunk? (eval '(car (cons 2 4)) the-global-environment))

;Value: #t

(eval '(pair? (cons 2 4)) the-global-environment)

;Value: #t

Now we return to display the lazy pair appropriately. Here we used structural
induction on object. For the pair object, we also used induction on depth
combined with structural induction on o2. Finally for the choice of
representation of thunk, we took that of stream:

(define (represent-object o)
  (cond ((compound-procedure? o)
	 (list 'compound-procedure
		     (procedure-parameters o)
		     (procedure-body o)
		     '<procedure-env>))
	((thunk? o)
	 '...)
	((evaluated-thunk? o)
	 (represent-object (thunk-value o)))
	((tagged-list? o 'pair)
	 (represent-pair (cdr o)))
	(else o)))

(define (represent-pair p)
  (let ((rep1 (represent-object (car p))) ;induction on depth
	(o2 (cdr p)))
    (cond ((thunk? o2)
	   (list rep1 (represent-object o2)))
	  ((evaluated-thunk? o2)
	   (cons rep1 (represent-object o2)))
	  ((tagged-list? o2 'pair)
	   (cons rep1 (represent-pair (cdr o2))))
	  (else                         ;atomic value
	   (cons rep1 (represent-object o2))))))

Then modify user-print as follows:

(define (user-print object)
  (display (represent-object object)))

Then test:

;;; L-Eval input:
(define test-display (cons ((lambda (x) (+ 2 x)) 3) (cons 2 '())))

;;; L-Eval value:
ok

;;; L-Eval input:
test-display

;;; L-Eval value:
(... ...)

;;; L-Eval input:
(car (cdr test-display))

;;; L-Eval value:
2

;;; L-Eval input:
test-display

;;; L-Eval value:
(... 2 ...)

;;; L-Eval input:
(cdr (cdr test-display))

;;; L-Eval value:
()

;;; L-Eval input:
test-display

;;; L-Eval value:
(... 2)

;;; L-Eval input:
(car test-display)

;;; L-Eval value:
5

;;; L-Eval input:
test-display

;;; L-Eval value:
(5 2)

For the completeness, here I add to user-print additional feature, detect the
shared structure in lazy pair:

(define (pair?* o) (tagged-list? o 'pair))
(define car* cadr)
(define cdr* cddr)

(define (extract-sharings object)
  (let ((tracked '())
	(sharings '()))
    (define scan
      (lambda (o)
	(define (mutate-list! o not-tracked-op)
	  (if (memq o tracked)
	      (if (not (memq o sharings))
		  (set! sharings (cons o sharings))
		  'done)
	      (begin (set! tracked (cons o tracked))
		     (not-tracked-op o))))
	(cond ((evaluated-thunk? o)
	       (scan (thunk-value o)))
	      ((pair?* o)
	       (mutate-list!
		o (lambda (o)
		    (scan (car* o))
		    (scan (cdr* o))))))))
    (scan object)
    sharings))

(define (display-entry object)
  (let ((sharings (extract-sharings object))
	(issue-table '(*issue*)))       ;hash-table won't work!
    (define (issued-number o)
      (cond ((assq o (cdr issue-table)) => cadr)
	    (else #f)))
    (define issue!
      (let ((id 0))                     ;identification number
	(lambda (o)
	  (let ((to-be-issued id))
	    (set-cdr! issue-table (cons (list o to-be-issued)
					(cdr issue-table)))
	    (set! id (1+ id))
	    to-be-issued))))
    (define (display-issued-object id)
      (display "#")
      (display id)
      (display "#"))
    (define (display-issuing id)
      (display "#")
      (display id)
      (display "="))
    (define (display-object o)
      (cond ((compound-procedure? o)
	     (display (list 'compound-procedure
			    (procedure-parameters o)
			    (procedure-body o)
			    '<procedure-env>)))
	    ((thunk? o)
	     (display '...))
	    ((evaluated-thunk? o)
	     (display-object (thunk-value o)))
	    ((pair?* o)
	     (display-pair o))
	    (else (display o))))
    (define (display-pair p)
      (define (display-pair-entry p)
	(display "(")
	(display-object (car* p))
	(display-iter (cdr* p))
	(display ")"))
      (define (display-shared-or-default exp default-op pad1-op pad2-op)
	(if (memq exp sharings)         ;it is shared structure
	    (let ((id (issued-number exp)))
	      (if id
		  (begin (pad1-op)
			 (display-issued-object id))
		  (begin (pad2-op)
			 (display-issuing (issue! exp))
			 (display-pair-entry exp))))
	    (default-op exp)))
      (define (display-iter exp)
	(cond ((null? exp))
	      ((evaluated-thunk? exp)
	       (display-iter (thunk-value exp)))
	      ((pair?* exp)
	       (display-shared-or-default
		exp
		(lambda (p)
		  (display " ")
		  (display-object (car* p))
		  (display-iter (cdr* p)))
		(lambda () (display " . "))
		(lambda () (display " "))))
	      ((thunk? exp)
	       (display " ")
	       (display-object exp))
	      (else
	       (display " . ")
	       (display-object exp))))
      (display-shared-or-default
       p (lambda (p) (display-pair-entry p))
       (lambda () 'ignore)
       (lambda () 'ignore)))
    (display-object object)
    (set-cdr! issue-table '())))        ;clear the cached

Then our user-print became

(define (user-print object)
  ;; (display (represent-object object))
  (display-entry object))

Then test code:

;;; L-Eval input:
(define ones (cons 1 ones))

;;; L-Eval value:
ok

;;; L-Eval input:
ones

;;; L-Eval value:
(... ...)

;;; L-Eval input:
(car ones)

;;; L-Eval value:
1

;;; L-Eval input:
(cdr ones)

;;; L-Eval value:
#0=(1 . #0#)

;;; L-Eval input:
(define one (cons 1 two))               ;mutual recursive definition

;;; L-Eval value:
ok

;;; L-Eval input:
(define two (cons 2 one))

;;; L-Eval value:
ok

;;; L-Eval input:
(car one)

;;; L-Eval value:
1

;;; L-Eval input:
(cdr one)

;;; L-Eval value:
(... ...)

;;; L-Eval input:
(car two)

;;; L-Eval value:
2

;;; L-Eval input:
(cdr two)

;;; L-Eval value:
#0=(1 2 . #0#)

;;; L-Eval input:
one

;;; L-Eval value:
#0=(1 2 . #0#)

;;; L-Eval input:
two

;;; L-Eval value:
#0=(2 1 . #0#)

Variations on a Scheme – Nondeterministic Computing

Amb and Search

Exercise 4.35

Note that this procedure should behave similar with an-element-of:

(define (an-integer-between low high)
  (require (<= low high))
  (amb low (an-integer-between (1+ low) high)))

Then here is the test:

;;; Amb-Eval input:
(an-integer-between 1 10)

;;; Starting a new problem
;;; Amb-Eval value:
1

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
2

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
3

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
4

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
5

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
6

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
7

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
8

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
9

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
10

;;; Amb-Eval input:
try-again

;;; There are no more values of
(an-integer-between 1 10)

Exercise 4.36

The specified idea coded as
```
(define (a-pythagorean-triple-from low high)
     (let ((i (an-integer-starting-from low)))
       (let ((j (an-integer-starting-from i)))
	 (let ((k (an-integer-starting-from j)))
	   (require (= (+ (* i i) (* j j)) (* k k)))
	   (list i j k)))))
```
Unfortunately the last let expression doesn't end; it tries all the integers
higher than j. So it will never tries other than i equals low, j equals low.

So we need to constrain k using following rules – the triangle inequality:
- i²+j² ≥ k² ⇔ i+j > k for i,j ≥ 1
This also would not work since now i is fixed to low; this kind problem is
exactly same as before, when we tried to produce stream of pairs from two
input streams. We need to ensure arbitrary element should appear in the
resulting stream after finite number of cdr ing down.

Can we fix current problem using the analogous strategy from stream's? Or can we
come up with nondeterminism specific algorithm?

Here we try the latter approach using the observation from
a-pythagorean-triple-between; in that procedure, it uses strategy of
elimination – at any stage of computation, it removes the cases where i lower
than current i, e.g. if it started from low = 2 and current i is 4 then
it is provided that every case where low ≤ i ≤ 4; similar argument
applied to j and k –, we can apply that strategy to this problem as k to
be the first stage of computation.

Here is the code:
```
(define (a-pythagorean-triple-from low)
     (let ((k (an-integer-starting-from low)))
       (let ((i (an-integer-between low k)))
	 (let ((j (an-integer-between i k)))
	   (require (= (+ (* i i) (* j j)) (* k k)))
	   (list i j k)))))
```
And test:
```
;;; Amb-Eval input:
(a-pythagorean-triple-from 1)

;;; Starting a new problem
;;; Amb-Eval value:
(3 4 5)

...

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(12 16 20)

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(7 24 25)
```
From this exercise, we learned our amb evaluator can be thought of as
generator in python as long as it traverse the choice tree in depth-first.
So until now, amb evaluator allowed us to loop over infinite range, like
stream allowed to process infinite list. Is this observation is general enough
to characterize amb evaluator? To answer with this question, we need to
explore following examples with this mind.
Exercise 4.37

Yes since the number of cases to try out is different in asymptotic complexity.

The former one is Θ(n³) and this one is Θ(n²), where n is the
number of element in the given range – [low, high].

So as long as same in both are asymptotic complexities of computation in each
step.

The difference in computation of both is the use of sqrt. From this
source, sqrt's complexity same as the multiplication.

So consequently this Ben's version is efficient in asymptotic order.

Examples of Nondeterministic Programs

Exercise 4.38

Here is the result:

;;; Amb-Eval input:
(multiple-dwelling)

;;; Starting a new problem
;;; Amb-Eval value:
((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
((baker 1) (cooper 2) (fletcher 4) (miller 5) (smith 3))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
((baker 1) (cooper 4) (fletcher 2) (miller 5) (smith 3))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
((baker 3) (cooper 4) (fletcher 2) (miller 5) (smith 1))

;;; Amb-Eval input:
try-again

;;; There are no more values of
(multiple-dwelling)

So, 4 more answers!

Exercise 4.39

Yes, it matter. We can manage to reduce the average number of tests to get aborted or
succeed. Let we think about the possibilities that each branches passes the
specific requirement. Then reorder the restrictions in the increasing order
of this "weight." After that, we obtain minimum number of tests needed to get answer.

Here is the reordering:

(define (multiple-dwelling)
  (let ((baker (amb 1 2 3 4 5))
	(cooper (amb 1 2 3 4 5))
	(fletcher (amb 1 2 3 4 5))
	(miller (amb 1 2 3 4 5))
	(smith (amb 1 2 3 4 5)))
    (require
     (distinct? (list baker cooper fletcher miller smith)))
    (require (> miller cooper))
    (require (not (= (abs (- smith fletcher)) 1)))
    (require (not (= (abs (- fletcher cooper)) 1)))
    (require (not (= baker 5)))
    (require (not (= cooper 1)))
    (require (not (= fletcher 5)))
    (require (not (= fletcher 1)))
    (list (list 'baker baker)
	  (list 'cooper cooper)
	  (list 'fletcher fletcher)
	  (list 'miller miller)
	  (list 'smith smith))))

Then compare the time consumed:

;; original version
(timed (lambda ()
	 (ambeval '(multiple-dwelling) the-global-environment
		  (lambda (val fail) val) (lambda () 'ignore))))

time expended: .86
;Value: ((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))

;;modified definition
(timed (lambda ()
	 (ambeval '(multiple-dwelling-modified) the-global-environment
		  (lambda (val fail) val) (lambda () 'ignore))))

time expended: .77
;Value: ((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))

Exercise 4.40

Like we did when we transit from list processing to stream processing, let we
interleave construction with filtering along with the criterion as before –
ordering the requirement in "weight".

Let we first inspect the result and then discuss what caused that difference.

Here is the code:

(define (multiple-dwelling-optimized)
     (let ((fletcher (amb 1 2 3 4 5)))
       (require (not (= fletcher 5)))
       (require (not (= fletcher 1)))
       (let ((cooper (amb 1 2 3 4 5)))
	 (require (not (= cooper 1)))
	 (require (not (= (abs (- fletcher cooper)) 1)))
	 (let ((miller (amb 1 2 3 4 5)))
	   (require (> miller cooper))
	   (let ((baker (amb 1 2 3 4 5)))
	     (require (not (= baker 5)))
	     (let ((smith (amb 1 2 3 4 5)))
	       (require (not (= (abs (- smith fletcher)) 1)))
	       (require
		(distinct? (list baker cooper fletcher miller smith)))
	       (list (list 'baker baker)
		     (list 'cooper cooper)
		     (list 'fletcher fletcher)
		     (list 'miller miller)
		     (list 'smith smith))))))))

Then compare the time it consumed!

(timed (lambda ()
	 (ambeval '(multiple-dwelling-optimized) the-global-environment
		  (lambda (val fail) val) (lambda () 'ignore))))

time expended: .14000000000000057
;Value: ((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))

Huge improvement! We could make this optimization since we made that in each
filtering step the difference of the number of branches, between before and after that
step, minimum. As the number of remaining branches should be only one, it means
we traverse the minimum number of branches at the very beginning.

Exercise 4.41

As we noted before, the amb evaluator has a lot of analogy with programming
with iterative process. So here we implement requested task using loop.

The typical imperative style coding:

(define (multiple-dwelling)
  (let baker-loop ((baker 1))
    (let cooper-loop ((cooper 1))
      (let fletcher-loop ((fletcher 1))
	(let miller-loop ((miller 1))
	  (let smith-loop ((smith 1))
	    (if (and (distinct? (list baker cooper fletcher miller smith))
		     (not (= baker 5))
		     (not (= cooper 1))
		     (not (= fletcher 5))
		     (not (= fletcher 1))
		     (> miller cooper)
		     (not (= (abs (- smith fletcher)) 1))
		     (not (= (abs (- fletcher cooper)) 1)))
		(list (list 'baker baker)
		      (list 'cooper cooper)
		      (list 'fletcher fletcher)
		      (list 'miller miller)
		      (list 'smith smith))
		(cond ((< smith 5) (smith-loop (1+ smith)))
		      ((< miller 5) (miller-loop (1+ miller)))
		      ((< fletcher 5) (fletcher-loop (1+ fletcher)))
		      ((< cooper 5) (cooper-loop (1+ cooper)))
		      ((< baker 5) (baker-loop (1+ baker)))
		      (else 'failed!)))))))))

Then test:

(multiple-dwelling)

;Value: ((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))

Just for curiosity, here we also implement the functional version – stream
version:

(define (multiple-dwelling-stream)
  (stream-filter
   (lambda (result) result)
   (stream-append-map
    (lambda (baker)
      (stream-append-map
       (lambda (cooper)
	 (stream-append-map
	  (lambda (fletcher)
	    (stream-append-map
	     (lambda (miller)
	       (stream-map
		(lambda (smith)
		  (and (distinct? (list baker cooper fletcher miller smith))
		       (not (= baker 5))
		       (not (= cooper 1))
		       (not (= fletcher 5))
		       (not (= fletcher 1))
		       (> miller cooper)
		       (not (= (abs (- smith fletcher)) 1))
		       (not (= (abs (- fletcher cooper)) 1))
		       (list (list 'baker baker) ;return if all the previous test passed
			     (list 'cooper cooper)
			     (list 'fletcher fletcher)
			     (list 'miller miller)
			     (list 'smith smith))))
		(stream-enumerate-interval 1 5)))
	     (stream-enumerate-interval 1 5)))
	  (stream-enumerate-interval 1 5)))
       (stream-enumerate-interval 1 5)))
    (stream-enumerate-interval 1 5))))

Actually this pattern appears frequently when we try to emulate loop in
functional world! So in Scala, by default, for loop desugared into above
flat-map map combination.

Test!

(multiple-dwelling-stream)

;Value: {((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)) ...}

Exercise 4.42

It is just brain stretching exercise:

(define (either p1 p2)
  (or (and p1 (not p2))
      (and (not p1) p2)))

(define (solve-Liars)
  (let ((Betty (amb 1 2 3 4 5))
	(Ethel (amb 1 2 3 4 5))
	(Joan (amb 1 2 3 4 5))
	(Kitty (amb 1 2 3 4 5))
	(Mary (amb 1 2 3 4 5)))
    (require (distinct? (list Kitty Betty Ethel Joan Mary)))
    (require (either (= Kitty 2) (= Betty 3)))
    (require (either (= Ethel 1) (= Joan 2)))
    (require (either (= Joan 3) (= Ethel 5)))
    (require (either (= Kitty 2) (= Mary 4)))
    (require (either (= Mary 4) (= Betty 1)))
    (list (list 'Betty Betty)
	  (list 'Ethel Ethel)
	  (list 'Joan Joan)
	  (list 'Kitty Kitty)
	  (list 'Mary Mary))))

;;; Amb-Eval input:
(solve-Liars)

;;; Starting a new problem
;;; Amb-Eval value:
((betty 3) (ethel 5) (joan 2) (kitty 1) (mary 4))

;;; Amb-Eval input:
try-again

;;; There are no more values of
(solve-liars)

To support or and and, using which we defined either, we need to modify
our analyzer:

*** in analyze
	((and? exp) (analyze (and->transformed exp)))
	((or? exp) (analyze (or->transformed exp)))

For the implementation of those transformation please visit my other project.

Exercise 4.43

As our amb evaluator does not support the multi-directional computation, we
need to capture the relationship in one direction. After some experiment, I've
come to realize that let the fathers has a daughter and a yacht would make
our task concise.

Here is (inefficient but) concise problem definition:

(define (solve-daughter-and-yacht)
  ;; underlying relation ADT
  (define yacht cdr)
  (define daughter car)
  (define has-daughter-and-yacht cons)
  (define (has-daughter? father daugh)
    (eq? (daughter father) daugh))
  (define (has-yacht? owner yac)
    (eq? (yacht owner) yac))
  (define (assign-daughter-and-yachts daughters yachts)
    (has-daughter-and-yacht (an-element-of daughters)
			    (an-element-of yachts)))
  (let ((daughters '(Mary Lorna Rosalind Gabrielle Melissa)))
    (let ((yachts daughters))
      (let ((moore (assign-daughter-and-yachts daughters yachts))
	    (hall (assign-daughter-and-yachts daughters yachts))
	    (barnacle (assign-daughter-and-yachts daughters yachts))
	    (parker (assign-daughter-and-yachts daughters yachts))
	    (colonel (assign-daughter-and-yachts daughters yachts)))
	(require (has-daughter? moore 'Mary))
	(require (has-yacht? moore 'Lorna))
	(require (has-yacht? hall 'Rosalind))
	(require (has-yacht? barnacle 'Gabrielle))
	(require (has-daughter? barnacle 'Melissa))
	(require (has-yacht? colonel 'Melissa))
	(let ((Gabrielle-father (amb moore hall barnacle parker colonel)))
	  (require (has-daughter? Gabrielle-father 'Gabrielle)
		   (has-yacht? Gabrielle-father (daughter parker))))
	(list (list 'Moore moore)
	      (list 'Hall hall)
	      (list 'Barnacle barnacle)
	      (list 'Parker parker)
	      (list 'Colonel colonel))))))

Yet, this won't work; more precisely, it is hard to wait until it spit the answer.

So let's optimize as we did before:

(define (solve-daughter-and-yacht)
  ;; underlying relation ADT
  (define yacht cdr)
  (define daughter car)
  (define has-daughter-and-yacht cons)
  (define (has-daughter? father daugh)
    (eq? (daughter father) daugh))
  (define (has-yacht? owner yac)
    (eq? (yacht owner) yac))
  (define (assign-daughter-and-yachts daughters yachts)
    (has-daughter-and-yacht (an-element-of daughters)
			    (an-element-of yachts)))
  (let ((daughters '(Mary Lorna Rosalind Gabrielle Melissa)))
    (let ((yachts daughters))
      (let ((moore (assign-daughter-and-yachts daughters yachts)))
	(require (has-daughter? moore 'Mary))
	(require (has-yacht? moore 'Lorna))
	(let ((barnacle (assign-daughter-and-yachts daughters yachts)))
	  (require (has-yacht? barnacle 'Gabrielle))
	  (require (has-daughter? barnacle 'Melissa))
	  (let ((hall (assign-daughter-and-yachts daughters yachts)))
	    (require (has-yacht? hall 'Rosalind))
	    (let ((colonel (assign-daughter-and-yachts daughters yachts)))
	      (require (has-yacht? colonel 'Melissa))
	      (let ((parker (assign-daughter-and-yachts daughters yachts)))
		(let ((fathers (list moore barnacle hall colonel parker)))
		  (require (distinct? (map daughter fathers)))
		  (require (distinct? (map yacht fathers)))
		  (let ((Gabrielle-father (an-element-of fathers)))
		    (require (has-daughter? Gabrielle-father 'Gabrielle))
		    (require (has-yacht? Gabrielle-father (daughter parker))))
		  (list (list 'Moore moore)
			(list 'Hall hall)
			(list 'Barnacle barnacle)
			(list 'Parker parker)
			(list 'Colonel colonel)))))))))))

Then now it response.

;;; Amb-Eval input:
(solve-daughter-and-yacht)

;;; Starting a new problem
;;; Amb-Eval value:
((moore (mary . lorna)) (hall (gabrielle . rosalind)) (barnacle (melissa . gabrielle)) (parker (rosalind . mary)) (colonel (lorna . melissa)))

;;; Amb-Eval input:
try-again

;;; There are no more values of
(solve-daughter-and-yacht)

So Lorna's father is Colonel Downing.

Exercise 4.44

Here is the straight forward transformation:

(define (solve-queens board-size)
  (define empty-board '())
  (define (adjoin-position new-row rest-of-queens)
    (cons new-row rest-of-queens))
  (define (safe? positions)
    (define (not-equal-to? nr rest)
      (or (null? rest)
	  (and (not (= nr (car rest)))
	       (not-equal-to? nr (cdr rest)))))
    (define (pm-i-not-equal-to? nr i rest)
      (or (null? rest)
	  (and (not (or (= (+ nr i) (car rest))
			(= (- nr i) (car rest))))
	       (pm-i-not-equal-to? nr (1+ i) (cdr rest)))))
    (let ((new-row (car positions))
	  (rest-queens (cdr positions)))
      (and (not-equal-to? new-row rest-queens) ;provided that positions not empty
	   (pm-i-not-equal-to? new-row 1 rest-queens))))
  (define (queens-cols k)
    (if (= k 0)
	empty-board
	(let ((positions
	       (adjoin-position
		(an-integer-between 1 board-size)
		(queens-cols (- k 1)))))
	  (require (safe? positions))
	  positions)))
  (queens-cols board-size))

It works

;;; Amb-Eval input:
(solve-queens 6)

;;; Starting a new problem
;;; Amb-Eval value:
(2 4 6 1 3 5)

Unfortunately, this algorithm in nondeterministic programming is way too slow.
It is due to the order of recursive calling and branching:

(define (solve-queens board-size)
...
  (define (queens-cols k)
    (if (= k 0)
	empty-board
	(let ((rest-queens (queens-cols (- k 1)))) ;the only change
	  (let ((positions (adjoin-position
			    (an-integer-between 1 board-size)
			    rest-queens)))
	    (require (safe? positions))
	    positions))))
  (queens-cols board-size))

By forcing the recursion before branching – an-integer-between – our program
got way more fast:

;;; Amb-Eval input:
(solve-queens 10)

;;; Starting a new problem
;;; Amb-Eval value:
(7 4 2 9 5 10 8 6 3 1)

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(8 5 2 4 10 7 9 6 3 1)

Conclusion: Computation order impact hugely on efficiency!

Exercise 4.45

Input and output:

(parse '(The professor lectures to the student in the class with the cat))

;; output
(sentence
 (simple-noun-phrase (article the) (noun professor))
 (verb-phrase
  (verb-phrase (verb-phrase (verb lectures) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun student)))) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))
  (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))

(sentence
 (simple-noun-phrase (article the) (noun professor))
 (verb-phrase (verb-phrase (verb lectures) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun student))))
	      (prep-phrase (prep in) (noun-phrase (simple-noun-phrase (article the) (noun class)) (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))

(sentence
 (simple-noun-phrase (article the) (noun professor))
 (verb-phrase
  (verb-phrase (verb lectures) (prep-phrase (prep to) (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))))
  (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))

(sentence
 (simple-noun-phrase (article the) (noun professor))
 (verb-phrase
  (verb lectures)
  (prep-phrase
   (prep to)
   (noun-phrase (noun-phrase (simple-noun-phrase (article the) (noun student)) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))
		(prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))

(sentence
 (simple-noun-phrase (article the) (noun professor))
 (verb-phrase
  (verb lectures)
  (prep-phrase
   (prep to)
   (noun-phrase (simple-noun-phrase (article the) (noun student))
		(prep-phrase (prep in) (noun-phrase (simple-noun-phrase (article the) (noun class)) (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))))

Interpretation:

First output means "the professor is with the cat" and "lectures in the class"
to student.
Second means the professor is in "the class with the cat" and lectures to student.
Third means "the professor is with the cat" and lectures to "student in the class."
Forth means the professor lectures to "student in the class" with the cat.
Last means the professor lectures to student in "the class with the cat."

Exercise 4.46

Note that parse-prepositional-phrase and parse-noun-phrase procedure is
mutually recursive. If the evaluator evaluate in different order than now,
evaluating parse-prepositional-phrase leads to parse-noun-phrase without
consuming preposition and which in turn consume simple-noun-phrase and then
execute parse-prepositional-phrase. Which is not the one we wanted.
Exercise 4.47

This version did not store the checkered point; so as long as there is answer it
can consume it will work as expected. Otherwise, it falls into the infinite
loop. You can understand this situation easily by drawing the tree structure it
branches.

If we interchange the expression order, it even won't work if we try
(parse '(The professor)). It just run forever without spitting anything.

Exercise 4.48

Here we try to include the clause; now we can parse compound sentence. Here is
the design with the code:

(define subordinates '(subord when if))

;; Subordinate-clause := Subordinate + Sentence
(define (parse-subordinate-clause)
  (list 'subordinate-clause
	(parse-word subordinates)
	(parse-sentence)))

;; Setence := Simple-sentence | Sentence + Subordinate-clause
(define (parse-sentence)
  (define (maybe-extend sentence)
    (amb sentence
	 (maybe-extend (list 'compound-sentence
			     sentence
			     (parse-subordinate-clause)))))
  (maybe-extend (parse-simple-sentence)))

Then test:

;;; Amb-Eval input:
(parse '(the professor lectures to the student in the class when the cat eats))

;;; Starting a new problem
;;; Amb-Eval value:
(compound-sentence
 (simple-sentence
  (simple-noun-phrase (article the) (noun professor))
  (verb-phrase (verb-phrase (verb lectures) (prep-phrase (prep to) (simple-noun-phrase (article the) (noun student)))) (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class)))))
 (subordinate-clause (subord when) (simple-sentence (simple-noun-phrase (article the) (noun cat)) (verb eats))))

Exercise 4.49

To support generate we make following changes:

(define (parse-word word-list)
  ;; (require (not (null? *unparsed*)))
  ;; (require (memq (car *unparsed*) (cdr word-list)))
  (let ((found-word (an-element-of (cdr word-list))))
    ;; (set! *unparsed* (cdr *unparsed*))
    (list (car word-list) found-word)))

(define (generate)
  (parse '()))

Then test:

;;; Amb-Eval input:
(generate)

;;; Starting a new problem
;;; Amb-Eval value:
(simple-sentence (simple-noun-phrase (article the) (noun student)) (verb studies))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(compound-sentence (simple-sentence (simple-noun-phrase (article the) (noun student)) (verb studies))
		   (subordinate-clause (subord when) (simple-sentence (simple-noun-phrase (article the) (noun student)) (verb studies))))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(compound-sentence
 (compound-sentence (simple-sentence (simple-noun-phrase (article the) (noun student)) (verb studies))
		    (subordinate-clause (subord when) (simple-sentence (simple-noun-phrase (article the) (noun student)) (verb studies))))
 (subordinate-clause (subord when) (simple-sentence (simple-noun-phrase (article the) (noun student)) (verb studies))))

As implied, it is not interesting; just repeat the sentence "the student
studies" using the when subordinate adjunct.

Implementing the `Amb` Evaluator

Exercise 4.50

Here is the implementation. Design should be done in prior, in my case I've done
in my digital paper. And here is the resulting code:

;; ramb syntax procedure

(define (ramb? exp) (tagged-list? exp 'ramb))
(define ramb-choices amb-choices)

*** in analyze
	((ramb? exp) (analyze-ramb exp))

(define (analyze-ramb exp)
  (let ((cprocs (map analyze (amb-choices exp))))
    (lambda (env succeed fail)
      (define (try-rand choices)
	(let ((chosen (pick-random choices)))
	  (if chosen
	      (chosen
	       env succeed
	       (lambda ()
		 (try-rand (filter (lambda (choice) (not (eq? choice chosen)))
				   choices))))
		(fail))))
      (try-rand cprocs))))

Then here is modification:

(define (parse-word word-list)
  ;; (require (not (null? *unparsed*)))
  ;; (require (memq (car *unparsed*) (cdr word-list)))
  (let ((found-word (choose-randomly (cdr word-list))))
    ;; (set! *unparsed* (cdr *unparsed*))
    (list (car word-list) found-word)))

(define (choose-randomly lst)
  (require (not (null? lst)))
  (ramb (car lst) (choose-randomly (cdr lst))))

Then the result from generate:

;;; Amb-Eval input:
(generate)

;;; Starting a new problem
;;; Amb-Eval value:
(simple-sentence (simple-noun-phrase (article a) (noun professor)) (verb studies))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(compound-sentence (simple-sentence (simple-noun-phrase (article a) (noun professor)) (verb studies))
		   (subordinate-clause (subord if) (simple-sentence (simple-noun-phrase (article the) (noun cat)) (verb studies))))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(compound-sentence (compound-sentence (simple-sentence (simple-noun-phrase (article a) (noun professor)) (verb studies))
				      (subordinate-clause (subord if) (simple-sentence (simple-noun-phrase (article the) (noun cat)) (verb studies))))
		   (subordinate-clause (subord when) (simple-sentence (simple-noun-phrase (article the) (noun professor)) (verb studies))))

;;; Amb-Eval input:
(generate)

;;; Starting a new problem
;;; Amb-Eval value:
(simple-sentence (simple-noun-phrase (article the) (noun professor)) (verb sleeps))

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(compound-sentence (simple-sentence (simple-noun-phrase (article the) (noun professor)) (verb sleeps))
		   (subordinate-clause (subord when) (simple-sentence (simple-noun-phrase (article a) (noun cat)) (verb eats))))

Quite interesting!

Exercise 4.51

To make assignment permanently, we just remove the undo steps in
analyze-assignment:

(define (analyze-permanent-assignment exp)
  (let ((var (assignment-variable exp))
	(vproc (analyze (assignment-value exp))))
    (lambda (env succeed fail)
      (vproc env
	     (lambda (val fail2)
	       (set-variable-value! var val env)
	       (succeed 'ok fail2))
	     fail))))

Then detector (we just reuse the selectors from assignment):

(define (permanent-assignment? exp)
  (tagged-list? exp 'permanent-set!))

Then test!

;;; Amb-Eval input:

(define count 0)
(let ((x (an-element-of '(a b c)))
      (y (an-element-of '(a b c))))
  (permanent-set! count (+ count 1))
  (require (not (eq? x y)))
  (list x y count))

;;; Starting a new problem
;;; Amb-Eval value:
ok

;;; Amb-Eval input:

;;; Starting a new problem
;;; Amb-Eval value:
(a b 2)

;;; Amb-Eval input:
try-again

;;; Amb-Eval value:
(a c 3)

If we used set! instead permanent-set!, then the count always be 1 since
it set! after branching so the undoing step is done in prior of backtracking.

Exercise 4.52

You should design that is analogous to if:

(define (analyze-if-fail exp)
  (let ((try (analyze (if-fail-try exp)))
	(failed (analyze (if-fail-failed exp))))
    (lambda (env succeed fail)
      (try env succeed
	   (lambda () (failed env succeed fail))))))

(define (if-fail? exp) (tagged-list? exp 'if-fail))
(define (if-fail-try exp) (cadr exp))
(define (if-fail-failed exp) (caddr exp))

Then test:

;;; Amb-Eval input:
(if-fail (let ((x (an-element-of '(1 3 5))))
	   (require (even? x))
	   x)
	 'all-odd)

;;; Starting a new problem
;;; Amb-Eval value:
all-odd

;;; Amb-Eval input:
(if-fail (let ((x (an-element-of '(1 3 5 8))))
	   (require (even? x))
	   x)
	 'all-odd)

;;; Starting a new problem
;;; Amb-Eval value:
8

Exercise 4.53

The result would be the list of all the possible prime-sum-pair s! You can
reason this about by keeping track of the time tree it makes or it would be more
convicing that you see the result in your eyes:

;;; Amb-Eval input:
(let ((pairs '()))
  (if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
	     (permanent-set! pairs (cons p pairs))
	     (amb))
	   pairs))

;;; Starting a new problem
;;; Amb-Eval value:
((8 35) (3 110) (3 20))

Exercise 4.54

It is easy:

(define (require? exp) (tagged-list? exp 'require))
(define (require-predicate exp) (cadr exp))

(define (analyze-require exp)
  (let ((pproc (analyze (require-predicate exp))))
    (lambda (env succeed fail)
      (pproc env
	     (lambda (pred-value fail2)
	       (if (false? pred-value)
		   (fail2)
		   (succeed 'ok fail2)))
	     fail))))

Logic Programming

Deductive Information Retrieval

Exercise 4.55

a.

;;; Query input:
(supervisor ?x (Bitdiddle Ben))

;;; Query results:
(supervisor (tweakit lem e) (bitdiddle ben))
(supervisor (fect cy d) (bitdiddle ben))
(supervisor (hacker alyssa p) (bitdiddle ben))

b.

;;; Query input:
(job ?x (accounting . ?y))

;;; Query results:
(job (cratchet robert) (accounting scrivener))
(job (scrooge eben) (accounting chief accountant))

c.

;;; Query input:
(address ?x (Slumerville . ?rest))

;;; Query results:
(address (aull dewitt) (slumerville (onion square) 5))
(address (reasoner louis) (slumerville (pine tree road) 80))
(address (bitdiddle ben) (slumerville (ridge road) 10))

Exercise 4.56

a.

;;; Query input:
(and (supervisor ?person (Bitdiddle Ben))
     (address ?person ?where))

;;; Query results:
(and (supervisor (tweakit lem e) (bitdiddle ben))
     (address (tweakit lem e) (boston (bay state road) 22)))
(and (supervisor (fect cy d) (bitdiddle ben))
     (address (fect cy d) (cambridge (ames street) 3)))
(and (supervisor (hacker alyssa p) (bitdiddle ben))
     (address (hacker alyssa p) (cambridge (mass ave) 78)))

b.

;;; Query input:
(and (salary (Bitdiddle Ben) ?Ben-amount)
     (salary ?person ?amount)
     (lisp-value < ?amount ?Ben-amount))

;;; Query results:
(and (salary (bitdiddle ben) 60000)
     (salary (aull dewitt) 25000)
     (lisp-value < 25000 60000))
(and (salary (bitdiddle ben) 60000)
     (salary (cratchet robert) 18000)
     (lisp-value < 18000 60000))
(and (salary (bitdiddle ben) 60000)
     (salary (reasoner louis) 30000)
     (lisp-value < 30000 60000))
(and (salary (bitdiddle ben) 60000)
     (salary (tweakit lem e) 25000)
     (lisp-value < 25000 60000))
(and (salary (bitdiddle ben) 60000)
     (salary (fect cy d) 35000)
     (lisp-value < 35000 60000))
(and (salary (bitdiddle ben) 60000)
     (salary (hacker alyssa p) 40000)
     (lisp-value < 40000 60000))

c.

;;; Query input:
(and (supervisor ?person ?someone)
     (not (job ?someone (computer . ?any)))
     (job ?someone ?his-job))

;;; Query results:
(and (supervisor (aull dewitt) (warbucks oliver))
     (not (job (warbucks oliver) (computer . ?any)))
     (job (warbucks oliver) (administration big wheel)))
(and (supervisor (cratchet robert) (scrooge eben))
     (not (job (scrooge eben) (computer . ?any)))
     (job (scrooge eben) (accounting chief accountant)))
(and (supervisor (scrooge eben) (warbucks oliver))
     (not (job (warbucks oliver) (computer . ?any)))
     (job (warbucks oliver) (administration big wheel)))
(and (supervisor (bitdiddle ben) (warbucks oliver))
     (not (job (warbucks oliver) (computer . ?any)))
     (job (warbucks oliver) (administration big wheel)))

Exercise 4.57

(rule (can-be-replaced-by ?p1 ?p2)
      (and (job ?p1 ?job1) (job ?p2 ?job2)
	   (or (same ?job1 ?job2)
	       (can-do-job ?job2 ?job1))
	   (not (same ?p1 ?p2))))

a.

;;; Query input:
(can-be-replaced-by (Fect Cy D) ?whom)

;;; Query results:
(can-be-replaced-by (fect cy d) (bitdiddle ben))
(can-be-replaced-by (fect cy d) (hacker alyssa p))

b.

;;; Query input:
(and (can-be-replaced-by ?p1 ?p2)
     (salary ?p1 ?a1) (salary ?p2 ?a2)
     (lisp-value > ?a1 ?a2))

;;; Query results:
(and (can-be-replaced-by (warbucks oliver) (aull dewitt)) (salary (warbucks oliver) 150000) (salary (aull dewitt) 25000) (lisp-value > 150000 25000))
(and (can-be-replaced-by (hacker alyssa p) (fect cy d)) (salary (hacker alyssa p) 40000) (salary (fect cy d) 35000) (lisp-value > 40000 35000))

Exercise 4.58

Here is the definition:

(rule (big-shot ?p)
      (and (job ?p (?div . ?rest))
	   (not (and (supervisor ?p ?boss) ;not have a boss who work in the same division
		     (job ?boss (?div2 . ?rest2))
		     (same ?div ?div2)))))

Then test:

;;; Query input:
(big-shot ?who)

;;; Query results:
(big-shot (scrooge eben))
(big-shot (warbucks oliver))
(big-shot (bitdiddle ben))

Exercise 4.59

a.

;;; Query input:
(meeting ?division (Friday ?time))

;;; Query results:
(meeting administration (friday |1pm|))

b.

Here is the resulting code:

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

c.

;;; Query input:
(meeting-time (Hacker Alyssa P) (Wednesday ?time))

;;; Query results:
(meeting-time (hacker alyssa p) (wednesday |4pm|))
(meeting-time (hacker alyssa p) (wednesday |3pm|))

Exercise 4.60

Since the rule is symmetry: If (lives-near p1 p2) then also (lives-near p2 p1). To make the requested happen, we need query with non-symmetric relation
by imposing order in persons. The most canonical way of doing this is
lexicographical ordering:

(define (name<? s-lst1 s-lst2)
  (symbol<? (fold-right symbol-append '|| s-lst1)
	    (fold-right symbol-append '|| s-lst2)))

Then we can query as

;;; Query input:
(and (lives-near ?person-1 ?person-2) (lisp-value name<? ?person-1 ?person-2))

;;; Query results:
(and (lives-near (aull dewitt) (reasoner louis)) (lisp-value name<? (aull dewitt) (reasoner louis)))
(and (lives-near (aull dewitt) (bitdiddle ben)) (lisp-value name<? (aull dewitt) (bitdiddle ben)))
(and (lives-near (fect cy d) (hacker alyssa p)) (lisp-value name<? (fect cy d) (hacker alyssa p)))
(and (lives-near (bitdiddle ben) (reasoner louis)) (lisp-value name<? (bitdiddle ben) (reasoner louis)))

Exercise 4.61

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

would results in

?x = 1,		?y = (2 3)                  ;by applying base case
?x = (2 3),	?y = 4                      ;by applying recursive case and then base

And the

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

would spit out

?x = 2                                  ;by applying base case
?x = 3                                  ;by applying recursive case twice and then base

And verification:

;;; Query input:
(?x next-to ?y in (1 (2 3) 4))

;;; Query results:
(1 next-to (2 3) in (1 (2 3) 4))
((2 3) next-to 4 in (1 (2 3) 4))

;;; Query input:
(?x next-to 1 in (2 1 3 1))

;;; Query results:
(2 next-to 1 in (2 1 3 1))
(3 next-to 1 in (2 1 3 1))

This exercise shows we are not limited to the prefix notation, which is used in
underlying Scheme evaluator, in query language.

Exercise 4.62

Here is the straight forward transformation:

(rule (last-pair (?x) (?x)))            ;base case
(rule (last-pair (?head . ?tail) ?x)    ;recursive case
      (last-pair ?tail ?x))

Here you should be careful in assert! order: You should assert! recursive
rule first and then base rule. It might sound counterintuitive; it is due to the
implementation details of data base where the assertions and rules stored.

Then test!

;;; Query input:
(last-pair (3) ?x)

;;; Query results:
(last-pair (3) (3))

;;; Query input:
(last-pair (2 ?x) (3))

;;; Query results:
(last-pair (2 3) (3))

Then the last unfolding case:

;;; Query input:
(last-pair ?x (3))

;;; Query results:
(last-pair (3) (3))
(last-pair (?head-181 3) (3))
(last-pair (?head-181 ?head-185 3) (3))
(last-pair (?head-181 ?head-185 ?head-189 3) (3))
(last-pair (?head-181 ?head-185 ?head-189 ?head-193 3) (3))
(last-pair (?head-181 ?head-185 ?head-189 ?head-193 ?head-197 3) (3))
(last-pair (?head-181 ?head-185 ?head-189 ?head-193 ?head-197 ?head-201 3) (3))
(last-pair (?head-181 ?head-185 ?head-189 ?head-193 ?head-197 ?head-201 ?head-205 3) (3))
...

It is reasonable since the revert is right!

;;; Query input:
(last-pair (?head-181 ?head-185 ?head-189 ?head-193 ?head-197 3) (3))

;;; Query results:
(last-pair (?head-304 ?head-306 ?head-308 ?head-310 ?head-312 3) (3))

And as ?head-... is free variable the result assert (infinite number of) facts
that for any assignment to ?head-... the given statements are satisfied.

And also note that the number appended to the variable name like 181 in
?head-181 is due to the implementation detail.

Exercise 4.63

(rule (grandson ?g ?s)
      (and (son ?f ?s) (son ?g ?f)))
(rule (son ?m ?s)
      (and (wife ?m ?w) (son ?w ?s)))

Then test!

;;; Query input:
(grandson Cain ?who)

;;; Query results:
(grandson cain irad)

;;; Query input:
(son Lamech ?son)

;;; Query results:
(son lamech jubal)
(son lamech jabal)

;;; Query input:
(grandson Methushael ?who)

;;; Query results:
(grandson methushael jubal)
(grandson methushael jabal)

How the Query System Works

Is Logic Programming Mathematical Logic?

Exercise 4.64

By the high level specification of this logic language, we can trace the
query (outranked-by (Bitdiddle Ben) ?who) as follows:
1. ?staff-person is bound to (Bitdiddle Ben) and ?who is bound to ?boss
  (since after this point by using the body of rule they are going to bind
  ?boss; so we need to bind ?who here to propagate the subsequent bindings).
2. Depending on the implementation details, whether it spits out the first
  output of (supervisor ?staff-person ?boss) or (and (outranked-by ?middle-manager) (supervisor ?staff-person ?middle-manager))
3. Here let we assume the case or consume the latter one first. Then by the
  specification of and it first query (outranked-by ?middle-manager ?boss)
  with the input frame, which is extended from 1. but has no bindings for
  ?middle-manager and ?boss.
4. By the same arguments from 1. to 3. it infinitely process (outranked-by ?middle-manager ?boss) without bindings for those.
5. Now let we consider other way around: or first process the former one. Then
  it now extend frame with binding for ?boss; so it spits out possible
  answers but to find more it should consume the latter one. It follows to the
  reasoning we did in the above case but spitting out each answer it encounters
  , after that, falling into infinite loops.
Let's experiment with our evaluator to verify what path our evaluator proceed:
```
;;; Query input:
(outranked-by (Bitdiddle Ben) ?who)

;;; Query results:
(outranked-by (bitdiddle ben) (warbucks oliver))
(outranked-by (bitdiddle ben) (warbucks oliver))  C-c C-c�
;Quit!
```
Yes the rather one is what our evaluator chose.

Exercise 4.65

Since there is four different frames satisfying Oliver to be wheel:

?middle-manager		?x
Bitdiddle Ben		Hacker Alyssa P
Bitdiddle Ben		Fect Cy D
Bitdiddle Ben		Tweakit Lem E
Scrooge Eben			Cartchet Robert

Exercise 4.66

Think about the following request:
```
(sum ?amount
     (and (wheel? ?x)
	  (salary ?x ?amount)))
```
to find out the total salaries of all the wheels in the Microshaft company. But
as we seen before Oliver counted forth times. What we wanted! We wanted to count
once for each wheel without duplication.

To deal with this malfunction, he need to remove the duplicate frames from the
output stream of query. Here we need to define what is du

HyunggyuJang/SICP

About

Topics

Resources

Stars

Watchers

Forks

Releases

Packages 0

Languages

Packages