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