Chapter 2 solution detail

Exercise 2.1

#!scheme
(define (make-rat n d)
  (let* ((mul (* n d))
     (n-abs (abs n))
     (d-abs (abs d))
     (g (gcd n-abs d-abs)))
    (cons (* (/ mul (* n-abs d-abs)) (/ n-abs g))
      (/ d-abs g))))

(print-rat (make-rat -1 -3))
; 1/3

(print-rat (make-rat -2 4))
; -1/2

(print-rat (make-rat 2 -4))
; -1/2

(print-rat (make-rat 2 4))
; 1/2

Exercise 2.2

#!scheme
(define (print-point p)
  (newline)
  (display "(")
  (display (x-point p))
  (display ",")
  (display (y-point p))
  (display ")"))

(define make-point cons)
(define x-point car)
(define y-point cdr)
(define make-segment cons)
(define start-segment car)
(define end-segment cdr)

(define (mid-point lseg)
  (let ((start (start-segment lseg))
    (end (end-segment lseg)))
    (make-point (/ (+ (x-point start)
              (x-point end))
           2.0)
        (/ (+ (y-point start)
              (y-point end))
           2.0))))

(print-point (mid-point (make-point (make-point 1 2) (make-point 4 7))))
; (2.5, 4.5)

Exercise 2.3

#!scheme
(define make-retangle1 make-segment)
(define (width lseg) (abs (- (x-point (start-segment lseg))
                  (x-point (end-segment lseg)))))

(define (height lseg) (abs (- (y-point (start-segment lseg))
                   (y-point (end-segment lseg)))))

(define (perimeter rect)
  (* 2 (+ (width rect) (height rect))))

(define (area rect)
  (* (width rect) (height rect)))

(define p1 (make-point 1 2))
(define p2 (make-point 3 4))

(define rect1 (make-retangle1 p1 p2))
(perimeter rect1)
;Value : 8

(area rect1)
;Value : 4

(define (make-rectangle2 left-bottom-point width height)
  (list left-bottom-point width height))

(define (width rect) (second rect))
(define (height rect) (third rect))


(define rect2 (make-rectangle2 p1 2 2))

(perimeter rect2)
; Value: 8

(area rect2)
; Value: 4

The above is a example to show that the concrete data will not affect the hight level procedure. In the exercise, we use two representation to represent the rectangle, one is with tow point of the left-bottom and top-right, one is with the left-bottom point and the with and height. The concrete data provided the interface procedure width and height to return the width and height of the rectangle, so the top level procedure perimeter and area will not be affect even though the concrete data changed.

Exercise 2.4

#!scheme
(define (my-cons x y)
  (lambda (m) (m x y)))

(define (my-car z)
  (z (lambda (p q) p)))

(define (my-cdr z)
  (z (lambda (p q) q)))

(define tt (my-cons 1 2))

(my-car tt)
;Value: 1

(my-cdr tt)
;Value: 2

In fact, this was just the notation of make_pair in λ-calculus. One could refer the book An introduction to functional programming through λ-calculus. In this book, chapter three give a detailed description of the basic operator in λ-calculus. And if one read this chapter, he/she will know (lambda (p q) p) is just the function def select_first λfirst.λsecond.first and (lambda (p q) q) is just the function def select_second λfirst.λsecond.second, and (lambda (m) (m x y)) is just function def make_pair = λe1.λe2.λc.(c e1 e2). So the definition of my-car is just a λ application for make_pair to λ-expression select_first.

Exercise 2.5

#!scheme
(define (my-cons a b)
  (* (expt 2 a) (expt 3 b)))

(define (my-car z)
  (if (not (= (modulo z 2) 0)) 
      0
      (+ 1 (my-car (/ z 2)))))

(define (my-cdr z)
  (if (not (= (modulo z 3) 0)) 
      0
      (+ 1 (my-car (/ z 3)))))

(define tt (my-cons 2 3))

(my-car tt)
;Value: 2
(my-cdr tt)
;Value: 3

Exercise 2.6

This exercise is about the Church numerals. It also discussed in the book An introduction to functional programming through lambda calculus I mentioned in Exercise 2.4(chapter 3).

#!scheme
(define zero (lambda (f) (lambda (x) x)))
(define (add-1 n)
  (lambda (f) (lambda (x) (f ((n f) x)))))

(define one (add-1 zero))
(define two (add-1 one))
(define three (add-1 two))

((one square) 3)
;Value: 9
;the result from (square 3)

((two square) 3)
;Value: 81
;the result from (square (square 3))

((three square) 3)
;Value: 6561
;the result from (square (square (square 3)))

; one = (lambda (f) (lambda (x) (f x)))
; two = (lambda (f) (lambda (x) (f (f x))))
; three = (lambda (f) (lambda (x) (f (f (f x)))))

(define (add a b)
  (lambda (f)
    (lambda (x)
      ((a f) ((b f) x)))))

(((add one two) square) 3)
;Value 6561

For the definition of one, two and three, we can just use substitution to get the result, and we could see they are the same as described in wikipedia page. It's just the programming style of lambda expression. And in fact the procedure add-1 can give us some hint of workout the procedure add. The solution is as above code.

Exercise 2.7

#!scheme
(define (make-interval a b) (cons a b))

(define (lower-bound x)
  (min (car x) (cdr x)))

(define (upper-bound x)
  (max (car x) (cdr x)))

Exercise 2.8

#!scheme
(define (sub-interval a b)
  (make-interval (- (lower-bound a) (upper-bound b))
         (- (upper-bound a) (lower-bound b))))

Exercise 2.9

#!scheme
(define (width-interval x)
  (/ (- (upper-bound x) (lower-bound x)) 2.0))

Exercise 2.10

#!scheme
(define (div-interval x y)
  (if (= (width-interval y) 0.0)
      (error "Divide interval by zero")
      (mul-interval
       x
       (make-interval (/ 1.0 (upper-bound y))
              (/ 1.0 (lower-bound y))))))

