SICP-Refresher-Chapter-2(5)

带有通用型操作的系统

通过通用型界面过程，不但能够定义出在不同表示上的通用操作，还能定义针对不同参数种类的通用型操作；
这一系统具有可加性，这样，人们还可以设计出其他独立的算术包，并将其组合到这一通用型的算术系统中；

通用型算术运算

在一个大型的复杂系统里可能有许多层次，每层与下一层次之间的连接都借助于一些通用型操作，当一个数据对象被“向下”传输时，用于引导它进入适当程序包的最外层标志被剥除，下一层次的标志（如果有的话）变成可见的，并将被用于下一次分派；

练习 2.77-2.80

2.77

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17


(define z (make-from-real-imag 3 4))

;; 如 通用型算术运算 第一条笔记所记录的；

;; (magnitude z)
;; (apply-generic 'magnitude z)
;; (apply (get 'magnitude '(complex)) (map contents z))
;; (apply magnitude (cons 'rectangular (cons 3 4)))
;; (apply-generic 'magnitude (cons 'rectangular (cons 3 4)))
;; (apply (get 'magnitude '(rectangular)) (cons 3 4))
;; (magnitude (cons 3 4))
;; (sqrt (+ (square (real-part (cons 3 4))) (square (imag-part (cons 3 4)))))
;; ...

;; apply-generic 被调用两次；
;; 第一次调用中分派的是复数计算包的 magnitude
;; 第二次调用中分派的是直角坐标表示计算包的 magnitude

2.78

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16


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

(define (type-tag datum)
  (cond ((number? datum) 'scheme-number)
	((pair? datum) (car datum))
	(else
	 (error "Bad tagged datum -- CONTENTS" datum))))

(define (contents datum)
  (cond ((number? datum) datum)
	((pair? datum) (cdr datum))
	(else
	 (error "Bad tagged datum -- CONTENTS" datum))))

2.79

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22


;; 下面对应各个计算包的三个代码块最好是放置在各自的安装包安装过程中
(define (equ-number? n1 n2)
  (= n1 n2))
(put 'equ? '(scheme-number scheme-number) equ-number?)

(define (equ-rational? r1 r2)
  (let ((product1 (* (numer r1) (denom r2)))
	(product2 (* (denom r1) (numer r2))))
    (= product1 product2)))
(put 'equ? '(rational rational) equ-rational?)

(define (equ-complex? c1 c2)
  (let ((real1 (real-part c1))
	(imag1 (imag-part c1))
	(real2 (real-part c2))
	(imag2 (imag-part c2)))
    (and (= real1 real2) (= imag1 imag2))))
(put 'equ? '(complex complex) equ-complex?)

;; 通用型相等谓词 equ? 接口
(define (equ? x y)
  (apply-generic 'equ? x y))

2.80

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18


;; 下面对应各个计算包的三个代码块最好是放置在各自的安装包安装过程中
(define (=zero-number? n)
  (= n 0))
(put '=zero? '(scheme-number) =zero-number?)

(define (=zero-rational? r)
  (= (numer r) 0))
(put '=zero? '(rational) =zero-rational?)

(define (=zero-complex? c)
  (let ((real (real-part c))
	(imag (imag-part c)))
    (and (= real 0) (= imag 0))))
(put '=zero? '(complex) =zero-complex?)

;; 通用谓词 =zero? 接口
(define (=zero? x)
  (apply-generic '=zero? x))

不同类型数据的组合

我们一直煞费苦心地在程序的各个部分之间引进了屏障，以使它们能够分别开发和分别理解，现在却又要引进跨类型的操作，我们必须以一种经过精心考虑的可控方式去做这件事请，以使我们在支持这种操作的同时又没有严重地损害模块间的分界；
在设计包含许多程序包和许多跨类型操作的系统时，要想规划好一套统一的策略，分清各种包之间的责任，很容易变成非常复杂的任务；
不同的数据类型通常都不是完全相互无关的，常常存在一些方式，使我们可以把一种类型的对象看作另一种类型的对象，类型之间的适当转换只依赖于类型本身，而不依赖于所实际应用的操作（强制）；
即使需要运算的两种类型的对象都不能转换到另一种类型，也完全可能在将这两种类型的对象都转换到第三种类型后执行这一运算（类型的层次结构）；

练习 2.81-2.86

2.81

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38


;; a

;; 这种情况下，对两个复数调用 exp 将会使程序进入无尽递归进而报错；

;; b

;; 并没有纠正有关同样类型参数的强制问题；

;; 反而引入了新的问题使 apply-generic 无法正常工作，当两个参数是同样类型且并没有
;; 可用的通用型操作时，这样的修改将会使程序进入无尽递归进而报错；


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

2.82

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53


(define (transfer-1 base element)
  (let ((tag (type-tag element)))
    (if (equal? base tag)
	element
	(let ((proc (get-coercion tag base)))
	  (if proc
	      (proc element)
	      false)))))

(define (iter-transfer base args result)
  (if (null? args)
      result
      (let ((element (car args))
	    (left (cdr args)))
	(let ((transfer-one (transfer-1 base element)))
	  (if transfer-one
	      (iter-transfer base left (cons transfer-one result))
	      false)))))


(define (transfer type-tags args)
  (if (null? type-tags)
      #f
      (let ((base (car type-tags))
	    (left-type-tags (cdr type-tags)))
	(let ((result (iter-transfer base args '())))
	  (if result
	      result
	      (transfer left-type-tags args))))))


(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))
	  (let ((transfer-result (transfer type-tags args)))
	    (if transfer-result
		;; (apply-generic op . args)的错误调用形式
		;; 这里转换后的所有参数构成了一个表；
		;; apply-generic 会将此表整体当作最后一个参数，这是错误的
		;; 当然本题重点不在这，但如果有解决办法会更好；
		(apply-generic op (reverse transfer-result))
		(error "No method for these types"
		       (list op type-tags))))))))

;; 像这样的情况；
;; type1->type2 存在
;; type3->type1 存在
;; 最差的情况: 其他两种转换方式（转换到 type1, type3）并不存在;
;; 然后全部转换到 type2 的路也行不通，因为 type3 只能直接转换到 type1;
;; 本程序实现上没法转换成功，但其实可以在 type3 转换到 type1 之后再转换到 type2,
;; 这样就全部转换成同一类型了。

2.83

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18


(define (install-raise)
  (put 'raise '(scheme-number) scheme-number->rational)
  (put 'raise '(rational) rational->real)
  (put 'raise '(real) real->complex))

(define (raise number)
  (apply-generic 'raise number))

(define (scheme-number->rational number)
  (make-rational number 1))

;; 我们并没有实现实数计算包
;; 在这里假设它已经被实现了并加入了此通用计算系统中
(define (rational->real number)
  (make-real (/ (numer number) (denom number))))

(define (real->complex number)
  (make-from-real-imag number 0))

2.84

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50


;; 在原来的表格中安装类型塔（其实就是一个按次序放置类型的表）
(define (install-types-tower)
  (let ((types-tower (list 'scheme-number
			   'rational
			   'real
			   'complex)))
    (put 'types-tower 'number types-tower)))

;; 判断类型1和类型2的类型塔中次序
(define (lower-one type1 type2)
  (let ((types-tower (get 'types-tower 'number)))
    (let ((left-type1-tower (memq type1 types-tower))
	  (left-type2-tower (memq type2 type-tower)))
      (if (and left-type1-tower left-type2-tower)
	  (> (length left-type1-tower) (length left-type2-tower))
	  (error "Invalid type" type1 type2)))))

;; 在 apply-generic 中加入类型提升机制
(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)))
		(cond ((equal? type1 type2)
		       (error "No method for these types"
			      (list op type-tags)))
		      ((lower-one t1 t2)
		       (apply-generic op (raise a1) a2))
		      (else (apply-generic op a1 (raise a2)))))
	      (error "No method for these types"
		     (list op type-tags)))))))

;; 类型塔的另一种安装方式（来自网络，比我的解决方案高效）
;; 重构 lower-one 过程，apply-generic 不用修改；
(define (install-level-package)
  (put 'level 'scheme-number 1)
  (put 'level 'rational 2)
  (put 'level 'real 3)
  (put 'level 'complex 4)
  (put 'level 'rectangular 4)
  (put 'level 'polar 4)
  'done)

(define (level type)
  (get 'level type))

2.85

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73


;; install project
(define (project-rational x)
  (make-scheme-number (round (/ (numer x) (denom x)))))
(define (project-real x)
  (make-scheme-number (round x)))
;; 我们并没有实现实数计算包
;; 在这里假设它已经被实现了并加入了此通用计算系统中
(define (project-complex x)
  (make-real (real-part x)))

(define (install-project)
  (put 'project '(rational) project-rational)
  (put 'project '(real) project-real)
  (put 'project '(complex) project-complex)
  'done)

(define (projectt x)
  (apply-generic 'project x))

;; install drop
(define (drop-scheme-number x)
  x)

(define (drop-rational x)
  (let ((a (project x)))
    (if (equ? (raise a) x)
	a
	x)))

(define (drop-real x)
  (let ((a (project x)))
    (if (equ? (raise (raise a)) x)
	a
	x)))

(define (drop-complex x)
  (let ((a (project x)))
    (if (equ? (raise a) x)
	(drop a)
	x)))

(define (install-drop)
  (put 'drop '(scheme-number) drop-scheme-number)
  (put 'drop '(rational) drop-rational)
  (put 'drop '(real) drop-real)
  (put 'drop '(complex) drop-complex)
  'done)

(define (drop n)
  (apply-generic 'drop n))


(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
	  (let ((res (apply proc (map contents args))))
	    (if (or (eq? op 'raise) (eq? op 'equ?) (eq? op 'drop))
		res
		(drop res)))
	  (if (= (length args) 2)
	      (let ((type1 (car type-tags))
		    (type2 (cadr type-tags))
		    (a1 (car args))
		    (a2 (cadr args)))
		(cond ((equal? type1 type2)
		       (error "No method for these types"
			      (list op type-tags)))
		      ((lower-one t1 t2)
		       (apply-generic op (raise a1) a2))
		      (else (apply-generic op a1 (raise a2)))))
	      (error "No method for these types"
		     (list op type-tags)))))))

2.86

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48


;;; 全局环境
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (arctan x) (apply-generic 'arctan x))
(define (exp x y) (apply-generic 'exp x y))

;; 下面的过程应该置于常规数计算包的安装过程中
(put 'sine '(scheme-number) (lambda (x) (tag (sin x))))
(put 'cosine '(scheme-number) (lambda (x) (tag (cos x))))
(put 'arctan '(scheme-number scheme-number) (lambda (y x) (tag (atan y x))))
(put 'exp '(scheme-number scheme-number) (lambda (x y) (tag (expt x y))))

;; 下面的过程应该置于有理数计算包的安装过程中
;; assume that there is a way of computing numer and denom from real number(*.*)
;; 假设有一个过程可以从实数中算出精确程度达到某一量级的 分子分母 表示序对
(put 'sine '(rational) (lambda (x) (tag (get_numer_denom (sin (/ (numer x) (denom x)))))))
(put 'cosine '(rational) (lambda (x) (tag (get_numer_denom (cos (/  (numer x) (denom x)))))))
(put 'arctan '(rational rational)
     (lambda (y x) (tag (get_numer_denom
		    (atan (/ (numer y) (denom x)) (/ (numer x) (denom x)))))))
(put 'exp '(rational rational)
     (lambda (x y) (tag (get_numer_denom
		    (expt (/ (numer x) (denom x)) (/ (numer y) (denom y)))))))

 ;;; 直角坐标系复数包
(define (square x) (mul x x))
(define (sqrt x) (exp x 0.5))
(define (make-from-mag-ang r a) (cons (mul r (cosine a)) (mul r (sine a))))
(define (magnitude z) (sqrt (add (square (real-part z)) (square (imag-part z)))))
(define (angle z) (arctan (imag-part z) (real-part z)))

 ;;; 极坐标表示复数包
(define (real-part z) (mul (magnitude z) (cosine (angle z))))
(define (imag-part z) (mul (magnitude z) (sine (angle z))))

 ;;; 复数包
(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))))

实例：符号代数

展示在设计这样一个系统时所面临的各种抉择，以及如何应用 抽象数据 和 通用型操作 的思想，以利于组织好这一工作项目；
单变元多项式；
在这一代数演算系统里，一个“多项式”就是一种特殊的语法形式，而不是在其之下的数学意义；
默认被操作的大部份多项式运算都是稀疏多项式。

练习 2.87-2.97

2.87

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14


(define (install-poly-zero?)
  (define (=zero?-p p)
    (define (recursive terms)
      (if (empty-termlist? terms)
	  true
	  (let ((first (first-term terms))
		(rest (rest-terms terms)))
	    (if (=zero? (coeff first))
		(recursive rest)
		false))))
    (recursive (term-list p)))
  (put '=zero? 'polynomial =zero?-p))

(install-poly-zero?)

2.88

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35


(define (install-negative)
  (define (negative-scheme-number n)
    (make-scheme-number (- n)))

  (define (negative-rational n)
    (make-rational (negative (numer n)) (denom n)))

  (define (negative-complex n)
    (make-complex-from-real-imag (negative (real-part n)) (negative (imag-part n))))

  (define (negative-poly n)
    (define (recursive-t terms)
      (if (empty-termlist? terms)
	  the-empty-termlist
	  (let ((first (first-term terms)))
	    (adjoin-term (make-term
			  (order first)
			  (negative (coeff first)))
			 (recursive-t (rest-terms terms))))))
    (make-poly (variable n) (recursive-t (term-list n))))

  (put 'negative '(scheme-number) negative-scheme-number)
  (put 'negative '(rational) negative-rational)
  (put 'negative '(complex) negative-complex)
  (put 'negative '(polynomial) negative-poly))

(define (negative n)
  (apply-generic 'negative n))

(define (sub-poly p1 p2)
  (add-poly p1 (negative p2)))

;; add this into install-polynomial-package
(put 'sub '(polynomial polynomial)
     (lambda (x y) (tag (sub-poly x y))))

2.89

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11


;; 其他过程不用修改

(define (first-term term-list)
  (make-term (- (len term-list) 1) (car term-list)))

(define (adjoin-term term term-list)
  (cond ((=zero? (coeff term)) term-list)
	((=equ? (order term) (length term-list))
	 (cons (coeff term) term-list))
	((> (order term) (length term-list))
	 (adjoin-term term (cons 0 term-list))))) ;the order of term would never be smaller than the length

2.90

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131


;; 安装多项式项表的‘项’包
(define (install-poly-term-package)
  ;; procedures kept same
  (define (make-term order coeff) (list order coeff))
  (define (order term) (car term))
  (define (coeff term) (cadr term))
  ;; tag
  (define (tag term)
    (attach-tag 'polynomial-term term))
  ;; put
  (put 'make 'polynomial-term
       (lambda (x y) (tag (make-term x y))))
  (put 'order '(polynomial-term) order)
  (put 'coeff '(polynomial-term) coeff)
  )
(define (make-term x y)
  ((get 'make 'polynomial-term) x y))
(define (order x)
  (apply-generic 'order x))
(define (coeff x)
  (apply-generic 'coeff x))

;; 安装密集表示的项表包
(define (install-dense-terms-package)
  ;; procedures about dense terms...

  ;; prcedures kept same:
  ;; rest-terms
  ;; empy-termlist?

  ;; and delete procedure the-empty-termlist;
  ;; replace call of the-empty-termlist with
  ;; 'L1' or 'L' in 'mul-term' & 'mul-term-by-all-terms'
  (define (tag terms)
    (attach-tag 'polynomial-dense terms))
  (define (first-term term-list)
    (make-term (- (len term-list) 1) (car term-list)))
  (define (adjoin-term term term-list)
    (cond ((=zero? (coeff term)) term-list)
	  ((=equ? (order term) (length term-list))
	   (cons (coeff term) term-list))
	  ((> (order term) (length term-list))
	   (adjoin-term term (cons 0 term-list))))) ;
  (define (negative-t terms)
    (if (empty-termlist? terms)
	the-empty-termlist
	(let ((first (car terms)))
	  (const (negative first)
		 negative-t (rest-terms terms))))
    (put 'negative '(polynomial-dense)
	 (lambda (x) (tag (negative-t x))))
    (put 'first-term '(polynomial-dense)
	 (lambda (x) (first-term x)))
    (put 'empty-termlist? '(polynomial-dense) empty-termlist?)
    (put 'rest-terms '(polynomial-dense)
	 (lambda (x) (tag (rest-terms x))))
    (put 'adjoin-term 'polynomial-dense
	 (lambda (x y) (tag (adjoin-term x y))))))

;; 安装稀疏表示的项表包
(define (install-sparse-terms-package)
  ;; procedures about sparse terms...

  ;; procedure rest-terms? and so on, define and put
  ;; prcedures kept same:
  ;; rest-terms
  ;; empy-termlist?

  ;; and delete procedure the-empty-termlist;
  ;; replace call of the-empty-termlist with
  ;; 'L1' or 'L' in 'mul-term' & 'mul-term-by-all-terms'

  (define (tag terms)
    (attach-tag 'polynomial-sparse terms))
  (define (first-term term-list) (car term-list))
  (define (adjoin-term term term-list)
    (if (=zero? (coeff term))
	term-list
	(cons term term-list)))
  (define (negative-t terms)
    (if (empty-termlist? terms)
	the-empty-termlist
	(let ((first (first-term terms)))
	  (adjoin-term (make-term
			(order first)
			(negative (coeff first)))
		       (negative-t (rest-terms terms))))))
  (put 'negative '(polynomial-sparse)
       (lambda (x) (tag (negative-t x))))
  (put 'first-term '(polynomial-sparse)
       (lambda (x) (first-term x)))
  (put 'empty-termlist? '(polynomial-sparse) empty-termlist?)
  (put 'rest-terms '(polynomial-sparse)
       (lambda (x) (tag (rest-terms x))))
  (put 'adjoin-term 'polynomial-sparse
       (lambda (x y) (tag (adjoin-term x y)))))


;; 稀疏和密集项表表示的通用型操作
(define (first-term x)
  (apply-generic 'first-term x))

(define (adjoin-term x y)
  ((get 'adjoin-term (type-tag y)) x (contents y)))

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

(define (empty-termlist? x)
  (apply-generic 'empty-termlist x))

(define (rest-terms x)
  (apply-generic 'rest-terms x))


;; 多项式计算包
(define (install-polynomial-package)
  ;; internal procedures...

  ;; replace call of procedure the-empty-termlist with
  ;; 'L1' or 'L' in 'mul-term' & 'mul-term-by-all-terms'
  ;; add-terms
  ;; mul-terms
  ;; sub-terms

  ;; others kept same

  (put 'sub '(poly poly)
       (lambda (x y) (tag 'polynomial (sub-poly x y)))) ;2.88
  ;; and so on.
  )

2.91

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27


(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 ((nwe-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)))
		(list (addjoin-term (make-term new-o new-c)
				    (car rest-of-result))
		      (cadr rest-of-result))))))))

;; div-terms 结果的余数部分在 div-poly 过程中是不需要的
(define (div-poly p1 p2)
  (if (same-variable? (variable p1) (variable p2))
      (let ((t1 (term-list p1))
	    (t2 (term-list p2)))
	(let ((result (div-terms t1 t2)))
	  (make-poly (variable p1)
		     (car result))))
      (error "Polys not in same var -- DIV-POLY"
	     (list p1 p2))))

2.92

1
2
3


;; 去年写的代码现在完全理解不了；
;; 暂时想不出更好更清晰的解答；
;; 暂时搁置；

2.93

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36


(define (install-scheme-number-package)
  ;; gcd-scheme-number 就是原来最初的 gcd 的别名
  ;; 其他过程不变
  (put 'gcd '(scheme-number scheme-number)
       (lambda (s1 s2) (tag (gcd-scheme-number s1 s2))))
  )

(define (install-rational-package)
  ;; 将 +, -, *, / 改为 add, sub, mul, div
  (define (make-rat n d)
    (let ((g (greatest-common-divisor n d)))
      (cons (div n g) (div d g))))
  ;; 其他过程不变
  )

(define (install-polynomial-package)
  ;; 其他过程不变
  (define (gcd-poly a b)
    (define (remainder-terms t1 t2)
      (cadr (div-terms t1 t2)))
    (define (gcd-terms t1 t2)
      (if (empty-termlist? t2)
	  t1
	  (gcd-terms t2 (remainder-terms t1 t2))))
    (if (same-variable? (variable a) (variable b))
	(let ((t1 (term-list a))
	      (t2 (term-list b)))
	  (make-poly (variable a) (gcd-terms t1 t2)))
	(error "Polys not in same var -- GCD-POLY"
	       (list a b))))
  (put 'gcd '(polynomial polynomial)
       (lambda (p1 p2) (tag (gcd-poly p1 p2))))
  )

(define (greatest-common-divisor a b)
  (apply-generic 'gcd a b))

2.94

1

;; 在 ex 2.93 中全部完成了（相关代码放在一起更好）。

2.95

1

;; 按题意定义多项式，求多项式最大公约数，比较。

2.96

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42


;; 只适用于整数系数的多项式

;; a
(define (pseudoremainder-terms a b)
  (let ((f1 (first-term a))
	(f2 (first-term b)))
    (let ((o1 (order f1))
	  (o2 (order f2))
	  (c (coeff f2)))
      (let ((constant (expt c (+ 1 o1 (- o2)))))
	(let ((term (make-term 0
			       constant)))
	  (cadr (div-terms
		 (mul-term-by-all-terms term a)
		 b)))))))


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

;; b
(define (gcd-terms a b)
  (define (gcd-terms-coeff terms)
    (let ((coeffs (map (lambda (t) (coeff t)) terms)))
      (define (recursive coeffs)
	(if (null? (cddr coeffs))
	    (greatest-common-divisor
	     (car coeffs)
	     (cadr coeffs))
	    (greatest-common-divisor
	     (car coeffs)
	     (recursive coeffs))))
      (recursive coeffs)))

  (if (empty-termlist? b)
      (let ((coeffs-gcd (gcd-terms-coeff a)))
	(div-terms
	 a
	 (list (make-term 0 coeffs-gcd))))
      (gcd-terms b (pseudoremainder-terms a b))))

2.97

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55


;; (load "./2.96.scm")
;; a

(define (reduce-terms n d)
  (define (compute-constant a b c)
    (let ((af (first-term a))
	  (bf (first-term b))
	  (cf (first-term c)))
      (let ((c (coeff af))
	    (o1 (max (order bf) (order cf)))
	    (o2 (order af)))
	(expt c (+ 1 o1 (- o2))))))
  (define (simplify a b)
    (let ((g (gcd-terms-coeff (append a b))))
      (let ((sa (car (div-terms a (list (make-term 0 g)))))
	    (sb (car (div-terms b (list (make-term 0 g))))))
	(list sa sb))))
  (let ((g (gcd-terms n d)))
    (let ((constant (compute-constant g n d)))
      (let ((mn (mul-term-by-all-terms (make-term 0 constant) n))
	    (md (mul-term-by-all-terms (make-term 0 constant) d)))
	(let ((gn (car (div-terms mn g)))
	      (gd (car (div-terms md g))))
	  (simplify gn gd))))))

(define (reduce-poly p1 p2)
  (if (same-vaiable? (variable p1) (variable p2))
      (let ((t1 (term-list p1))
	    (t2 (term-list p2)))
	(let ((result (reduce-terms t1 t2)))
	  (list (make-poly (variable p1) (car result))
		(make-poly (variable p1) (cadr result)))))
      (error "Polys not in same variable -- REDUCE-POLY"
	     (list p1 p2))))

;; b

;; inside procedure install-scheme-number-package
(define (reduce-integers n d)
  (let ((g (gcd n d)))
    (list (/ n g) (/ d g))))
(put 'reduce '(scheme-number scheme-number)
     (lambda (n d) (map tag (reduce-integers n d))))

;; inside procedure install-polynomial-package
(put 'reduce '(polynomial polynomial)
     (lambda (n d) (map tag (reduce-poly n d))))

;; inside procedure install-rational-package
(define (make-rat n d)
  (let ((simple (reduce n d)))
    (cons (car simple) (cadr simple))))

(define (reduce n d)
  (apply-generic 'reduce n d))

文章目录

带有通用型操作的系统

通用型算术运算

练习 2.77-2.80

2.77

2.78

2.79

2.80

不同类型数据的组合

练习 2.81-2.86

2.81

2.82

2.83

2.84

2.85

2.86

实例：符号代数

练习 2.87-2.97

2.87

2.88

2.89

2.90

2.91

2.92

2.93

2.94

2.95

2.96

2.97