m2.81

(use pre-sicp2)
"""
pre-sicp.scmにput-coercionなどを書いた
"""

(define (scheme-number->complex n)
  (make-complex-from-real-imag (contents n) 0))

(put-coercion 'scheme-number 'complex scheme-number->complex)
 (let ((t (make-scheme-number 3)))
   (scheme-number->complex t))
;; 7:user> => (complex rectangular 3 . 0)

(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))))))
              (error "No method for these types"
                     (list op type-tags)))))))
;subtype / supertype

;;m2.81
;; (define (scheme-number->schme-number n) n)
;; (define (complex->complex z) z)
;; (put-coercion 'scheme-number 'scheme-number scheme-number->schme-number)
;; (put-coercion 'complex 'complex complex->complex)

;(hash-table-keys coercion-table)

;;a.
;;暴走する。
(define (exp x y) (apply-generic 'exp x y))
(put 'exp '(scheme-number scheme-number)
     (lambda (x y) (expt x y)))

;;試した結果
;;(exp 3 (scheme-number->complex 3))
;; 1:user> 
	;;帰ってこない（無限ループ）
;;   C-c C-c*** UNHANDLED-SIGNAL-ERROR: unhandled signal 2 (SIGINT)

;;b.
;; たぶん、正しくない。
;; もともと同じ型のものをもう一度型変換をするようにしてしまったら、
;; 終了条件が存在しなくなってしまう。
;;　なのでずっと無限ループしてしまう。

;;c.
(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
         (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)))
              (let1 same-type? (eq? type1 type2)
                    (if same-type?
                        (error "No method for these same 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))))))
;;実行結果
(exp (make-scheme-number 3)
     (make-scheme-number 4))
;; 2:user> => 81
;; (exp (make-scheme-number 3)
;;      (make-complex-from-real-imag 3 0))
;; 3:user> *** ERROR: No method for these same types (exp (complex complex))


;;m2.82
(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
         (proc (get op type-tags)))
    ;;第一要素の型を元に、可能な限り型変換を試みる。
    ;;(第一要素が終わったら、第二要素を元にして… restが空リストになったら終了
    (define (try-coercion-to-same-types rest args)
      (define (iter seed)
        (fold-right (lambda (x y)
                      (let1 x->seed (get-coercion (type-tag x) seed)
                             (if x->seed
                                 (cons (x->seed x) y)
                                 (cons x y))))
                    '()
                    args))
      (if (null? rest)
          (error "No methopd for these types" args)
          (let* ((new-args (iter (car rest)))
                 (proc (get op (map type-tag new-args))))
            (if proc
                (apply proc (map contents new-args))
                (try-coercion-to-same-types (cdr rest) new-args)))))
     (if proc
         (apply proc (map contents args))
         (try-coercion-to-same-types type-tags args))))


(put 'add '(scheme-number scheme-number scheme-number)
     (lambda (x y z) (+ x y z)))
(put 'add '(complex complex complex)o
     (lambda (x y z)
       (let1 f (lambda (n) (cons 'complex n))
             (add (add (f x)(f y)) (f z)))))
(define (add . args) (apply apply-generic (cons 'add args)))

;;できた。
(define z (make-complex-from-real-imag 3 2))
(add 10 10 10)
(add z 10 10)
(add 10 z 10)
(add 10 10 z)
(add z z 10)
(add z 10 z)
(add 10 z z)
(add z z z)
;; 21:user> => 30
;; 22:user> => (complex rectangular 23 . 2)
;; 23:user> => (complex rectangular 23 . 2)
;; 24:user> => (complex rectangular 23 . 2)
;; 25:user> => (complex rectangular 16 . 4)
;; 26:user> => (complex rectangular 16 . 4)
;; 27:user> => (complex rectangular 16 . 4)
;; 28:user> => (complex rectangular 9 . 6)


;; ((let1 t (hash-table-get parent-hash 'add)
;;       (hash-table-get t '(complex complex complex)))
;;  z z z)