(sicp31)m2.79~2.80

もう少し真面目にしたほうがいいかもしれない。

;;2.79
;;generic function equ? をつける。
;;面倒なので、同じ型で同じ値以外は#fを返すようにする。
(define (install-equ?)
  (define (equ? x y)
    (apply-generic 'equ x y))
  (define (same-type? x y)
    (eq? (type-tag x) (type-tag y)))
  (define (same-value? x y f)
    (= (f x) (f y)))
  (define (equ-num? x y)
    (and (same-type? x y)
         (same-value? x y (lambda (e) e))))
  
  (define (equ-comp? x y)
    (and (same-type? x y)
         (same-value? x y (lambda (e) (* (real-part e)
                                         (imag-part e))))))
  (define (equ-rat? x y)
    (and (same-type? x y)
         (same-value? x y (lambda (e) (* (numer e) (denom e))))))

  ;;本当は違うところで定義した方がいいと思う.
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  ;;=======================
  
  (put 'equ? '(scheme-number scheme-number) equ-num?)
  (put 'equ? '(scheme-number rational) equ-num?)
  (put 'equ? '(scheme-number complex) equ-num?)
  (put 'equ? '(rational scheme-number) equ-rat?)
  (put 'equ? '(rational rational) equ-rat?)
  (put 'equ? '(rational complex) equ-rat?)
  (put 'equ? '(complex scheme-number) equ-comp?)
  (put 'equ? '(complex rational) equ-comp?)
  (put 'equ? '(complex complex) equ-comp?)
  "done")

(install-equ?)
(let* ((n1 (make-scheme-number 2))
      (c1 (make-from-real-imag 2 2))
      (r1 (make-rational 2 2))
      (ch (lambda (x y) (apply-generic 'equ? x y)))
      (t (list n1 c1 r1)))
  (map (lambda (x) (map (cut ch x <>) t)) t))

;;ちょっとずるい感じだけど、これでいいや。
;;11:user> => ((#t #f #f) (#f #t #f) (#f #f #t))


;;m2.80
;; Define a generic predicate =zero?
;; ordinary numbers, rational numbers, and complex numbers.

(define (install-zero?)
  (define (=zero? e)
    (apply-generic 'zero? e))
  (define (num-zero? n) (= n 0))

  (define (rat-zero? r) (= (numer r) 0))

  ;;やっぱり、これをどこか違うところに移した方がいいはず何だけど…
  (define (numer e) (car e))

  (define (comp-zero? c)
    (and (= (imag-part c) 0)
         (= (real-part c) 0)))

  (put 'zero? 'scheme-number num-zero?)
  (put 'zero? 'rational rat-zero?)
  (put 'zero? 'complex comp-zero?)
  "done")
(install-zero?)

;;確かめ
(let ((n 0)
      (sn (make-scheme-number 0))
      (r (make-rational 0 3))
      (c (make-from-real-imag 0 0)))
  (map (cut =zero? <>) (list n sn r c)))

;;14:user> => (#t #t #t #t)