要完成这个练习,需要先实现书本 123 页给出的 put
和 get
函数,这两个函数以及类型表所需的定义可以在书本 186 页找到:
;;; p123-put-and-get.scm
(load "p186-make-table.scm")
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
deriv
过程没有对 number?
和 same-variable?
使用数据导向处理的原因是,在求导程序中,数字被直接表示为 Scheme 的数值类型,而变量被直接表示为 Scheme 的符号类型(查看书本 100 页),因此只使用 number?
和 same-variable?
这两种内置的谓词语句,就足以对这两中类型进行判断了,没有必要画蛇添足。
当然,如果一定要做的话,也不是不可以,但是这样一来,求导程序的每个包都要加上 number?
和 same-variable?
谓词,而这样的分派实际上是没有必要的。
举个例子,可以为数字类型加上标识,比如 integer
:
(cons 'integer 10086)
当 deriv
函数接收到这个对象时,它执行查找:
((get 'number? 'integer) 10086)
然后 (get 'number 'integer)
查找过程 number?
,对 10086
进行判断:
(number? 10086)
得出结果 #t
。
虽然结果是正确的,但是你会发现以上的工作实际上就是饶了个圈子,给调用 number?
多增加了一个步骤而已,因此在实际中,对 number?
和 same-variable?
进行数据导向处理是没有必要的。
以下是数据导向版本的加法求导程序,主要修改是因为在求导的过程中已经用 operator
取出了前缀的 '+
符号,所以 addend
和 aguend
可以少用一次 cdr
,其他的和书本 100-101 页的程序类似:
;;; 73-install-sum-package.scm
(load "p123-put-and-get.scm")
(load "73-tag.scm") ; 载入 contents 和 attach-tag
(load "p102-number.scm") ; 载入 =number?
(define (install-sum-package)
;;; internal procedures
(define (addend s)
(car s))
(define (augend s)
(cadr s))
(define (make-sum x y)
(cond ((=number? x 0)
y)
((=number? y 0)
x)
((and (number? x) (number? y))
(+ x y))
(else
(attach-tag '+ x y))))
;;; interface to the rest of the system
(put 'addend '+ addend)
(put 'augend '+ augend)
(put 'make-sum '+ make-sum)
(put 'deriv '+
(lambda (exp var)
(make-sum (deriv (addend exp) var)
(deriv (augend exp) var))))
'done)
(define (make-sum x y)
((get 'make-sum '+) x y))
(define (addend sum)
((get 'addend '+) (contents sum)))
(define (augend sum)
((get 'augend '+) (contents sum)))
测试:
1 ]=> (load "73-install-sum-package.scm")
;Loading "73-install-sum-package.scm"...
; Loading "p123-put-and-get.scm"... done
; Loading "73-tag.scm"... done
;... done
;Value: augend
1 ]=> (load "73-deriv.scm")
;Loading "73-deriv.scm"...
; Loading "p123-put-and-get.scm"... done
;... done
;Value: variable?
1 ]=> (install-sum-package)
;Value: done
1 ]=> (deriv '(+ x 3) 'x)
;Value 11: 1
以下是数据导向版本的乘法求导程序,修改方式和前面的加法求导程序类似:
;;; 73-install-product-package.scm
(load "p123-put-and-get.scm")
(load "73-tag.scm") ; 载入 attach-tag 和 contents
(load "p102-number.scm") ; 载入 =number?
(define (install-product-package)
;;; internal procedures
(define (multiplier p)
(car p))
(define (multiplicand p)
(cadr p))
(define (make-product x y)
(cond ((or (=number? x 0) (=number? y 0))
0)
((=number? x 1)
y)
((=number? y 1)
x)
((and (number? x) (number? y))
(* x y))
(else
(attach-tag '* x y))))
;;; interface to the rest of the system
(put 'multiplier '* multiplier)
(put 'multiplicand '* multiplicand)
(put 'make-product '* make-product)
(put 'deriv '*
(lambda (exp var)
(make-sum
(make-product (multiplier exp)
(deriv (multiplicand exp) var))
(make-product (deriv (multiplier exp) var)
(multiplicand exp)))))
'done)
(define (make-product x y)
((get 'make-product '*) x y))
(define (multiplier product)
((get 'multiplier '*) (contents product)))
(define (multiplicand product)
((get 'multiplicand '*) (contents product)))
测试:
1 ]=> (load "73-deriv.scm")
;Loading "73-deriv.scm"...
; Loading "p123-put-and-get.scm"... done
;... done
;Value: variable?
1 ]=> (load "73-install-sum-package.scm")
;Loading "73-install-sum-package.scm"...
; Loading "p123-put-and-get.scm"... done
; Loading "73-tag.scm"... done
;... done
;Value: augend
1 ]=> (load "73-install-product-package.scm")
;Loading "73-install-product-package.scm"...
; Loading "p123-put-and-get.scm"... done
; Loading "73-tag.scm"... done
;... done
;Value: multiplicand
1 ]=> (install-sum-package)
;Value: done
1 ]=> (install-product-package)
;Value: done
1 ]=> (deriv '(* x y) 'x)
;Value 11: y
因为求导程序的输入表达式有一个操作符和两个操作对象,因此给表达式打上 tag
的程序和书本 119 页的打 tag
程序有些不同:
;;; 73-tag.scm
(define (attach-tag type-tag x y)
(list type-tag x y))
(define (type-tag datumn)
(car datumn))
(define (contents datumn)
(cdr datumn))
求导程序的乘幂计算规则和前面的乘法和加法一样,至于计算乘幂的方法,在 练习 2.56 有介绍:
;;; 73-install-exponentiation-package.scm
(load "p123-put-and-get.scm")
(load "73-tag.scm")
(define (install-exponentiation-package)
;;; internal procedures
(define (base exp)
(car exp))
(define (exponent exp)
(cadr exp))
(define (make-exponentiation base n)
(cond ((= n 0)
0)
((= n 1)
base)
(else
(attach-tag '** base n))))
;;; interface to the rest of the system
(put 'base '** base)
(put 'exponent '** exponent)
(put 'make-exponentiation '** make-exponentiation)
(put 'deriv '**
(lambda (exp var)
(let ((n (exponent exp))
(u (base exp)))
(make-product
n
(make-product
(make-exponentiation
u
(- n 1))
(deriv u var))))))
'done)
(define (make-exponentiation base n)
((get 'make-exponentiation '**) base n))
(define (base exp)
((get 'base '**) (contents exp)))
(define (exponent exp)
((get 'exponent '**) (contents exp)))
测试:
1 ]=> (load "73-deriv.scm")
;Loading "73-deriv.scm"...
; Loading "p123-put-and-get.scm"... done
;... done
;Value: variable?
1 ]=> (load "73-install-sum-package.scm") ; 因为 product 包要用到 sum 包
;Loading "73-install-sum-package.scm"...
; Loading "p123-put-and-get.scm"... done
; Loading "73-tag.scm"... done
; Loading "p102-number.scm"... done
;... done
;Value: augend
1 ]=> (load "73-install-product-package.scm") ; 因为 exponentiation 包要用到 product 包
;Loading "73-install-product-package.scm"...
; Loading "p123-put-and-get.scm"... done
; Loading "73-tag.scm"... done
; Loading "p102-number.scm"... done
;... done
;Value: multiplicand
1 ]=> (load "73-install-exponentiation-package.scm")
;Loading "73-install-exponentiation-package.scm"...
; Loading "p123-put-and-get.scm"... done
; Loading "73-tag.scm"... done
;... done
;Value: exponent
1 ]=> (install-sum-package)
;Value: done
1 ]=> (install-product-package)
;Value: done
1 ]=> (install-exponentiation-package)
;Value: done
1 ]=> (deriv '(** x 3) 'x)
;Value 11: (* 3 (** x 2))
包里面的主体程序无须变动,但是调用 put
的参数的位置需要调整。
比如原本的:
(put 'make-sum '+ make-sum)
现在要改成:
(put '+ 'make-sum make-sum)
但是 make-sum
程序本身不必修改。
测试(为了方便起见,使用一个 square
函数作例子):
1 ]=> (load "p123-put-and-get.scm")
;Loading "p123-put-and-get.scm"... done
;Value: put
1 ]=> (put 'square 'scheme-number square)
;Value: ok
1 ]=> (get 'square 'scheme-number)
;Value 11: #[compiled-procedure 11 ("arith" #x110) #xf #x1ea533]
1 ]=> ((get 'square 'scheme-number) 10)
;Value: 100