练习 2.73

要完成这个练习,需要先实现书本 123 页给出的 putget 函数,这两个函数以及类型表所需的定义可以在书本 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!))

a)

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? 进行数据导向处理是没有必要的。

b)

以下是数据导向版本的加法求导程序,主要修改是因为在求导的过程中已经用 operator 取出了前缀的 '+ 符号,所以 addendaguend 可以少用一次 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))

c)

求导程序的乘幂计算规则和前面的乘法和加法一样,至于计算乘幂的方法,在 练习 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))

d)

包里面的主体程序无须变动,但是调用 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

讨论

blog comments powered by Disqus