scheme中的强制操作

前文为了实现同样类型的通用型计算法，采取了计算包的方式。
但还未考虑过，如果是不同类型的数据，该如何进行计算？例如有理数和实数、整数和复数？这之间如何调和。
scheme给出一个“强制”操作用来解决此类问题。

点击查看代码

(define (scheme-number->complex n)(make-complex-from-real-imag (contents n) 0))
(put-coercion 'scheme-number 'complex scheme-number->complex)
(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)))(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))))))(erroe "No method for these types" (list op type-tags))))))

将不同类型的数据强制为同类数据，之后的计算过程与前文类似。 练习2.81 Louis注意到，在两个参数类型实际相同的情况下，apply-generic也可能试图去做参数间的强制。由此他推论需要在强制表格中加入一些过程，将每个参数强制为他们本身的类型。 a）如果真的采用了强制自身的过程，那么在条共apply-generic过程时，各参数类型都为scheme或者complex，而表格中找不到相应的操作，此时会发生什么情况？ 答：该过程会陷入死循环，操作不存在时apply-generic会不断调用自身。 b）Louis真的纠正了有关同样类型参数的强制问题吗？ 答：并未。加入强制自身的过程后，本检索不到相关操作就会报错退出，此时会产生t1->t2、t2->t1的不断循环，程序进入死循环。 c)修改apply-generic，使之不会试着蛆强制两个同样类型的参数。 答：增加一个判断即可，当检索不到proc且参数类型相同时直接报错。

点击查看代码

define (apply-generic op. args)(let ((type-tage (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 请阐述一种方法，设法推广apply-generic，以便处理多个参数的一般性情况下的强制问题。一种可能策略是试着将所有参数都强制到第一个参数的类型，而后试着强制到第二个参数的类型，以此类推。请给出一个例子说明这种策略还不够一般。

点击查看代码

(define (attach-tag type-tag contents)(cons type-tag contents))
(define (type-tag datum)(if (pair? datum)(car datum)(error "Bad tagged datum" datum)))
(define (contents datum)(if (pair? datum)(cadr datum)(error "Bad tagged datum" datum)))
(define (all-the-same? items)(cond ((null? items) #t))((= (length items) 1) #t)(else (if (equal? (car items)(cadr items))(all-the-same? (cdr items))#f)))
(define (for-each-map ops items)(if (null? ops)'()(cons ((car ops)(car items))(for-each-map (cdr ops)(cdr items)))))
(define (map-all-or-false op items)(if (null? items)'()(let ((first-ret (op (car items))))(if first-ret (let ((second-ret (map-all-or-false op (cdr items))))(if second-ret(cons first-ret second-ret)#f))#f))))
(define (get-coercion-list type-tags to-type)(define (identity x) x)(map-all-or-false (lambda (type) (if (equal? type to-type)identity(get-coercion type to-type))) type-tags))
(define (try-coercion-list type-tags args)(define (try-single-coercion type-tags args to-type)(if (null? to-type)#f(let ((coercion-list (get-coercion-list type-tags to-type)))(if coercion-list(for-each-map coercion-list args)(try-single-coercion type-tags args (cdr to-type))))))(if (all-the-same? type-tags?)#f(try-single-coercion type-tags args (car type-tags))))
(define (apply-generic-list op args)(let ((type-tags (map type-tag args)))(let ((proc (get op type-tags)))(if proc(apply proc (map contents args))(let ((coercion-args (try-coercion-args type-tags args)))(if coercion-args(apply-generic-list op coercion-args)(error "No method for these types -- APPLY-GENERIC" (list op type-tags)))))))) 
(define (apply-generic op . args)(apply-generic-list op args))

该方案只能做到直接转换，如果A、B、C三种类型可以A->B、B->C，理论上应该可以A->B->C，但目前的设计只能做到A->C

练习2.83 假定在设计一个通用型算数包，处理类型塔，请为每个类型设计一个过程，它能将该类型的对象提升到塔的上面一层。请说明如何安装一个通用的raise操作，使之能对各个类型工作。

点击查看代码

(define (raise x)(let ((raise-proc (get 'raise (list (type-tag x)))))(if raise-proc(raise-proc (contents x))#f)))
(define (install-rasie-package)(put 'raise '(integer)(lambda (x) (make-ractional x 1)))(put 'raise '(ractional)(lambda (x) (make-real (/ (number x) (denom x)))))(put 'raise '(real)(lambda (x) (make-complex-from-real-imag x 0))))

练习2.84 利用练习2.83里的raise操作修改apply-generic过程，使它能通过逐层提升的方法将参数强制到同样的类型。

点击查看代码

(define (raise-to-type x type)(let ((x-type (type-tag x)))(if (equal? x-type type)x(let ((x-raise (raise x)))(if x-raise(raise-to-type x-raise type)#f)))))
(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 (and (= (length args) 2) (not (equal? (car type-tags) (cadr type-tags))))(let ((a1 (car args))(a2 (cadr args)))(let ((a1-raise (raise-to-type a1 (type-tag a2))))(if a1-raise(apply-generic op a1-raise a2)(let ((a2-raise (raise-to-type a2 (type-tag a1))))(if a2-raise(apply-generic op a1 a2-raise))(error "No method for these types" (list op type-tags))))))(error "No method for these types" (list op type-tags)))))))