(define t1 (make-interval 3 4))

(define t2 (make-interval 3 3))

(div-interval t1 t2)

Exercise 2.11

#!scheme
(define (mul-interval x y)
  (define (sign interval)
    (cond ((and (> (lower-bound interval) 0)
        (> (upper-bound interval) 0)) 1)
      ((and (< (lower-bound interval) 0)
        (< (upper-bound interval) 0)) -1)
      (else 0)))
  (let ((x-sign (sign x))
    (y-sign (sign y))
    (x1 (lower-bound x))
    (x2 (upper-bound x))
    (y1 (lower-bound y))
    (y2 (upper-bound y)))
    (cond ((= x-sign  1)
       (cond ((= y-sign 1) (make-interval (* x1 y1) (* x2 y2)))
         ((= y-sign -1) (make-interval (* x2 y1) (* x1 y2)))
         (else (make-interval (* x2 y1) (* x1 y2)))))
      ((= x-sign -1)
       (cond ((= y-sign 1) (make-interval (* x1 y2) (* x2 y1)))
         ((= y-sign -1) (make-interval (* x2 y2) (* x1 y1)))
         (else (make-interval (* x1 y2) (* x2 y1)))))
      (else
       (cond ((= y-sign 1) (make-interval (* x1 y2) (* x2 y1)))
         ((= y-sign -1) (make-interval (* x2 y1) (* x1 y2)))
         (else (make-interval (min (* x1 y2) (* x2 y1))
                      (max (* x1 y1) (* x2 y2)))))))))

Exercise 2.12

#!scheme
(define (center i)
  (/ (+ (upper-bound i) (lower-bound i)) 2.0))

(define (width i)
  (/ (- (upper-bound i) (lower-bound i)) 2.0))

(define (make-center-percent c pct)
  (let ((width (/ (* c pct) 100.0)))
    (make-interval (- c (/ width 2.0)) (+ c (/ width 2.0)))))

(define (percent-tolerance i)
  (let ((c (center i))
    (w (width i)))
    (* (/ w c) 100)))

Exercise 2.13

Let Ca is the center of interval A, Ta is the tolerance of A, and Cb is the center of B, and Tb is the tolerance. According to the assumption, all Ca, Ta, Cb, Tb are positive, and 0 < Ta, Tb < 100%.

A = [Ca - 0.5 * Ta * Ca, Ca + 0.5 * Ta * Ca]

B = [Cb - 0.5 * Tb * Cb, Cb + 0.5 * Tb * Cb]

A * B = [Ca * Cb * (1 - 0.25 * (Ta + Tb) + 0.25 * Ta * Tb), Ca * Cb * (1 + 0.25 * (Ta + Tb) - 0.25 * Ta * Tb)]

So the tolerance of A * B is: 0.5 * (Ta + Tb) - 0.5 * Ta * Tb

Exercise 2.14

#!scheme(define (par1 r1 r2)
  (div-interval (mul-interval r1 r2)
        (add-interval r1 r2)))

(define (par2 r1 r2)
  (let ((one (make-interval 1 1)))
    (div-interval one (add-interval (div-interval one r1)
                    (div-interval one r2)))))

(define a (make-interval 2 8))

(define b (make-interval 2 8))

(par1 a b)
;Value 13: (.25 . 16.)

(par2 a b)
;Value 14: (1. . 4.)

(div-interval a a)
;Value 15: (.25 . 4.)

In fact, we could see that we don't define the relation equal of interval, for interval a = [2, 8], a/a = [0.25, 4] is not correct. So we could not use mathe operation to change the formula since they are not equal under interval operation.

Exercise 2.15

It seems that everytime we calculuate interval division, such as A/B, with percent-tolerance of A not zero, we introduce some error. Since the par1, since then, it seems that procedure par1 will introduce more error than procedure par2.

Exercise 2.16

I can not got the solution to the problem currently.

Exercise 2.17

#!scheme
(define (last-pair lst)
  (if (null? (cdr lst))
      lst
      (last-pair (cdr lst))))

(last-pair (list 23 72 149 34))
;Value 14: (34)

Exercise 2.18

