第二章习题 2.73 - 2.97 的解答。

E-2.73:

(a) 因为 number 和 variable 使用的是 scheme 提供的原子类型，并不是自定义的类型。

(b)

(define (install-deriv-package)

  (define (deriv-sum expression var)
    (make-sum ((get 'deriv (operator expression)) (addend expression) var)
              ((get 'deriv (operator expression)) (augend expression) var)))

  (define (deriv-product expression var)
    (make-sum (make-product (multiplier expression)
                            ((get 'deriv (operator expression)) (multiplicand expression) var))
              (make-product ((get 'deriv (operator expression)) (multiplier expression) var)
                            (multiplicand expression))))

  (put 'deriv '+ deriv-sum)
  (put 'deriv '* deriv-product)
  'done)

(d) 需修改所有调用 get 的地方的参数顺序。

E-2.74:

(define (get-record name file)
  ((get 'lookup (file-format file)) name (file-content file)))

(define (get-salary record)
  ((get 'salary (record-format record)) (record-content record)))

(define (find-employee-record name file-list)
  (if (null? file-list)
    '()
    (let ((record (get-record name (car file-list))))
      (if (null? record)
        (find-employee-record name (cdr file-list))
        (record)))))

当收购了新公司后只需将新公司相应的操作添加到表中 (install-*) 即可。

E-2.75:

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

E-2.76: 如果频繁增加类型的话用 data-directed 比较好，因为每增加一种类型只需调用一次 install-* 即可；频繁增加操作的话 message-passing 比较好，只需修改 dispatch 函数即可。

E-2.77: 从 install-complex-package 中可以看到并没有 magnitude 这个函数，所以报错是必然的。添加了新的函数后，“(magnitude z)”的执行过程如下所示（其中 z 的形式为“(complex (rectangular 3 4))”）：

1. (magnitude z):
2. (apply-generic 'magnitude z)：magnitude 的实际定义，第一次执行 apply-generic
3. 在 apply-generic 函数中的“(let ((proc (get op type-tags))))”获得新增加的 magnitude 函数（否则就报错了），这时取出的 proc 是新增的带有“complex”标签的 magnitude
4. 进入“(apply proc (map contents args))”
   1. 这里的 contents 函数把第一个标签“complex”去掉了，只剩“(rectangular 3 4)”
   2. proc 对剩下部分的运算，在本题中就是“(magnitude (rectangular 3 4))”
   3. (apply-generic 'magnitude (rectangular 3 4))：magnitude 的实际定义，第二次执行 apply-generic
   4. 取出带有“rectangular”标签的 magnitude 函数，获得最终结果

E-2.78: 加 tag 时检查一下是否是 number，如果是的话就不加；判断的时候如果是 number 就返回“scheme-number”，否则正常返回。

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

(define (type-tag datum)
  (if (number? datum)
    'scheme-number
    (if (pair? datum)
      (car datum)
      (error "..."))))

(define (contents datum)
  (if (number? datum)
    datum
    (if (pair? datum)
      (cdr datum)
      (error "..."))))

E-2.79: 对于有理数只考虑最简分数的形式。

(define (install-scheme-number-package)
  (put 'equ? (scheme-number scheme-number)
       (lambda (x y) (= x y))))

(define (install-rational-package)
  (put 'equ? (rational rational)
       (lambda (x y) (and (= (numer x) (numer y))
                          (= (denom x) (denom y))))))

(define (install-complex-package)
  (put 'equ? (complex complex)
       (lambda (x y) (and (= (magnitude x) (magnitude y))
                          (= (angle x) (angle y))))))

E-2.80:

(define (install-scheme-number-package)
  (put '=zero? '(scheme-number)
       (lambda (x) (= x 0))))

(define (install-rational-package)
  (put '=zero? '(rational)
       (lambda (x) (= (numer x) 0))))

(define (install-complex-package)
  (put '=zero? '(complex)
       (lambda (x) (and (= (real-part x) 0)
                        (= (imag-part x) 0)))))

E-2.81:

(a) 如果加上自己到自己的转换操作有可能会死循环，因为找不到操作时 apply-generic 会尝试转换到其它类型。（不明白为何会出现这种需求？）
(b) 我觉得不需要自我转换的操作，如果找不到操作直接报错就是了。
(c) 操作时先判断两者是否同样类型。如果是的话就直接找对应类型的函数，否则再做类型提升。

其实我觉得这个例子里的转换有问题，转换无法区分到底是向上转还是向下转。

E-2.82: 题目的意思是把所有参数都转换成参数中类型最高的一个，例如整数，有理数，复数相加，先试试看能不能都转换成整数，如果不能再试试能不能转换成有理数，然后是复数，最后再进行操作。我觉得比较好的策略是先两两处理，例如先处理整数和有理数，只需把整数提升为有理数即可，最后的结果是有理数；然后再把有理数提升至复数和第三个复数运算。

E-2.83:

; integer -> rational
(define (install-integer-package)
  (put 'raise '(integer)
       (lambda (x) (make-rat (contents x) 1))))

; rational -> real
(define (install-rational-package)
  (define (make-real x)
    (attach-tag 'real x))

  (put 'raise '(rational)
       (lambda (x) (make-real (/ (numer x) (denom x))))))

; real -> complex
(define (install-real-package)
  (put 'raise '(real)
       (lambda (x) (make-complex-from-real-imag (contents x) 0))))

E-2.84:

写了个比较恶心的版本……具体做法是：

• 先找出参数中的最高类型，即函数 find-highest-type，返回值是参数中的最高类型；
• 将所有参数都提升到最高类型，即函数 raise-to；
• 回到原来的 apply-generic，不同的是用提升后的参数列表代替了原来的参数列表。

(define (apply-generic op . args)

  (define (find-highest-type args)

    (define (can-raise? arg1 t2)
      (let ((raise (get 'raise (type-tag arg1))))
        (if raise
          (let ((raised-result (raise arg1)))
            (if (eq? (type-tag raised-result) t2)
              #t
              (can-raise? raised-result t2)))
          #f)))

    (define (find-higher arg1 arg2)
      (let ((t1 (type-tag arg1))
            (t2 (type-tag arg2)))
        (cond ((eq? t1 t2) arg1)
              ((can-raise? arg1 t2) arg2)
              (else arg1))))

    (define (find-highest-helper arg1 args)
      (if (null? args)
        (type-tag arg1)
        (find-highest-helper (find-higher arg1 (car args)) (cdr args))))

    (find-highest-helper (car args) (cdr args)))

  (define (raise-to args t)
    (define (raise-to-helper arg)
      (let ((raise (get 'raise (type-tag arg))))
        (if raise
          (let ((raised-result (raise arg)))
            (if (eq? (type-tag raise-result) t)
              raised-result
              (raise-to-helper raised-result t)))
          arg)))

    (map raise-to-helper args))

  (let ((new-args (raise-to args (find-highest-type args)))
        (type-tags (map type-tag new-args))
        (proc (get op type-tags)))
    (if proc
      (apply proc (map contents new-args))
      (error
        "No method for these types -- APPLY-GENERIC"
        (list op type-tags)))))

E-2.85:

转换方法是：

• 先是 rational->integer，这种情况下只有一层；
• 在这题里 real 是浮点数或分数，肯定可以转换成 rational（即分母为 1 的分数），因此先直接降为 rational 然后调用“(get 'drop 'rational)”；
• 先判断 complex 是否能转为 real（看虚部是否为 0），如果可以的话调用“(get 'drop '(real))”看是否能继续往下转；虚部不为 0 则不能转为 real。

一般来说，就是先判断能否直接转为下一层，如果不能就算了，如果可以的话再调用下一层的 drop 函数看是否可以继续往下转。

apply-generic 的一处改动是对“(apply proc (map contents args))”的结果做一次 drop。

; rational -> integer
(define (install-rational-package)
  (define (make-integer x)
    (attach-tag 'integer x))

  (put 'drop '(rational)
       (lambda (x)
         (let ((result (/ (numer x) (demon x))))
           (if (= (round result) result)
             (make-integer result)
             x)))))

; real -> rational -> integer
(define (install-real-package)
  (define (project x)
    (make-rat (contents x) 1))

  (define (drop x)
    ((get 'drop '(rational)) (project x)))

  (put 'drop '(real) drop))

; complex -> real -> rational -> integer
(define (install-complex-package)
  (define (make-real x)
    (attach-tag 'real x))

  (define (drop x)
    (if (= (imag-part x) 0)
      ((get 'drop '(real)) (make-real (real-part x)))
      x))

  (put 'drop '(complex) drop))

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
        (apply-generic 'drop (apply proc (map contents args)))
        (error
          "No method for these types -- APPLY-GENERIC"
          (list op type-tags))))))

E-2.86: 因为复数的实部和虚部都有可能是其它类型的数，所以不能直接用系统的 +-*/，要用对外接口 add/sub/mul/div 根据实际类型取出相应的操作。

(define (add-complex z1 z2)
  (make-from-real-imag (add (real-part z1) (real-part z2))
                       (add (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
  (make-from-real-imag (sub (real-part z1) (real-part z2))
                       (sub (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
  (make-from-mag-ang (mul (magnitude z1) (magnitude z2))
                     (add (angle z1) (angle z2))))
(define (div-complex z1 z2)
  (make-from-mag-ang (div (magnitude z1) (magnitude z2))
                     (sub (angle z1) (angle z2))))

;-----------------------------------------------------------------------------------------

(define (install-rational-package)
  (put 'sin '(rational) (lambda (x)
                          (sin (contents x))))
  (put 'cos '(rational) (lambda (x)
                          (cos (contents x)))))

(define (install-scheme-number-package)
  (put 'sin '(scheme-number) (lambda (x)
                               (sin (contents x))))
  (put 'cos '(scheme-number) (lambda (x)
                               (cos (contents x)))))

E-2.87: 假设其它类型已实现 =zero? 操作。

(define (install-polynomial-package)
  (put '=zero? '(polynomial)
       (lambda (x)
         (if (eq? (type-tag x) 'polynomial)
           (empty-termlist? x)
           (=zero? x)))))

E-2.88: 先实现一个取相反数的操作，这样减去一个数就可以转变为加上这个数的相反数。

(define (install-polynomial-package)
  (define (negative-poly p)
    (define (neg-term t)
      (make-term (order t) (negative (coeff t))))

    (map neg-term (term-list p)))

  (put 'negative '(polynomial) negative-poly)
  (put 'sub '(polynomial polynomial) (lambda (x y)
                                       (add-poly x (negative-poly y)))))

E-2.89: 假设 adjoin-term 按指数从高到低的顺序调用。

(define (adjoin-term term term-list)
  (define (adjoin-helper current-order result)
    (cond ((> (order term) current-order)
           (adjoin-helper (+ current-order 1) (append (list 0) result))
           ((= (order term) current-order)
            (append (list (order term)) result))))

    (if (=zero? (coeff term))
      term-list
      (adjoin-helper term-list (length term-list) '()))))

E-2.90: 这题代码量太大，跳过了。

E-2.91: 举个例子走一遍就明白了，步骤注释在程序中。

(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
                  ;<compute rest of result recursively>
                  (div ; 递归求余数除以除数的结果
                    (sub L1 ; 被除数减去 除数和商相乘的结果 得到的余数
                         (mul L2 ; 除数和商相乘
                              (make-term new-o new-c))) ; 最高次数项的试商结果
                    L2)
                  ))
            ;<form complete result>
            (list (add ; 商相加
                    (make-term new-o new-c) ; 最高次数的商
                    (car rest-of-result)) ; 余数除以除数的商(由递归求得)
                  (cadr (rest-of-result))) ; 最后的余数
            ))))))

(define (div-poly P1 P2)
  (let ((result-terms (div-terms (term-list P1) (term-list P2))))
    (list (make-poly (variable P1) (car result-terms))
          (make-poly (variable P1) (cadr result-terms)))))

E-2.92: 跳过。

E-2.93:

(define (make-rat-modified numer denom)
  (let ((gcd-result (gcd-terms (term-list numer) (term-list denom))))
    (make-rat (div numer (make-poly (variable numer) gcd-result))
              (div denom (make-poly (variable denom) gcd-result)))))

E-2.94:

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

(define (gcd-poly p1 p2)
  (if (not (eq? (variable p1) (variable p2)))
    (error "...")
    (make-poly (variable p1)
               (gcd-terms (term-list p1) (term-list p2)))))

E-2.95: 略。

E-2.96:

(define (pseudoremainder-terms a b)
  (let ((o1 (car (first-term a)))
        (o2 (car (first-term b)))
        (c (cadr (first-term b)))
        (factor (exp c (+ 1 (- o1 o2)))))
    (div-terms a (mul b factor))))

gcd-list 的作用是对多个整数求 gcd，得到 gcd 后再遍历结果，将系数都除以 gcd。

(define (gcd-list l)
  (define (iter result l)
    (if (null? l)
      result
      (iter (gcd result (car l)) (cdr l))))

  (if (null? l)
    #f
    (iter (car l) (cdr l))))

(define (gcd-terms-modified a b)
  (if (empty-termlist? b)
    (if (empty-termlist? a)
      a
      (let ((gcd-value (gcd-list (map cadr a))))
        (map (lambda (x)
               (list (car x) (/ (cadr x) gcd-value)))
             a)))
    (gcd-terms-modified b (pseudoremainder-terms a b))))

E-2.97:

(define (reduce-terms n d)
  (let ((gcd-value (gcd-terms-modified n d)))
    (list (div n gcd-value) (div d gcd-value))))

(define (reduce-poly p1 p2)
  (if (not (eq? (variable p1) (variable p2)))
    #f
    (let ((t1 (term-list p1))
          (t2 (term-list p2))
          (var (variable p1))
          (results (reduce-terms t1 t2)))
      (list (make-poly var (car results))
            (make-poly var (cadr results))))))