计算机程序的构造和解释(SICP) 第2章习题解析 Part7

(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)))
                  ; 进入该步说明没有type1, type2对应的函数, 此时如果类型相同则报错
                  (if (equal? type1 type2)
                      (error "No method for these types" (list op type-tags))
                      (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)))))))

2.82(p137)

事实上，只要是塔型结构，即使参数只有两个，该函数也会出现问题。

考虑图2.26，假设多边形有一个op，假设现在要对三角形和四边形调用该op，那么必然要将两者转换为多边形，但是该过程无法做到这点。

2.83(p137)

参考资料：

http://community.schemewiki.org/?sicp-solutions

整体结构：

2.83helper
- arithmetic.scm
- complex_ari.scm
- integer_ari.scm（新增）
- rational_ari.scm
- real_ari.scm
- raise.scm（新增）
2.83.scm

raise.scm代码如下：

(define (install-raise-package)
    (put 'raise '(integer)
       (lambda (x) (make-rational x 1)))
    (put 'raise '(rational)
       (lambda (x) (make-real (/ (numer x) (denom x)))))
    (put 'raise '(real)
       (lambda (x) (make-complex-from-real-imag x 0)))
)

主代码如下：

(load "2.83helper/arithmetic.scm")

(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))
(define (magnitude z) (apply-generic 'magnitude z))
(define (raise x) (apply-generic 'raise x))

(define d1 (make-integer 1))
(define d2 (raise d1))
(define d3 (raise d2))
(define d4 (raise d3))

(newline)
(display d1)
(newline)
(display d2)
(newline)
(display d3)
(newline)
(display d4)
(newline)
(exit)

结果如下：

(integer . 1)
(rational 1 . 1)
(real . 1)
(complex rectangular 1 . 0)

2.84(p137)

参考资料：

http://community.schemewiki.org/?sicp-ex-2.84

这里假设类型的关系为塔型，所以或者类型$a$可以转换为类型$b$，或者类型$b$可以转换为类型$a$。

整体结构：

2.84helper
- apply.scm（修改）
- arithmetic.scm
- height.scm（新增）
- raise.scm（修改）
2.84.scm

raise.scm增加一个raise k次的函数：

(define (install-raise-package)
    (put 'raise 'integer
        (lambda (x) (make-rational x 1)))
    (put 'raise 'rational
        (lambda (x) (make-real (/ (numer x) (denom x)))))
    (put 'raise 'real
        (lambda (x) (make-complex-from-real-imag x 0)))
)

(define (raise-k-times x k)
    (define raise-x (get 'raise (type-tag x)))
    (if (= k 0)
        x
        (raise-k-times (raise-x (contents x)) (- k 1))))

height.scm定义层级关系：

(define complex-height
    0)
(define real-height
    (+ 1 complex-height))
(define rational-height
    (+ 1 real-height))
(define integer-height
    (+ 1 rational-height))

(define (height type)
    (cond ((eq? type 'complex) complex-height)
          ((eq? type 'real) real-height)
          ((eq? type 'rational) rational-height)
          ((eq? type 'integer) integer-height)))

修改后的apply.scm：

(load "2.84helper/height.scm")
(load "2.84helper/raise.scm")

(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 ((h1 (height type1))
                      (h2 (height type2)))
                     (define h (abs (- h1 h2)))
                  ; 调整
                  (cond ((< h1 h2)
                         (apply-generic op a1 (raise-k-times a2 h)))
                        ((> h1 h2)
                         (apply-generic op (raise-k-times a1 h) a2))
                        (else
                         (apply-generic op a1 a2)))))
              (error "No method for these types"
                     (list op type-tags)))))))

主函数：

(load "2.84helper/arithmetic.scm")

(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))
(define (magnitude z) (apply-generic 'magnitude z))

(define d1 (make-integer 1))
(define d2 (raise-k-times d1 1))
(define d3 (raise-k-times d1 2))
(define d4 (raise-k-times d1 3))
(define d5 (add d1 d2))
(define d6 (add d3 d4))
(define d7 (make-integer 1))

(newline)
(display d1)
(newline)
(display d2)
(newline)
(display d3)
(newline)
(display d4)
(newline)
(display d5)
(newline)
(display d6)
(newline)
(display (eq? d1 d7))

(exit)

测试结果：

(integer . 1)
(rational 1 . 1)
(real . 1)
(complex rectangular 1 . 0)
(rational 2 . 1)
(complex rectangular 2 . 0)
#f

2.85(p137)

由于计算机中实数使用浮点数表示，所以编程无法判断实数是否为有理数，因此这里的只考虑

整数
实数
复数

整体结构：

2.85helper
- apply.scm（修改）
- arithmetic.scm
- drop.scm（新增）
- height.scm（删除有理数部分）
- raise.scm（删除有理数部分）
2.85.scm

drop.scm：

思路是比较简单的，如果(raise(project(x))) = x，那么则可以project；否则返回x。

(load "2.85helper/raise.scm")

(define (install-project-package)
    (put 'project 'complex
        (lambda (x) (make-real (real-part x))))
    (put 'project 'real
        (lambda (x) (make-integer (round x))))
)

(define (drop x)
    (let ((type-x (type-tag x))
          (project-x (get 'project (type-tag x))))
        (if project-x
            (let ((x-project (project-x (contents x))))
                (let ((raise-x (get 'raise (type-tag x-project))))
                    (let ((x-raise (raise-x (contents x-project)))
                          (eq (get 'equ? (list type-x type-x))))
                        (if (eq (contents x) (contents x-raise))
                            (drop x-project)
                            x))))
            x)))

apply.scm：

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          ; 新增
          (drop (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 ((h1 (height type1))
                      (h2 (height type2)))
                     (define h (abs (- h1 h2)))
                  ; 修改
                  (cond ((< h1 h2)
                         (drop (apply-generic op a1 (raise-k-times a2 h))))
                        ((> h1 h2)
                         (drop (apply-generic op (raise-k-times a1 h) a2)))
                        (else
                         (drop (apply-generic op a1 a2))))))
              (error "No method for these types"
                     (list op type-tags)))))))

主程序：

(load "2.85helper/arithmetic.scm")

(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))
(define (magnitude z) (apply-generic 'magnitude z))

; test
(define d1 (make-integer 1))
(define d2 (make-real 1.0))
(define d3 (make-real -1.5))
(define d4 (make-real 2.5))
(define d5 (make-complex-from-real-imag 1.5 2))
(define d6 (make-complex-from-real-imag 1.5 -2))
(newline)
(display (add d1 d2))
(newline)
(display (add d3 d4))
(newline)
(display (add d5 d6))

(exit)

结果如下：

(integer . 2.0)
(integer . 1.0)
(integer . 3.0)

2.86(p137)

参考资料：

http://community.schemewiki.org/?sicp-ex-2.86

这部分如果要完全实现还是比较复杂的，这部分留在完整的运算系统中实现，这里只补充核心部分。

将加减乘除替换为add, sub, mul, div
定义通用的sin, cos, square, sqrt, atan

op.scm：

(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))
(define (magnitude z) (apply-generic 'magnitude z))
(define (raise x) (apply-generic 'raise x))
(define (value x) (apply-generic 'value x))

(define (sine x)
    (sin (value x)))

(define (cosine x)
    (cosine (value x)))

(define (square x)
    (* (value x) (value x)))

(define (sqrt x)
    (sqrt (value x)))

(define (atan x)
    (atan (value x)))