(sicp33)m2.83~m2.84

疲れた＞＜。
type-x>y?は作ってみたけど使わなかった。
(比較する度に階数を計算するのは効率が悪そうだし…)

;;m2.83
"""
順序 integer -> rational -> real -> complex
"""

(define (install-raise-package)
  (define (integer->rational i)
    (make-rational (contents i)  1))



  (define (rational->real r)
    (make-real (/ (numer r) (denom r))))
  (define (numer r) (car (contents r)))
  (define (denom r) (cdr (contents r)))

  (define (real->complex r)
    (make-complex-from-real-imag (contents r) 0))
  (put 'raise 'integer integer->rational)
  (put 'raise 'rational rational->real)
  (put 'raise 'real real->complex))

(define (make-real n) (attach-tag 'real n))
(define (make-rat n d) (attach-tag 'rat (cons n d)))
(define (make-integer i) (attach-tag 'integer i))
(define (my-raise n)
  (let1 proc (get 'raise (type-tag n))
         (if proc (proc n) n)))

(install-raise-package)

(make-integer 3)
(my-raise (make-integer 3))
(make-rat 3 2)
(my-raise (make-rat 3 2))
(make-real 0.3333)
(my-raise (make-real 0.333))

;; 1:user> => (integer 3)
;; 2:user> => (rational 3 . 1)
;; 3:user> => (rat (3 . 2))
;; 4:user> => (real 3/2)
;; 5:user> => (real 0.3333)
;; 6:user> => (complex rectangular 0.333 . 0)

;;たぶん、こんな感じでいいはず…
;;realのところで3/2がでているけど、これはgaucheの仕様っぽいのでいいや
;;（実数で表示する方法もあるのかな？）

;;m2.84
(define tower '(scheme-number rational real complex))

(define (type-level item)
  (define (look-up item tower count)
    (if (eq? (car tower) item)
        count
        (look-up item (cdr tower) (+ count 1))))
  (unless tower
    (let1 tower '(scheme-number rational real complex))) 
          (look-up item tower 0))

(define (type-x>y? x y)
  (unless tower
    (let1 tower '(scheme-number rational real complex)))
        (if (> (type-level x) (type-level y)) #t  #f))

(type-x>y? 'complex 'complex) ;;#f
(type-x>y? 'rational 'scheme-number) ;;#t

;;上のはintegerでした＞＜
(put 'raise 'scheme-number (lambda (x) (make-rational x 1)))

(define (apply-generic op . args)
  ;;もっとも高い型に揃える
  (define (raise-type args)
    (define (level x) (type-level (type-tag x)))
    (define (iter x hlv)
      (if (> hlv (level x)) (iter (my-raise x) hlv) x))
    (let1 highestlv
          (fold-right
           (lambda (x mlv)
             (let1 xlv (level x)
                   (if (> xlv mlv) xlv mlv)))
           0 args)
          (fold-right
           (lambda (x y)
             (if (> highestlv (level x))
                 (cons (iter x highestlv) y)
                 (cons x y)))
           '()
           args)))
  (let* ((type-tags (map type-tag args))
         (proc (get op type-tags)))
    (if proc
        (apply proc (map contents args))
        (let* ((new-args (raise-type args))
               (new-type-tags (map type-tag new-args))
               (new-proc (get op new-type-tags)))
           (if new-proc
               (apply new-proc (map contents new-args))
               (error "methods is not found" (list op new-args)))))))

;;実行してみる前に、普通にcomplex同士のたし算ができるか確かめてみる
(put 'add '(complex complex)
     (lambda (x y)
       (make-complex-from-real-imag (+ (real-part x) (real-part y))
                                    (+ (imag-part x) (imag-part y)))))

(real-part '(rectangular 3 . 4)) ;; 3

(let* ((f (lambda (x y) (make-complex-from-real-imag x y)))
       (args (list (f 3 4) (f 5 10))))
  (apply (get 'add (map type-tag args)) (map contents args)))
;; gosh> (complex rectangular 8 . 14)

(define sn (make-scheme-number 39))
(define c (make-complex-from-real-imag 3 4))

;;型を変換できているか確認。
;;(raise-type (list sn c))
;; gosh> ((complex rectangular 39 . 0) (complex rectangular 3 . 4))


;;できた。
(apply-generic 'add sn c)
;; gosh> (complex rectangular 42 . 4)