#!scheme
(define (my-reverse lst)
  (define (reverse-help acc lst)
    (if (null? lst)
    acc
    (reverse-help (cons (car lst) acc) (cdr lst))))
  (reverse-help '() lst))

(my-reverse (list 1 4 9 16 25))
;Value 16: (25 16 9 4 1)

Exercise 2.19

#!scheme
(define us-coins (list 50 25 10 5 1))
(define uk-coins (list 100 50 20 10 5 2 1 0.5))

(define (cc amount coin-values)
  (cond ((= amount 0) 1)
    ((or (< amount 0) (no-more? coin-values)) 0)
    (else
     (+ (cc amount (except-first-denomination coin-values))
        (cc (- amount (first-denomination coin-values)) coin-values)))))

(define no-more? null?)
(define first-denomination car)
(define except-first-denomination cdr)

(cc 100 us-coins)
;Value: 292
(cc 100 uk-coins)
;Value: 104561

Exercise 2.20

The scheme form for define arbitrary number of argument. (define (f x y . z) <body>), the procedure f can be caled with two or more arguments. The first will bound to x, second will bound to y, and the rest as a list will bound to z

#!scheme
(define (same-parity x . y)
  (cons x (filter (lambda (w) (even? (- w x))) y)))

(same-parity 1 2 3 4 5 6 7)
;Value 22: (1 3 5 7)
(same-parity 2 3 4 5 6 7)
;Value 23: (2 4 6)

Exercise 2.21

#!scheme
(define (square-list items)
  (if (null? items)
      '()
      (cons (square (car items)) (square-list (cdr items)))))

(square-list (list 1 2 3 4))
;Value 24: (1 4 9 16)

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

(square-list (list 1 2 3 4))
;Value 25: (1 4 9 16)

Exercise 2.22

Because it cons the square of current item onto the head of the list, so we finally get the reversed order of the answer.

For the fixed version, since cons needs the second item to be a list, but the code cons a list to an item, so in fact, we will get an improper cons cell.

Exercise 2.23

#!scheme
(define (my-for-each proc items)
  (if (null? items)
      'done
      (begin
    (proc (car items))
    (my-for-each proc (cdr items)))))

(my-for-each (lambda (x)
           (newline)
           (display x))
         (list 57 321 88))
;57
;321
;88
;Value: done

Exercise 2.24

#!scheme
(list 1 (list 2 (list 3 4)))
;Value 29: (1 (2 (3 4)))

Exercise 2.25

#!scheme
(car (cdr (car (cdr (cdr '(1 3 (5 7) 9))))))
;Value: 7

(car (car '((7))))
;Value: 7

(car
 (cdr 
  (car 
   (cdr 
    (car (cdr (car (cdr (car (cdr (car (cdr '(1 (2 (3 (4 (5 (6 7))))))))))))))))))
;Value: 7

Exercise 2.26

#!scheme
(define x (list 1 2 3))
(define y (list 4 5 6))

(append x y)
;Value 37: (1 2 3 4 5 6)
(cons x y)
;Value 38: ((1 2 3) 4 5 6)
(list x y)
;Value 39: ((1 2 3) (4 5 6))

Exercise 2.27

#!scheme
(define (deep-reverse items)
  (if (pair? items)
      (my-reverse (map deep-reverse items))
      items))

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

(my-reverse x)
;Value 41: ((3 4) (1 2))
(deep-reverse x)
;Value 44: ((4 3) (2 1))

(define y (list (list (list 3 4) 5 6) (list 7 9)))
y
;Value 55: (((3 4) 5 6) (7 9))
(deep-reverse y)
;Value 68: ((9 7) (6 5 (4 3)))

The above solution refer to this link, it use a higher-order-function and function my-reverse in exercise 2.18 to make the code extremely short.

Exercise 2.28

#!scheme
(define (fringe items)
  (if (pair? items)
      (append (fringe (car items)) (fringe (car (cdr items))))
      (list items)))

(fringe x)
;Value 73: (1 2 3 4)

(fringe (list x x))
;Value 74: (1 2 3 4 1 2 3 4)

Exercise 2.29

TODO

Exercise 2.30

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

(square-tree '(1 (2 (3 4) 5) 5))
;Value 18: (1 (4 (9 16) 25) 25)

Exercise 2.31

#!scheme
(define (tree-map f tree)
  (map (lambda (sub-tree)
     (if (pair? sub-tree)
         (tree-map f sub-tree)
         (f sub-tree)))
       tree))

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

(square-tree2 '(1 (2 (3 4) 5) 5))
;Value 20: (1 (4 (9 16) 25) 25)

Again, we see the power of abstraction, use the tree-map procedure, we can get the same result of map on the list to apply a function to every node on a tree

Exercise 2.32

#!scheme
(define (subsets s)
  (if (null? s)
      (list '())
      (let ((rest (subsets (cdr s))))
    (append rest (map (lambda (x) (cons (car s) x)) rest)))))

(subsets '(1 2 3))
;Value 28: (() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3))

Exercise 2.33

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


(define (my-map p sequence)
  (accumulate (lambda (x y) (cons (p x) y)) '() sequence))

(my-map odd? '(1 2 3 4))
;Value 32: (#t #f #t #f)

(define (my-append seq1 seq2)
  (accumulate cons seq2 seq1))

(my-append '(1 2 3) '(4 5 6))
;Value 34: (1 2 3 4 5 6)

(define (my-length sequence)
  (accumulate (lambda (x y) (+ y 1)) 0 sequence))

(my-length '(1 2 3))
;Value: 3

From this example, we can see the power of abstraction. With only the procedure accumulate, we could define our own map, append and length function in a very short and clear way.

Exercise 2.34

#!scheme
(define (horner-eval x coefficient-sequence)
  (accumulate (lambda (this-coeff higher-term)
        (+ (* higher-term x) this-coeff))
          0
          coefficient-sequence))

(horner-eval 2 (list 1 3 0 5 0 1))
;Value: 79

Exercise 2.35

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

(define (count-leaves t)
  (accumulate + 0 (map (lambda (x)
                    (if (not (pair? x))
                        1
                        (count-leaves x))) t)))

(count-leaves '(2 (1 3) 4 5 (6 7)))
;Value: 7

Exercise 2.36

#!scheme
(define (accumulate-n op init seqs)
  (if (null? (car seqs))
      '()
      (cons (accumulate op init (map car seqs))
        (accumulate-n op init (map cdr seqs)))))

(accumulate-n + 0 '((1 2 3) (4 5 6) (7 8 9) (10 11 12)))
;Value 13: (22 26 30)

Exercise 2.37

#!scheme
(define a-mat '((1 2 3 4) (4 5 6 6) (6 7 8 9)))
(define b-vec '(1 2 3 4))
(define c-mat '((1 1 1) (1 1 1) (1 1 1)))
(define (dot-product v w)
  (accumulate + 0 (map * v w)))

(define (matrix-*-vector m v)
  (map (lambda (x) (dot-product x v)) m))

(matrix-*-vector a-mat b-vec)
;Value 14: (30 56 80)

(define (transpose mat)
  (accumulate-n cons '() mat))

(transpose a-mat)
;Value 16: ((1 4 6) (2 5 7) (3 6 8) (4 6 9))

(define (matrix-*-matrix m n)
  (let ((cols (transpose n)))
    (map (lambda (x) (matrix-*-vector cols x)) m)))

(matrix-*-matrix c-mat c-mat)
;Value 18: ((3 3 3) (3 3 3) (3 3 3))

Exercise 2.38

#!scheme
(define fold-right accumulate)
(define (fold-left op initial sequence)
  (define (iter result rest)
    (if (null? rest)
    result
    (iter (op result (car rest))
          (cdr rest))))
  (iter initial sequence))

(fold-right / 1 (list 1 2 3))
;Value: 3/2
(fold-left / 1 (list 1 2 3))
;Value: 1/6
(fold-right list '() (list 1 2 3))
;Value 19: (1 (2 (3 ())))
(fold-left list '() (list 1 2 3))
;Value 20: (((() 1) 2) 3)

In fact, we write sequence as [x1, x2, ... , xn], and the function (fold-left op init sequence) will expand as (op (op ... (op init x1) x2) .. xn), and function (fold-right op init sequence) will be expand to (op (op (op ... (op xn init) xn-1) ... x2) x1).

So if we want the fold-left and fold-right to get the same result, we can suppose the sequence only contain one element [x1], and in this case, fold-left get (op init x1), and fold-right get (op xn init), so for the two to be equal, we need the operation op to be commutative.

Exercise 2.39

#!scheme
(define (my-reverse1 sequence)
  (fold-right (lambda (x y) (append y (list x))) '() sequence))

(my-reverse1 '(1 2 3 4))
;Value 24: (4 3 2 1)

(define (my-reverse2 sequence)
  (fold-left (lambda (x y) (cons y x)) '() sequence))

(my-reverse2 '(1 2 3 4))
;Value 25: (4 3 2 1)

From the exercise 2.33 to 2.39, we see the power of abstraction again, with only the abstraction function fold-left and fold-right, a lot of operations and functions can be defined use these two functions in a very elegant, concise way.

Exercise 2.40

#!scheme
(define (unique-pairs n)
  (accumulate append
          '()
          (map (lambda (i)
             (map (lambda (j) (list i j))
              (enumerate-interval 1 (- i 1))))
           (enumerate-interval 1 n))))

(unique-pairs 4)
;Value 31: ((2 1) (3 1) (3 2) (4 1) (4 2) (4 3))

Exercise 2.41

This exercise is a good example to show how higher order function can be used to implement nested loop under Functional Programming Language. Programmer new to Functional Programming Language are always not suited to no for or while loop to use, although Common Lisp provide loop macro similar to for in imperative language. But from this example, we can see that loop in imperative language can be implemented by higher-order-function and recursion.

Nowerdays' computer maily follow the Von Neumann architecture developed by Alan Turing. But there is also other computation theory. Functional Programming is actually based on the other computation theory lambda-calculus. Turing already showed that Turing Machine and lambda-calculus are equivelent. So for every compute procedure in Turing machine, there is a equivelent lambda expression.

#!scheme
(define (all-triples n)
  (flatmap (lambda (i)
         (flatmap (lambda (j)
            (map (lambda (k)
                   (list i j k))
                 (enumerate-interval 1 n)))
              (enumerate-interval 1 n)))
       (enumerate-interval 1 n)))

(define (all-ordered-triples n s)
  (filter (lambda (x) (= (reduce + 0 x) s)) (all-triples n)))

(all-ordered-triples 3 5)
;Value 21: ((1 1 3) (1 2 2) (1 3 1) (2 1 2) (2 2 1) (3 1 1))

Exercise 2.42

Scheme program to solve the 8-queens probem.

#!scheme
(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 1 board-size)))
      (queen-cols (- k 1))))))
  (queen-cols board-size))

(define empty-board '())
(define (adjoin-position row col rest-of-queens)
  (cons (list row col) rest-of-queens))

(define (safe? k positions)
  (define (row pos) (car pos))
  (define (col pos) (car (cdr pos)))
  (let ((k-pos (car positions))
    (rest-pos (cdr positions)))
    (null? (filter (lambda (pos)
             (or (= (row k-pos) (row pos))
                  (= (- (row k-pos) (row pos))
                 (- (col pos) (col k-pos)))
                  (= (- (row k-pos) (row pos))
                 (- (col k-pos) (col pos)))))
           rest-pos))))

(safe? 4 '((3 4) (1 3) (4 2) (2 1)))

(queens 4)
;Value 43: (((3 4) (1 3) (4 2) (2 1)) ((2 4) (4 3) (1 2) (3 1)))

Exercise 2.43

Since Louis change the order of flatmap, the program will solve solve function (queen-cols (- k 1)) every time it tried to put a new queen, instead only solve it once, and try to put a new queen on the kth column. So it is actually a exponentianl growth function to calculuate. Same as fibonacci function f(n) = f(n - 1) + f(n - 2). So in Functional programming, we should take care to store recursively answer to reduce the amout of computation.

Exercise 2.44

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

Exercise 2.45

#!scheme
(define (split f1 f2)
  (lambda (painter n)
    (if (= n 0)
    painter
    (let ((smaller ((split f1 f2) painter (- n 1))))
      (f1 painter (f2 smaller smaller))))))

(define right-split (split beside below))
(define up-split (split below beside))

This is a good example to show how to build common pattern to abstract over different operations. As we notice, the only difference of procedure right-split and up-split is the order of operations below and beside. So we could extract this as a argument to another procedure. Again we know, we benefit so much from the function as first-class citizen.

Exercise 2.46

Here is just one implementation.

#!scheme
(define make-vect cons)
(define xcor-vect car)
(define ycor-vect cdr)

(define (op-vect op x y)
  (make-vect (op (xcor-vect x) (xcor-vect y))
         (op (ycor-vect x) (ycor-vect y))))

(define (add-vect x y)
  (op-vect + x y))

(define (sub-vect x y)
  (op-vect - x y))

(define (scale-vect x s)
  (make-vect (* s (xcor-vect x))
         (* s (ycor-vect y))))

Exercise 2.47

#!scheme
(define (make-frame origin edge1 edge2)
  (list origin edge1 edge2))

(define origin-frame car)

(define (edge1-frame frame) (car (cdr frame)))

(define edge2-frame last)

(define (make-frame origin edge1 edge2)
  (cons origin (cons edge1 edge2)))

;; origin-frame and edge1-frame can be the same as above

(define (edge2-frame frame)
  (cdr (cdr frame)))

Exercise 2.48

#!scheme
(define (make-segment v1 v2)
  (cons v1 v2))

(define seg (make-segment (make-vect 1 2) (make-vect 3 4)))
;Value 15: ((1 . 2) 3 . 4)

(define start-segment car)

(define end-segment cdr)

(start-segment seg)
;Value 16: (1 . 2)

(end-segment seg)
;Value 17: (3 . 4)

Exercise 2.53

#!scheme
(list 'a 'b 'c)
;Value 18: (a b c)
(list (list 'george))
;Value 19: ((george))
(cdr '((x1 x2) (y1 y2)))
;Value 20: ((y1 y2))
(cadr '((x1 x2) (y1 y2)))
;Value 21: (y1 y2)
(pair? (car '(a short list)))
;Value: #f
(memq 'red '((red shoes) (blue socks)))
;Value: #f
(memq 'red '(red shoes blue socks))
;Value 22: (red shoes blue socks)

Exercise 2.54

#!scheme
;; there is a build-in equal?
(equal? '(this is a list) '(this is a list))

(define (my-equal? xs ys)
  (cond ((and (null? xs) (null? ys)) #t)
    ((eq? (car xs) (car ys)) (my-equal? (cdr xs) (cdr ys)))
    (else #f)))


(my-equal? '(this is a list) '(this is another list))
;Value: #f
(my-equal? '(this is a list) '(this is a list))
;Value: #t

Exercise 2.55

#!scheme
(car ''abracadabra)

(equal? ''abracadabra (quote (quote abracadabra)))
;Value: #t

In fact, from the above code, we could se ''abracadabra equals (quote (quote abracadabra)). So the car of the element is quote.

Exercise 2.56

#!scheme
(define (make-exponentiation base exponent)
  (cond ((and (number? exponent) (= exponent 0)) 1)
    ((and (number? exponent) (= exponent 1)) base)
    ((number? exponent) (list '** base exponent))
    (else (error "Not correct exponent format"))))

(define (exponent? exp) (eq? (car exp) '**))

(define (base exp) (cadr exp))
(define (exponent exp) (caddr exp))

(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 (multiplier exp)
                       (deriv (multiplicand exp) var))
             (make-product (deriv (multiplier exp) var)
                       (multiplicand exp))))
    ((exponent? exp) (make-product
              (exponent exp)
              (make-exponentiation (base exp)
                           (- (exponent exp) 1))))
    (else (error "unknow expression type: DERIV" exp))))

(deriv (make-exponentiation 'x 10) 'x)

Exercise 2.57

We can use higher-order-function to do such thing, and make some change to the procedure make-sum and make-product, following is the code:

#!scheme
(define (make-sum exp-list)
  (cond ((every number? exp-list) (reduce-left + 0 exp-list))
    (else (cons '+ (delete 0 exp-list)))))

(define (make-product exp-list)
  (cond ((every number? exp-list) (reduce-left * 1 exp-list))
    ((any (lambda (x) (and (number? x) (= x 0))) exp-list) 0)
    (else (cons '* (delete 0 exp-list)))))

(define (deriv exp var)
  (cond ((number? exp) 0)
    ((variable? exp) (if (same-variable? exp var) 1 0))
    ((sum? exp) (make-sum (map (lambda (x) (deriv x var)) (cdr exp))))
    ((product? exp) (make-sum (map (lambda (x)
                     (make-product
                      (list (deriv x var)
                        (delete x exp)))) (cdr exp))))
    ((exponent? exp) (make-product
              (list (exponent exp)
                (make-exponentiation (base exp)
                             (- (exponent exp) 1)))))
    (else (error "unknow expression type: DERIV" exp))))

(deriv '(* x y (+ x 3)) 'x)
;Value 59: (+ (* 1 (* y (+ x 3))) (* 1 (* x y)))

First, we change the procedure make-sum and make-product to accept list as argument and make sum and product of more than 2 elements. Then in the procedure deriv, we use map to build the differentiate procedure.

Exercise 2.58

problem a solution

#!scheme
(define (make-sum a b)
  (cond ((and (number? a) (number? b)) (+ a b))
    ((and (number? a) (zero? a)) b)
    ((and (number? b) (zero? b)) a)
    (else (list a '+ b))))


(define (make-product a b)
  (cond ((and (number? a) (number? b)) (* a b))
    ((and (number? a) (= a 1)) b)
    ((and (number? a) (= a 0)) 0)
    ((and (number? b) (= b 1)) a)
    ((and (number? b) (= b 0)) 0)
    (else (list a '* b))))

(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))

(define (sum? x) (and (pair? x) (eq? (cadr x) '+)))
(define (addend s) (car s))
(define (augend s) (caddr s))
(define (product? x) (and (pair? x) (eq? (cadr x) '*)))
(define (multiplier p) (car p))
(define (multiplicand p) (caddr p))

(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 (multiplier exp)
                       (deriv (multiplicand exp) var))
             (make-product (deriv (multiplier exp) var)
                       (multiplicand exp))))
    (else (error "unknow expression type: DERIV" exp))))

(deriv '(x + (3 * (x + (y + 2)))) 'x)
;Value: 4

Here again, we see the power of multiple-level abstraction. We can use the previous procedure deriv without any change to it. Only change the level to represent the expression.

Exercise 2.58

We only make little change to the deriv procedure and make some change to the cselect method. Here is my solution:

#!scheme
(define (atom? x) (not (pair? x)))
(define (nil? x) (equal? x '()))

(define (addend s) (car s))

(define (augend s)
  (if (and (atom? (caddr s)) (nil? (cdddr s)))
      (caddr s)
      (cddr s)))

(define (multiplier p) (car p))

(define (multiplicand p)
  (caddr p))

(define (deriv exp var)
  (cond
   ((nil? exp) 0)
   ((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-sum
             (make-product (multiplier exp)
                   (deriv (multiplicand exp) var))
             (make-product (deriv (multiplier exp) var)
                   (multiplicand exp)))
            (if (nil? (cdddr exp)) 0 (deriv (cddddr exp) var))))
   (else (error "unknow expression type: DERIV" exp))))

(define exp1 '(x + 3 * (x + y + 2)))
(define exp2 '(x * y + 3 * (x + y + 2) ))

(deriv exp1 'x)
;Value: 4
(deriv exp2 'x)
;Value 82: (y + 3)

Exercise 2.59

#!scheme
(define (union-set set1 set2)
  (cond ((null? set1) set2)
    ((null? set2) set1)
    ((element-of-set? (car set1) set2)
     (union-set (cdr set1) set2))
    (else (cons (car set1) (union-set (cdr set1) set2)))))

(define ss (adjoin-set 1 (adjoin-set 2 (adjoin-set 3 '()))))
(define so (adjoin-set 2 (adjoin-set 4 (adjoin-set 3 (adjoin-set 7 '())))))

(union-set ss so)
;Value 15: (1 2 4 3 7)

Exercise 2.60

#!scheme
(define (element-of-set? x set)
  "return a number of occurence of the item x, 0 represent not in it"
  (define (iter acc xs)
    (cond ((null? xs) acc)
      ((equal? x (car xs)) (iter (+ acc 1) (cdr xs)))
      (else (iter acc (cdr xs)))))
  (iter 0 set))

(define (adjoin-set x set)
  (cons x set))

(define (repeat i n)
  "produce a set of n i, (repeat 3 2) => (3 3)"
  (if (zero? n) '() (cons i (repeat i (- n 1)))))


(define (intersection-set set1 set2)
   (if (or (null? set1) (null? set2))
       '()
       (let* ((ii (car set1))
          (c1 (element-of-set? ii set1))
          (c2 (element-of-set? ii set2)))
     (append (repeat ii (min c1 c2))
         (intersection-set (delete ii set1) (delete ii set2))))))



(define (union-set set1 set2)
  (if (null? set1)
      set2
      (let* ((ii (car set1))
         (c1 (element-of-set? ii set1))
         (c2 (element-of-set? ii set2)))
    (append (repeat ii (+ c1 c2))
        (union-set (delete ii set1) (delete ii set2))))))

(define s1 (adjoin-set 1 (adjoin-set 2 (adjoin-set 1 (adjoin-set 2 '())))))
(define s2 (adjoin-set 3 (adjoin-set 2 (adjoin-set 2 (adjoin-set 2 '())))))



(intersection-set s1 s2)
;Value 22: (2 2)

(union-set s1 s2)
;Value 27: (1 1 2 2 2 2 2 3)

The solution is as above. This representation is useful for example for count vote tickets and so on. When we merge two vote result of a voting event, we should not regard repeat and take them into consideration.

Exercise 2.61

#!scheme
(define (adjoin-set item set)
  (cond
   ((null? set) (cons item set))
   ((= item (car set)) set)
   ((< item (car set)) (cons item set))
   (else (cons (car set) (adjoin-set item (cdr set))))))

(define s1 (adjoin-set 4 (adjoin-set 3 (adjoin-set 2 (adjoin-set 1 '())))))
s1
;Value 28: (1 2 3 4)

Exercise 2.62

#!scheme
(define (union-set set1 set2)
  (if (null? set1)
      set2
      (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)))
          (else (cons x2 (union-set set1 (cdr set2))))))))


(define s1 (adjoin-set 4 (adjoin-set 3 (adjoin-set 2 (adjoin-set 1 (adjoin-set 2 '()))))))

(define s2 (adjoin-set 4 (adjoin-set 7 (adjoin-set 8 '()))))

(union-set s1 s2)
;Value 31: (1 2 3 4 7 8)

Exercise 2.63

#!scheme
(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 '()))

(define tree '(5 (3 (1 () ()) (4 () ())) (9 (8 () ()) (10 () ()))))

(define tree2 '(5 (3 (1 () ())) (9 (8 () ()) (10 () ()))))

(tree->list-1 tree)
;Value 42: (1 3 4 5 8 9 10)

(tree->list-2 tree)
;Value 44: (1 3 4 5 8 9 10)

Yes, the two procedure will always produce same result. In fact tree->list-2 is just a tail-recursive form of tree->list-1.

Exercise 2.64

#!scheme
(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 (+ left-sizez 1))))
        (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. This program will split the ordered list as balance as possible and make a sub tree balance, so the final result is a balanced tree.

Take (1 3 5 7 9 11) as an example, it will first select (1 3) as the left tree, and (7 9 11) as the right tree, 5 as the root. Then recursive the prcedure and build the entire tree. The final tree is like

 5
/ \

/ \
1 9 \ / \ 3 7 11

b. We can easily see the build procedure follow the recursive procedure T(n) = 2 * T(n/2) + O(1). According the master theorem, we could easily know the procedure require O(n).

Exercise 2.65

Use the procedure in exercise 2.63 and 2.64, it is very easy to implement a balanced tree representation, the following is the code:

#!scheme
(define (union-set-tree set1 set2)
  (let* ((x1 (tree->list-1 set1))
     (x2 (tree->list-1 set2))
     (xr (union-set x1 x2)))
    (list->tree xr)))

(define (intersection-set-tree set1 set2)
  (let* ((x1 (tree->list-1 set1))
     (x2 (tree->list-1 set2))
     (xr (intersection-set x1 x2)))
    (list->tree xr)))

(define s1 (list->tree '(1 2 3 4 5)))
(define s2 (list->tree '(1 3 7 9 5)))

(intersection-set-tree s1 s2)
;Value 47: (1 () (3 () ()))

(union-set-tree s1 s2)
;Value 48: (4 (2 (1 () ()) (3 () ())) (7 (5 () ()) (9 () (5 () ()))))

Exercise 2.66

#!scheme
(define (lookup-tree given-key set-of-records)
  (cond ((null? set-of-records) false)
    ((equal? given-key (entry set-of-records)) (entry set-of-records))
    ((< given-key (entry set-of-records))
     (lookup-tree given-key (left-branch set-of-records)))
    ((> given-key (entry set-of-records))
     (lookup-tree given-key (right-branch set-of-records)))))

Exercise 2.67

#!scheme
(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))

(decode sample-message sample-tree)
;Value 13: (a d a b b c a)

Exercise 2.68

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

(define (encode-symbol symbol tree)
  (define (in-tree? current-tree)
    (if (leaf? current-tree)
    (if (eq? symbol (symbol-leaf current-tree)) true false)
    (member symbol (caddr tree))))
  (define (help acc curr-tree)
    (cond ((leaf? curr-tree) (reverse acc))
      ((in-tree? (left-branch curr-tree))
       (help (cons '0 acc) (left-branch curr-tree)))
      ((in-tree? (right-branch curr-tree))
       (help (cons '1 acc) (right-branch curr-tree)))
      (else (error "SYMBOL not in the tree: " symbol))))
  (help '() tree))

(encode '(a d a b b c a) sample-tree)
;Value 28: (0 1 1 0 0 1 0 1 0 1 1 1 0)

Exercise 2.69

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

(define (successive-merge leaf-set)
  (define (one? tree)
    (null? (cdr tree)))
  (if (one? leaf-set)
      (car leaf-set)
      (let* ((la (last leaf-set))
         (other (delete la leaf-set)))
    (make-code-tree la
            (successive-merge other)))))

(generate-huffman-tree '((a 4) (b 2) (c 1) (d 1)))
;Value 18: ((leaf a 4) ((leaf b 2) ((leaf c 1) (leaf d 1) (c d) 2) (b c d) 4) (a b c d) 8)

In the above code, we take the last element from leaf-set, and generate the huffman code tree with the last element removed, and make a tree combine the subtree and the last element.

Exercise 2.70

#!scheme
(define song-tree
  (generate-huffman-tree
   '((A 2) (GET 2) (SHA 3) (WAH 1) (BOOM 1) (JOB 2) (NA 16) (YIP 9))))

(define song-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))

(encode song-message song-tree)
;Value 19: (1 1 1 1 0 1 1 1 0 1 1 1 1 1 0 1 1 0 0 0 0 0 0 0 0 0 1 1 1 1 0 1 1 1 0 1 1 1 1 1 0 1 1 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 1 0 1 1 1 1 1 1 1)

We could easily get that it nees 87 bits to represent the song in huffman encoding tree. If we use fixed number bits to represent every symbol, since there are 8 symbol, we need 3bits(2^3 = 8) to represent every symbo, and the song contain 36 words(symbols), so we need 3 * 36 = 108 bits to represent the song under fixed-number-bits representation.

Exercise 2.71

For n = 5, the tree is look like:

All the node with a star is the leaf node in the tree. So we could easily know that it needs one bit to represent the most frequent symbol, and (n-1) bits to represent the most rare symbol.

Exercise 2.72

For n nodes with the frequence in Exercise 2.71, we know that to encode the most frequent symbol, we need to first search the list in the left tree, then search the list on the right tree, so it needs O(2^(n-2)) (search the left tree) + O(1) search the right tree.

For the least frequent symbol, we walks down always from the left tree, and it needs O(1) to search the tree everytime, so it nees O(n-2) to find the least frequent symbol.

Exercise 2.73

#!scheme
(define (same-variable? x y) (equal? x y))
(define (variable? x) (symbol? x))

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

;;;; exercise a 
;;;; the above code handle the basic condition of the deriv procedure and provide operator and operands selector


;;;; exercise b
(define (install-sum-deriv)
  (define (deriv-sum operands var)
    (+ (deriv (car operands) var) (deriv (cdr operands) var)))
  (begin
    (put 'deriv '+ deriv-sum)
    'done))

(install-sum-deriv)


(define (install-mul-deriv)
  (define (deriv-mul operands var)
    (let ((v1 (car operands))
      (v2 (cdr operands)))
      (+ (* (deriv v1 var) v2)
     (* v1 (deriv v2 var)))))
  (begin
    (put 'deriv '* deriv-mul)
    'done))

(install-mul-deriv)

(deriv (cons '+ (cons '(* 4 . x) '(* 3 . y))) 'x)
;Value: 4


;;;; exercise c
(define (install-exp-deriv)
  (define (deriv-exp operands var)
    (let ((base (car operands))
      (expo (cdr operands)))
      (* expo (cons '** base (- expo 1)))))
  (begin
    (put 'deriv '** deriv-exp)
    'done))

(install-exp-deriv)

;;;; exercise d
;;;; in fact, only very few change need to be done, only change the install code the procedure of put

Exercise 2.75

#!scheme
(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 'magnitude) r)
      ((eq? op 'angle) a)
      (else (error "Unknow op: MAKE-FROM-MAG-ANG: " op))))
  dispatch)

Exercise 2.76

We have shown that explicit dispatch has two weakness. And data-directed dispatch abstract on the column on types, so it will be convenient when add a new type. And message-passing style abstract on operations, so when we add operations more often than add types, it will be more convenient.

Exercise 2.77

Because the origin complex number didn't put the procedure real-part, imag-part, magnitude and angle to the package, so when Louis Reasoner evaluate the expression, it will have such method. After we put these procedure to the expression, it will be OK.

When we evaluate the expression, there will be 2 calls to the apply-generic procedure. One dispatch to the complex, one dispatch to whether it was represented as rectangular or polar form.

Exercise 2.78

We could redefine the procedure as follow:

#!scheme
(define (attach-tag type-tag contents)
  (if (number? contents)
      contents
      (cons type-tag contents)))

(define (type-tag datum)
  (if (pair? datum)
      (car datum)
      (if (number? datum)
      datum
      (error "Bad tagged datum: CONTENT" datum))))

(define (contents datum)
  (if (pair? datum)
      (cdr datum)
      (if (number? datum)
      datum
      (error "Bad tagged datum: CONTENT" datum))))

Exercise 2.79 - 2.80

#!scheme

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


(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))
      (error "No method for these types: APPLY-GENERIC:"
         (list op type))))))

(define (install-scheme-number-package)
  (define (tag x) (attach-tag 'scheme-number x))
  (begin
    (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)))
    (put 'equ? '(scheme-number scheme-number)
     (lambda (x y) (= x y)))
    (put '=zero? '(scheme-number)
     (lambda (x) (= x 0)))
    'done))

(install-scheme-number-package)

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

(equ? (make-scheme-number 10) (make-scheme-number 20))
;Value: #f

(=zero? (make-scheme-number 10))
;Value: #f

(=zero? (make-scheme-number 0))
;Value: #t

;;;; rational number package
(define (install-rational-package)
  ;;internal procedures
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (let ((g (gcd n d)))
      (cons (/ n g) (/ d g))))
  (define (add-rat x y)
    (make-rat (+ (* (numer x) (denom y))
         (* (numer y) (denom x)))
          (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (numer x) (denom y))
         (* (numer y) (denom x)))
          (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (numer x) (numer y))
          (* (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (* (numer x) (denom y))
          (* (denom x) (numer y))))
  (define (equ-rat? x y)
    (and (= (numer x) (numer y))
     (= (denom x) (denom y))))
  (define (=zero-rat? x)
    (= (numer x) 0))
  ;;interface to the rest of the system
  (define (tag x) (attach-tag 'rational x))
  (begin
    (put 'add '(rational rational)
     (lambda (x y) (tag (add-rat x y))))
    (put 'sub '(rational rational)
     (lambda (x y) (tag (sub-rat x y))))
    (put 'mul '(rational rational)
     (lambda (x y) (tag (mul-rat x y))))
    (put 'div '(rational rational)
     (lambda (x y) (tag (div-rat x y))))
    (put 'make 'rational
     (lambda (n d) (tag (make-rat n d))))
    (put 'equ? '(rational rational)
     (lambda (x y) (equ-rat? x y)))
    (put '=zero? '(rational)
     (lambda (x) (=zero-rat? x)))
    'done))

(install-rational-package)

(define (make-rational n d)
  ((get 'make 'rational) n d))

(equ? (make-rational 1 2) (make-rational 2 4))
;Value: #t

(=zero? (make-rational 0 3))
;Value: #t

(=zero? (make-rational 3 3))
;Value: #f

;;;; complex number package
(define (install-complex-package)
  ;;construct method
  (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) r a))
  (define (add-complex z1 z2)
    (make-from-real-imag (+ (real-part z1) (real-part z2))
             (+ (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (- (real-part z1) (real-part z2))
             (- (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (* (magnitude z1) (magnitude z2))
               (+ (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
               (- (angle z1) (angle z2))))
  (define (equ-complex? z1 z2)
    (and (= (real-part z1) (real-part z2))
     (= (imag-part z1) (imag-part z2))))
  (define (=zero-complex? z)
    (and (= (real-part z) 0) (= (imag-part z) 0)))
  ;;interface to the system
  (define (tag z) (attach-tag 'complex z))
  (begin
    (put 'add '(complex complex)
     (lambda (z1 z2) (tag (add-complex z1 z2))))
    (put 'sub '(complex complex)
     (lambda (z1 z2) (tag (sub-complex z1 z2))))
    (put 'mul '(complex complex)
     (lambda (z1 z2) (tag (mul-complex z1 z2))))
    (put 'div '(complex complex)
     (lambda (z1 z2) (tag (div-complex z1 z2))))
    (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))))
    (put 'equ? '(complex complex)
     (lambda (z1 z2) (equ-complex? z1 z2)))
    (put '=zero? '(complex)
     (lambda (z) (=zero-complex? z)))
    'done))

(install-complex-package)

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

We could add the procedure equ? and =zero? as above.

Exercise 2.81

#!scheme
;; a. It will fall into a infinite loop

;; b. No, Louis is wrong. If the type has procedure proc, then we can apply proc
;; to the type, it it does not have, even after coercion the type, we can not
;; apply it to the type.

;; c.

(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)))
        (if (equal? type1 type2)
            (apply-generic op type1 typ32)
            (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)))))))

Exercise 2.82

Consider the case the two argument has type type1 and type2, and there is a procedure in the table to operate on the combination of type1 and type2, but there is no such procedure to operate on argument (type1,type1) or (type2, type2). Under this case, the strategy here can not adequatelly solve this problem.

Exercise 2.83 - Exercise 2.84

#!scheme
(define (raise-type z)
  (let ((t (type-tag z))
    (c (contents z)))
    (cond ((equal? t 'integer) (make-rational c 1))
      ((equal? t 'rational) (make-real (* 1.0 c)))
      ((equal? t 'real) (make-complex c 0.0))
      (else z))))

(define (coerces-same op z1 z2)
  (let ((t (type-tag z1)))
    (if (equal? t 'complex)
    (let ((proc (get op (t t))))
      (if proc
          (proc z1  z2)
          (error "No method on complex number")))
    (apply-generic op (raise-type z1) (raise-type z2)))))

(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)))
        (if (equal? type1 type2)
            (coerces-same op a1 a2)
            (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)))))))