乐正

Actions speak louder than words.

Sicp-ex2-85

问题

本节中提到了“简化”数据对象表示的一种方法,就是使之在类型塔中经可能地下降。请设计 一个过程drop(下落),使它能在如练习2.83所描述的类型塔中完成这一工作。这里的关 键是以某种一般性的方式,判断一个数据对象能否下降。举例来说,复数$1.5 + 0i$至多可 以下降到real,复数$1 + 0i$至多可以下降到integer,而复数$2 + 3i$就根本无法下降。 现在提出一种确定一个对象能否下降的计划:首先定义一个运算project(投影),它将 一个对象压到塔的下面一层。例如,投影一个复数就是掉丢其虚部。这样一个数能够向下落, 如果我们首先project它而后将得到的结果raise到开始的类型,最终得到的东西与开始 的东西相等。请阐述实现这一想法的具体细节,并写出一个drop过程,是它可以将一个对 像尽可能的下落。你将需要设计各种各样的投影函数,并需要把project安装为系统里的一 个通用型操作。你还需要使用一个通用型的相等谓词,例如练习2.79所描述的。最后,利用 drop重写练习2.84的apply-generic,使之可能简化其结果。

解答

练习2.85 (ex2-85.scm) download
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
(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 (not (eq? type1 type2))
                    (cond ((is-parent a1 (contents a2))
                           (drop (apply-generic op a1 (raise a2))))
                          ((is-parent a2 (contents a1))
                           (drop (apply-generic op (raise a1) a2)))
                          (else
                            (let ((t1->t2 (get-coercion type1 type2))
                                  (t2->t1 (get-coercion type2 type1)))
                              (cond (t1->t2
                                      (drop (apply-generic op (t1->t2 a1) a2)))
                                    (t2->t1
                                      (drop (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))))
              (error "No method for these types"
                     (list op type-tags)))))))

(define (is-parent arg1 arg2)
  (cond ((not (pair? arg1)) #f)
        ((eq? (type-tag arg1) (type-tag arg2)) #t)
        (else (is-parent (contents arg1) arg2))))

(define (drop arg)
  (if (equ? arg (raise (project arg)))
      (drop (project arg))
      arg))

(define (project arg)
  (apply-generic 'project arg))

(define (equ? x y) (apply-generic 'equ? x y))

(define (install-equ?-package)
  (put 'equ? '(scheme-number scheme-number)
       (lambda (x y) (= x y)))
  (put 'equ? '(rational rational)
       (lambda (x y) (and (= (numer x) (numer y))
                          (= (denom x) (denom y)))))
  (put 'equ? '(complex complex)
       (lambda (x y) (and (= (real-part x) (real-part y))
                          (= (imag-part x) (imag-part y)))))
  'done)

(define (install-project-package)
  (define (complex-project z)
    (make-rational (real-part z) 1))

  (define (rational-project x)
    (make-scheme-number (numer x)))

  (put 'project '(complex) complex-project)
  (put 'project '(rational) rational-project)

  'done)

draft

« sicp-ex2-84 sicp-ex2-86 »

Comments