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)))))))