SICP読書女子会 2.5 (#34,#35,36,#37,#38)

2.5.1 ジェネリック算術演算

2.5.scm

整数 浮動小数の計算を定義

(define (install-scheme-number-package)
    (define (tag x) (attach-tag 'scheme-number x))
    (put 'add '(scheme-number scheme-number)
        (lambda (x y) (tag (+ x y))))
    (put 'sub '(scheme-number scheme-number)
        (lambda (x y) (tag (- x y))))
    (put 'mul '(scheme-number scheme-number)
        (lambda (x y) (tag (* x y))))
    (put 'div '(scheme-number scheme-number)
        (lambda (x y) (tag (/ x y))))

    ;;;;;;;;;;;;; Ex 2.79
    (put 'equ? '(scheme-number scheme-number) =)

    ;;;;;;;;;;;;; Ex 2.80
    (put '=zero? '(scheme-number)
        (lambda (x) (= x 0)))
    (put 'make 'scheme-number (lambda (x) (tag x)))
'done)

(define (make-scheme-number n)
    ((get 'make 'scheme-number) n))

有理数の計算の定義

(define (install-rational-package)
    ;; 内部⼿続き
    (define (numer x) (car x))
    (define (denom x) (cdr x))
    (define (make-rat n d)
        (let ((g (gcd n d)))
            (cons (/ n g) (/ d g))))
    (define (add-rat x y)
        (make-rat 
            (+ 
                (* (numer x) (denom y))
                (* (numer y) (denom x))
            )
            (* (denom x) (denom y))))
    (define (sub-rat x y)
        (make-rat 
            (- (* (numer x) (denom y))
            (* (numer y) (denom x)))
            (* (denom x) (denom y))))

    (define (mul-rat x y)
        (make-rat 
            (* (numer x) (numer y))
            (* (denom x) (denom y))))
    (define (div-rat x y)
        (make-rat 
            (* (numer x) (denom y))
            (* (denom x) (numer y))))
    ;; インタフェース
    (define (tag x) (attach-tag 'rational x))
    (put 'add '(rational rational)
        (lambda (x y) (tag (add-rat x y))))
    (put 'sub '(rational rational)
        (lambda (x y) (tag (sub-rat x y))))
    (put 'mul '(rational rational)
        (lambda (x y) (tag (mul-rat x y))))
    (put 'div '(rational rational)
        (lambda (x y) (tag (div-rat x y))))

    ;;;;;;;;;;;;; Ex 2.79 
    (put 'equ? '(rational rational) 
        (lambda (x y) 
            (= 
                (* (numer x) (denom y))
                (* (denom x) (numer y)))))
    ;;;;;;;;;;;;; Ex 2.80
    (put '=zero? '(rational)
        (lambda (x) (= (numer x) 0)))
    (put 'make 'rational
        (lambda (n d) (tag (make-rat n d))))
'done)
(define (make-rational n d)
    ((get 'make 'rational) n d))

複素数の計算の定義

;; 2.4.3より 複素数の各パッケージをinstall
(define (install-rectangular-package)
    ;; 内部手続き
    (define (real-part z) (car z))
    (define (imag-part z) (cdr z))
    (define (make-from-real-imag x y) (cons x y))
    (define (magnitude z)
        (sqrt (+ 
            (square (real-part z))
            (square (imag-part z)))))
    (define (angle z)
        (atan (imag-part z) (real-part z)))
    (define (make-from-mag-ang r a)
        (cons (* r (cos a)) (* r (sin a))))
    ;; システムのほかの部分とのインターフェイス
    (define (tag x) (attach-tag 'rectangular x))
    (put 'real-part '(rectangular) real-part)
    (put 'imag-part '(rectangular) imag-part)
    (put 'magnitude '(rectangular) magnitude)
    (put 'angle '(rectangular) angle)
    (put 'make-from-real-imag 'rectangular
    (lambda (x y) (tag (make-from-real-imag x y))))
    (put 'make-from-mag-ang 'rectangular
    (lambda (r a) (tag (make-from-mag-ang r a))))
'done)

(define (install-polar-package)
;; 内部手続き
    (define (magnitude z) (car z))
    (define (angle z) (cdr z))
    (define (make-from-mag-ang r a) (cons r a))
    (define (real-part z) (* (magnitude z) (cos (angle z))))
    (define (imag-part z) (* (magnitude z) (sin (angle z))))
    (define (make-from-real-imag x y)
        (cons 
            (sqrt (+ (square x) (square y)))
            (atan y x)))

    ;; システムのほかの部分とのインターフェイス
    (define (tag x) (attach-tag 'polar x))
    (put 'real-part '(polar) real-part)
    (put 'imag-part '(polar) imag-part)
    (put 'magnitude '(polar) magnitude)
    (put 'angle '(polar) angle)
    (put 'make-from-real-imag 'polar
    (lambda (x y) (tag (make-from-real-imag x y))))
    (put 'make-from-mag-ang 'polar
    (lambda (r a) (tag (make-from-mag-ang r a))))
'done)


;; 複素数パッケージ
(define (install-complex-package)
    ;; 直交形式パッケージと極形式パッケージからインポートした⼿続き
    (define (make-from-real-imag x y)
        ((get 'make-from-real-imag 'rectangular) x y))
    (define (make-from-mag-ang r a)
        ((get 'make-from-mag-ang 'polar) r a))

    ;; 内部⼿続き
    (define (add-complex z1 z2)
        (make-from-real-imag 
            (+ (real-part z1) (real-part z2))
            (+ (imag-part z1) (imag-part z2))))
    (define (sub-complex z1 z2)
        (make-from-real-imag 
            (- (real-part z1) (real-part z2))
            (- (imag-part z1) (imag-part z2))))
    (define (mul-complex z1 z2)
        (make-from-mag-ang 
            (* (magnitude z1) (magnitude z2))
            (+ (angle z1) (angle z2))))
    (define (div-complex z1 z2)
        (make-from-mag-ang 
            (/ (magnitude z1) (magnitude z2))
            (- (angle z1) (angle z2))))
    ;; システムのほかの部分とのインターフェイス
    (define (tag z) (attach-tag 'complex z))
    (put 'add '(complex complex)
        (lambda (z1 z2) (tag (add-complex z1 z2))))
    (put 'sub '(complex complex)
        (lambda (z1 z2) (tag (sub-complex z1 z2))))
    (put 'mul '(complex complex)
        (lambda (z1 z2) (tag (mul-complex z1 z2))))
    (put 'div '(complex complex)
        (lambda (z1 z2) (tag (div-complex z1 z2))))

    ;;;;;;;;;;;;; Ex 2.77
    ; polar , rectanglarをマップしてcomplexという型にしている
    ; そのため型に対するwrapperを準備してあげる必要がある
    (put 'real-part '(complex) real-part)
    (put 'imag-part '(complex) imag-part)
    (put 'magnitude '(complex) magnitude)
    (put 'angle '(complex) angle)

    ;;;;;;;;;;;;; Ex 2.79
    (put 'equ? '(complex complex) 
        (lambda (z1 z2) 
            (and 
                (= (real-part z1) (real-part z2))
                (= (imag-part z1) (imag-part z2))
        )))

    ;;;;;;;;;;;;; Ex 2.80
    (put '=zero? '(complex)
        (lambda (x) 
            (and 
                (= (real-part x) 0) 
                (= (imag-part x) 0)) ))
    ;; こっちでもいい
    ;(put '=zero? '(complex)
    ;(lambda (x) 
    ;    (= (magnitude x) 0)


    (put 'make-from-real-imag 'complex
        (lambda (x y) (tag (make-from-real-imag x y))))
    (put 'make-from-mag-ang 'complex
        (lambda (r a) (tag (make-from-mag-ang r a))))
'done)

(define (make-complex-from-real-imag x y)
    ((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
    ((get 'make-from-mag-ang 'complex) r a))

まとめてインストール

(install-scheme-number-package)
(install-rational-package)
(install-polar-package)
(install-rectangular-package)
(install-complex-package)

Ex 2.77

polar , rectanglarをラップしてcomplexという型にしている
そのため新しいcomplex型に対するwrapperも準備してあげる必要がある

Ex 2.78

(print "===Ex.2.78===")


(define (attach-tag type-tag contents)
    (if 
        (eq? type-tag 'scheme-number)
        contents
        (cons type-tag contents)))

(define (type-tag datum)
    (cond 
        ((number? datum) 'scheme-number)
        ((pair? datum) (car datum))
    (else 
        (error "Bad tagged datum: TYPE-TAG" datum))))

(define (contents datum)
    (cond 
        ((number? datum) datum)
        ((pair? datum) (cdr datum))
    (else
        (error "Bad tagged datum: CONTENTS" datum))))

Ex 2.79

↑に実装済み

(print "===Ex.2.79===")
(define (equ? x y) (apply-generic 'equ? x y))

(print "--number equ?")
(define num (make-scheme-number 5))
(define num2 (make-scheme-number 5))
(print (equ? num num2))

(print "--rational equ?")
(define rat (make-rational 1 2))
(define rat2 (make-rational 1 2))
(define rat3 (make-rational 2 4))
(print (equ? rat rat2))
(print (equ? rat rat3))

(print "--complex equ?")
(define com (make-complex-from-mag-ang 3 4))
(define com2 (make-complex-from-mag-ang 3 4))
(print (equ? com com2))
;できれば直行形式でも検証

; どちらでも整数値になるような組み合わせがほしい・・・　TODO
(define (real-part com) (apply-generic 'real-part com))
(define (imag-part com) (apply-generic 'imag-part com))
(print (real-part com) (imag-part com))

rectangular と polarについてもeq?を定義すべきだろうか・・・。
complexをただのwrapperとして使うのか、rect/polarをただのinitializerとして使って、内部としては同様に持ちたいのかで違いそう。

Ex 2.80

(print "===Ex.2.80===")
(define (=zero? x) (apply-generic '=zero? x))
(define num0 (make-scheme-number 0))
(define rat0 (make-rational 0 5))
(define com0 (make-complex-from-mag-ang 0 60))

(print "zero")
(print (=zero? num0))
(print (=zero? rat0))
(print (=zero? com0))

(print "not zero")
(print (=zero? num))
(print (=zero? rat))
(print (=zero? com))

5.2.2

Ex2.81

まず今までのget-putの実装じゃダメそうだったので、一部を変更

; put/get の実装 by hioさん
(define registory '())

(define (put op type item)
    (let ((key (cons op type)))
        (let ((pair (cons key item)))
            (set! registory (cons pair registory)))))

(define (get op type)
    (define (iter key rest)
        (cond
            ((null? rest) #f)
            ((equal? key (car (car rest)))
                (cdr (car rest)))
            (else
                (iter key (cdr rest)))))
    (iter (cons op type) registory))

;Louis Reasoner は、引数の型がすでに同じであっても、
;apply-generic は引数をお互いの型に強制型変換しようとしてもいいのではないかと気がついた。
;そのため、それぞれの型の引数をそれ⾃⾝の型に強制型変換 (coerce) する⼿続きを強制型変換テーブルに⼊れる必要があると彼は考えた。
;例えば、上に⽰した scheme-number->complex という強制型変換に加え、彼は次のことを⾏う。

(define (scheme-number->scheme-number n) n)
(define (complex->complex z) z)
(put-coercion 
    'scheme-number
    'scheme-number
    scheme-number->scheme-number)
(put-coercion 'complex 'complex complex->complex)


(define (exp x y) (apply-generic 'exp x y))

a

実装は下の方にある

テスト

(print "---a")
(define s1 (make-scheme-number 5))
(define s2 (make-scheme-number 2))
(print (exp s1 s2)) ;25


(define c1 (make-complex-from-real-imag 5 1))
(define c2 (make-complex-from-real-imag 2 1))
;(print (exp c1 c2)) 
;(complex complex)に揃ったあと無限ループ。

b

そのまま動く気がする

(print "---b")
(define r1 (make-rational 2 3))
(print (add s1 c1)) ;○ できる
(print (add c1 c2)) ;○ できる

問題文の意味がよくわからないのでパス

c

(print "---c")
(define (apply-generic op . args)
    (define (all el l)
        (cond
            ((null? l) #t)
            ((not (pair? l)) #f)
            ((eq? el (car l)) (all el (cdr l)))
        (else #f)))

    (let ((type-tags (map type-tag args)))
        (let ((proc (get op type-tags)))
            (print "type: " type-tags (all (car type-tags) type-tags))
            (cond 
                (proc
                    (apply proc (map contents args)))
                ((all (car type-tags) type-tags)
                    (error "No method for these types" (list op type-tags)))
                (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 ))))
                        )))
                (else
                    (error "No method for these types"
                                (list op type-tags ))))
        )))


(define c1 (make-complex-from-real-imag 5 1))
(define c2 (make-complex-from-real-imag 2 1))
;(print (exp c1 c2)) 
;*** ERROR: No method for these types (exp (complex complex))

Ex.2.82

これのD,Fみたいなクラスだったら、たどり着けない。。

ばぐってるー＞＜

(print "===Ex2.82===")
(define (raise x) (apply-generic 'raise x))

(define (apply-generic op . args)
    (define (all el l)
        (cond
            ((null? l) #t)
            ((not (pair? l)) #f)
            ((eq? el (car l)) (all el (cdr l)))
        (else #f)))

    (define (any el l)
        (cond 
            ((null? l) #f)
            ((eq? el (car l)) #t)
        (else
            (any el (cdr l)))
        ))

    (define (_raise target)
        (lambda (x) 
            (if 
                (= (type-tag x) target)
                (target)
                (parent (raise target))
           )
        )
    )


    (define (apply-all list)
        (let
            ((f (_raise (car list))))
            (let 
                ((next (map f list)))
                    (print "next:" next)
                    (if
                        next
                        next
                        (apply-all (cdr list))
                    )
            )))

    (let ((type-tags (map type-tag args)))
        (let ((proc (get op type-tags)))
            ;(print "type: " type-tags)
            (cond 
                (proc
                    (apply proc (map contents args)))
                ((all (car type-tags) type-tags) #f)
                ((any #f type-tags) #f)
                (else 
                    (apply-generic op (apply-all args))
                )


        )))
)

Ex.2.83

各型の実装
disit-packages.scm

;; はじめに整数・浮動小数の計算を定義
(define (install-scheme-number-package)
    (define (tag x) (attach-tag 'scheme-number x))
    (put 'add '(scheme-number scheme-number)
        (lambda (x y) (tag (+ x y))))
    (put 'sub '(scheme-number scheme-number)
        (lambda (x y) (tag (- x y))))
    (put 'mul '(scheme-number scheme-number)
        (lambda (x y) (tag (* x y))))
    (put 'div '(scheme-number scheme-number)
        (lambda (x y) (tag (/ x y))))

    ;;;;;;;;;;;;; Ex 2.79
    (put 'equ? '(scheme-number scheme-number) =)

    ;;;;;;;;;;;;; Ex 2.80
    (put '=zero? '(scheme-number)
        (lambda (x) (= x 0)))

    ;;;;;;;;;;;;; Ex 2.81
    (put 'exp '(scheme-number scheme-number)
        (lambda (x y) (tag (expt x y)))) 

    ;;;;;;;;;;;;; Ex 2.83
    (put 'raise '(scheme-number)
        (lambda (x) (make-rational x 1))
    )


    (put 'make 'scheme-number (lambda (x) (tag x)))
'done)

(define (make-scheme-number n)
    ((get 'make 'scheme-number) n))


(define (install-rational-package)
    ;; 内部⼿続き
    (define (numer x) (car x))
    (define (denom x) (cdr x))
    (define (make-rat n d)
        (let ((g (gcd n d)))
            (cons (/ n g) (/ d g))))
    (define (add-rat x y)
        (make-rat 
            (+ 
                (* (numer x) (denom y))
                (* (numer y) (denom x))
            )
            (* (denom x) (denom y))))
    (define (sub-rat x y)
        (make-rat 
            (- (* (numer x) (denom y))
            (* (numer y) (denom x)))
            (* (denom x) (denom y))))

    (define (mul-rat x y)
        (make-rat 
            (* (numer x) (numer y))
            (* (denom x) (denom y))))
    (define (div-rat x y)
        (make-rat 
            (* (numer x) (denom y))
            (* (denom x) (numer y))))
    ;; インタフェース
    (define (tag x) (attach-tag 'rational x))
    (put 'add '(rational rational)
        (lambda (x y) (tag (add-rat x y))))
    (put 'sub '(rational rational)
        (lambda (x y) (tag (sub-rat x y))))
    (put 'mul '(rational rational)
        (lambda (x y) (tag (mul-rat x y))))
    (put 'div '(rational rational)
        (lambda (x y) (tag (div-rat x y))))

    ;;;;;;;;;;;;; Ex 2.79 
    (put 'equ? '(rational rational) 
        (lambda (x y) 
            (= 
                (* (numer x) (denom y))
                (* (denom x) (numer y)))))
    ;;;;;;;;;;;;; Ex 2.80
    (put '=zero? '(rational)
        (lambda (x) (= (numer x) 0)))

    ;;;;;;;;;;;;; Ex 2.83
    (put 'raise '(rational)
        (lambda (x) (make-real-number (/ (numer x) (denom x))))
    )

    (put 'make 'rational
        (lambda (n d) (tag (make-rat n d))))
'done)
(define (make-rational n d)
    ((get 'make 'rational) n d))


;; 実数 2.83
(define (install-real-number-package)
    (define (tag x) (attach-tag 'real-number x))
    (put 'add '(real-number real-number)
        (lambda (x y) (tag (+ x y))))
    (put 'sub '(real-number real-number)
        (lambda (x y) (tag (- x y))))
    (put 'mul '(real-number real-number)
        (lambda (x y) (tag (* x y))))
    (put 'div '(real-number real-number)
        (lambda (x y) (tag (/ x y))))

    ;;;;;;;;;;;;; Ex 2.79
    (put 'equ? '(real-number real-number) =)

    ;;;;;;;;;;;;; Ex 2.80
    (put '=zero? '(real-number)
        (lambda (x) (= x 0)))

    ;;;;;;;;;;;;; Ex 2.81
    (put 'exp '(real-number real-number)
        (lambda (x y) (tag (expt x y)))) 

    ;;;;;;;;;;;;; Ex 2.83
    (put 'raise '(real-number)
        (lambda (x) (make-complex-from-real-imag x 0))
    )

    (put 'make 'real-number (lambda (x) (tag x)))

'done)

(define (make-real-number n)
    ((get 'make 'real-number) n))


;; 2.4.3より 複素数の各パッケージをinstall
(define (install-rectangular-package)
    ;; 内部手続き
    (define (real-part z) (car z))
    (define (imag-part z) (cdr z))
    (define (make-from-real-imag x y) (cons x y))
    (define (magnitude z)
        (sqrt (+ 
            (square (real-part z))
            (square (imag-part z)))))
    (define (angle z)
        (atan (imag-part z) (real-part z)))
    (define (make-from-mag-ang r a)
        (cons (* r (cos a)) (* r (sin a))))
    ;; システムのほかの部分とのインターフェイス
    (define (tag x) (attach-tag 'rectangular x))
    (put 'real-part '(rectangular) real-part)
    (put 'imag-part '(rectangular) imag-part)
    (put 'magnitude '(rectangular) magnitude)
    (put 'angle '(rectangular) angle)
    (put 'make-from-real-imag 'rectangular
    (lambda (x y) (tag (make-from-real-imag x y))))
    (put 'make-from-mag-ang 'rectangular
    (lambda (r a) (tag (make-from-mag-ang r a))))
'done)

(define (install-polar-package)
;; 内部手続き
    (define (magnitude z) (car z))
    (define (angle z) (cdr z))
    (define (make-from-mag-ang r a) (cons r a))
    (define (real-part z) (* (magnitude z) (cos (angle z))))
    (define (imag-part z) (* (magnitude z) (sin (angle z))))
    (define (make-from-real-imag x y)
        (cons 
            (sqrt (+ (square x) (square y)))
            (atan y x)))

    ;; システムのほかの部分とのインターフェイス
    (define (tag x) (attach-tag 'polar x))
    (put 'real-part '(polar) real-part)
    (put 'imag-part '(polar) imag-part)
    (put 'magnitude '(polar) magnitude)
    (put 'angle '(polar) angle)
    (put 'make-from-real-imag 'polar
    (lambda (x y) (tag (make-from-real-imag x y))))
    (put 'make-from-mag-ang 'polar
    (lambda (r a) (tag (make-from-mag-ang r a))))
'done)




;; 複素数パッケージ
(define (install-complex-package)
    ;; 直交形式パッケージと極形式パッケージからインポートした⼿続き
    (define (make-from-real-imag x y)
        ((get 'make-from-real-imag 'rectangular) x y))
    (define (make-from-mag-ang r a)
        ((get 'make-from-mag-ang 'polar) r a))

    ;; 内部⼿続き
    (define (add-complex z1 z2)
        (make-from-real-imag 
            (+ (real-part z1) (real-part z2))
            (+ (imag-part z1) (imag-part z2))))
    (define (sub-complex z1 z2)
        (make-from-real-imag 
            (- (real-part z1) (real-part z2))
            (- (imag-part z1) (imag-part z2))))
    (define (mul-complex z1 z2)
        (make-from-mag-ang 
            (* (magnitude z1) (magnitude z2))
            (+ (angle z1) (angle z2))))
    (define (div-complex z1 z2)
        (make-from-mag-ang 
            (/ (magnitude z1) (magnitude z2))
            (- (angle z1) (angle z2))))
    ;; システムのほかの部分とのインターフェイス
    (define (tag z) (attach-tag 'complex z))
    (put 'add '(complex complex)
        (lambda (z1 z2) (tag (add-complex z1 z2))))
    (put 'sub '(complex complex)
        (lambda (z1 z2) (tag (sub-complex z1 z2))))
    (put 'mul '(complex complex)
        (lambda (z1 z2) (tag (mul-complex z1 z2))))
    (put 'div '(complex complex)
        (lambda (z1 z2) (tag (div-complex z1 z2))))

    ;;;;;;;;;;;;; Ex 2.77
    ; polar , rectanglarをマップしてcomplexという型にしている
    ; そのため型に対するwrapperを準備してあげる必要がある
    (put 'real-part '(complex) real-part)
    (put 'imag-part '(complex) imag-part)
    (put 'magnitude '(complex) magnitude)
    (put 'angle '(complex) angle)

    ;;;;;;;;;;;;; Ex 2.79
    (put 'equ? '(complex complex) 
        (lambda (z1 z2) 
            (and 
                (= (real-part z1) (real-part z2))
                (= (imag-part z1) (imag-part z2))
        )))

    ;;;;;;;;;;;;; Ex 2.80
    (put '=zero? '(complex)
        (lambda (x) 
            (and 
                (= (real-part x) 0) 
                (= (imag-part x) 0)) ))

    ;; こっちでもいい
    ;(put '=zero? '(complex)
    ;(lambda (x) 
    ;    (= (magnitude x) 0)

    ;;;;;;;;;;;;; Ex 2.83
    (put 'raise '(complex) #f)

    (put 'make-from-real-imag 'complex
        (lambda (x y) (tag (make-from-real-imag x y))))
    (put 'make-from-mag-ang 'complex
        (lambda (r a) (tag (make-from-mag-ang r a))))
'done)

(define (make-complex-from-real-imag x y)
    ((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
    ((get 'make-from-mag-ang 'complex) r a))

テスト

(print "===Ex2.83===")   
(install-real-number-package)
(define rr1 (make-real-number 1))
(print "real-number" rr1)

(print "scheme-raise:" (raise s1))
(print "rational-raise:" (raise r1))
(print "real-raise:" (raise rr1))
(print "complex-raise:" (raise c1))

;real-number(real-number . 1)
;scheme-raise:(rational 5 . 1)
;rational-raise:(real-number . 2/3)
;real-raise:(complex rectangular 1 . 0)
;complex-raise:#f

実装してみたが、パッケージに依存関係が生まれてしまった。
このパッケージを入れるときはraiseする親パッケージも一緒にインストールする、という実装が必要かなと思った。

Ex 2.84

(print "===Ex2.84===")   
;練習問題 2.83の raise 演算を使って apply-generic⼿続きを修正して、
;この節で検討した通り、連続して “上げる” という⽅法によって
;引数が同じ型を持つよう強制型変換を⾏うようにせよ。
;⼆つの型のどちらがタワーの中で⾼い位置にあるかをテストする⽅法を考える必要がある。
;システムのほかの部分と “互換性がある” ようなやり⽅でこれを⾏い、
;タワーに新しい階を追加する際に問題を引き起こさないようにせよ。

(define (install-tree-depth-package)
    (put 'tree-depth '(scheme-number)
        (lambda (x) (+ 1 (tree-depth (raise x)))))

    (put 'tree-depth '(rational)
        (lambda (x) (+ 1 (tree-depth (raise x)))))

    (put 'tree-depth '(real-number)
        (lambda (x) (+ 1 (tree-depth (raise x)))))

    (put 'tree-depth '(complex)
        (lambda (x) 1))
'done)

; * apply-generic使うと、内部で再帰してしまう、、
(define (tree-depth x)
    ((get 'tree-depth (list (type-tag x))) x))

(install-tree-depth-package)
(print "complex tree-depth:" (tree-depth c1))
(print "real    tree-depth:" (tree-depth rr1))
(print "rational tree-depth:" (tree-depth r1))
(print "scheme  tree-depth:" (tree-depth s1))


(define (debug-raise . args)
    ;　全部リスト内がおんなじエレメント
    (define (all el l)
        (cond
            ((null? l) #t)
            ((not (pair? l)) #f)
            ((eq? el (car l)) (all el (cdr l)))
        (else #f)))

    ; リスト内でdepthの浅いtype
    (define (min-type args)
        (define (itr min-element lst)
            (if (null? lst)
                min-element
                (let 
                    (
                        (head (car lst))
                    )
                    (if (< (tree-depth head) (tree-depth min-element))
                        (itr (type-tag head) (cdr lst))
                        (itr min-element (cdr lst)))
                )))
        (itr (car args) (cdr args)))

    ; depthを1段階引き上げる
    (define (apply-raise list)
        (define (raise-to min-depth)
            (lambda (x)
                (if (= min-depth (tree-depth x))
                    x
                    (raise x)
                )))
        (let
            ((min-depth (tree-depth (car list))) )
            (map (raise-to min-depth) list)))

    (define (apply-raise-to-min args)
        (define (itr l)
            (if 
                (all (tree-depth (car l)) (map tree-depth l))
                l
                (itr (apply-raise l)))
            )
        (itr args)
    )

    (print "@depth-map: " (map tree-depth args))
    (print "@depth-disit-zip: " (map cons (map tree-depth args) args))
    (print "@min-type: "(min-type args))
    (print "@apply-raise: " (apply-raise args))
    (print "@apply-raise-to-min: " (apply-raise-to-min args))
    (print "@raise args: " (map raise args))
    (print "@any:" (any (lambda (x) (not x)) (map raise args)))
)

(debug-raise c1 rr1 r1 s1)
;depth-map: (1 2 3 4)
;depth-disit-zip: ((1 complex rectangular 5 . 1) (2 real-number . 1) (3 rational 2 . 3) (4 . 5))
;min-type: (complex rectangular 5 . 1)
;apply-raise: ((complex rectangular 5 . 1) (complex rectangular 1 . 0) (real-number . 2/3) (rational 5 . 1))
;apply-raise-to-min: ((complex rectangular 5 . 1) (complex rectangular 1 . 0) (complex rectangular 2/3 . 0) (complex rectangular 5 . 0))


(define (apply-generic op . args)
    ;　全部リスト内がおんなじエレメント
    (define (all el l)
        (cond
            ((null? l) #t)
            ((not (pair? l)) #f)
            ((eq? el (car l)) (all el (cdr l)))
        (else #f)))

    ; リスト内でdepthの浅いtype
    (define (min-type args)
        (define (itr min-element lst)
            (if (null? lst)
                min-element
                (let 
                    (
                        (head (car lst))
                    )
                    (if (< (tree-depth head) (tree-depth min-element))
                        (itr (type-tag head) (cdr lst))
                        (itr min-element (cdr lst)))
                )))
        (itr (car args) (cdr args)))

    ; depthを1段階引き上げる
    (define (apply-raise list)
        (define (raise-to min-depth)
            (lambda (x)
                (if (= min-depth (tree-depth x))
                    x
                    (raise x)
                )))
        (let
            ((min-depth (tree-depth (car list))) )
            (map (raise-to min-depth) list)))

    (define (apply-raise-to-min args)
        (define (itr l)
            (if 
                (all (tree-depth (car l)) (map tree-depth l))
                l
                (itr (apply-raise l)))
            )
        (itr args)
    )
    ;(print "---------------------------")
    ;(print "op: " op " args:" args)

    (let 
        (
            (type-tags (map type-tag args))
        )
        (let 
            (
                (proc (get op type-tags))
            )
            ;(print "type: " type-tags)
            ;(print "same?: " (all (car type-tags) type-tags))
            ;(print "proc:  " proc)
            (cond 
                ; procがある状態
                (proc
                    (apply proc (map contents args)))

                ; procが無いが、全ての型が揃っている
                ((all (car type-tags) type-tags) #f)
                    ;(error "No method for these types" (list op type-tags)))

                (else
                    (let 
                        (
                            (raised (apply-raise-to-min args))
                        )
                        ;(print "raised:" raised)
                        (apply apply-generic (cons op raised))
                    )

                ))
        ))
)

(print "complex + complex = " (add c1 c1))
(print "complex + rational = " (add c1 r1))
;complex + complex = (complex rectangular 10 . 2)
;complex + rational = (complex rectangular 17/3 . 1)

凄い遠回りした感のある実装・・・！

2.5.3

※2.87,88の実装入
```lisp
(print "====================")
(print " 2.5.3")
(print "====================")

; poly: 多項式

(use srfi-1) ;filter-mapの為

(define (install-polynomial-package)
;; 内部⼿続き
;; poly の表現
(define (make-poly variable term-list) (cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))

;⟨2.3.2 節の same-variable? と variable? ⼿続き⟩
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
    (and 
        (variable? v1)
        (variable? v2)
        (eq? v1 v2)))
;; 項と項リストの表現
;⟨下記の adjoin-term . . . coeff ⼿続き
(define (adjoin-term term term-list)
    (if 
        (=zero? (coeff term))
        term-list
        (cons term term-list)))
(define (the-empty-termlist) '())
(define (first-term term-list) (car term-list))
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))

(define (add-terms L1 L2)
    (cond 
        ((empty-termlist? L1) L2)
        ((empty-termlist? L2) L1)
    (else
        (let 
            (
                (t1 (first-term L1))
                (t2 (first-term L2))
            )
            (cond 
                ((> (order t1) (order t2))
                    (adjoin-term　t1 (add-terms (rest-terms L1) L2)))
                ((< (order t1) (order t2))
                    (adjoin-term　t2 (add-terms L1 (rest-terms L2))))
            (else
                (adjoin-term　(make-term (order t1)
                (add (coeff t1) (coeff t2)))
                (add-terms (rest-terms L1)
                (rest-terms L2))))))
    )))

(define (mul-terms L1 L2)
    (if 
        (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (first-term L1) L2)
            (mul-terms (rest-terms L1) L2))))

(define (mul-term-by-all-terms t1 L)
    (if 
        (empty-termlist? L)
        (the-empty-termlist)
        (let 
            ((t2 (first-term L)))
            (adjoin-term
                (make-term (+ (order t1) (order t2))
                (mul (coeff t1) (coeff t2)))
                (mul-term-by-all-terms t1 (rest-terms L))))))


(define (add-poly p1 p2) 
    (if 
        (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
            (add-terms (term-list p1) (term-list p2)))
        (error "Polys not in same var: ADD-POLY" (list p1 p2))))

(define (mul-poly p1 p2)
    (if 
        (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
            (mul-terms (term-list p1) (term-list p2)))
        (error "Polys not in same var: MUL-POLY" (list p1 p2))))

; Ex 2.87
(define (=zero-poly? p) 
    (= 0 (fold-left + 0 (map coeff (term-list p))))
)

(define (negative p)
    (make-poly 
        (variable p) 
        (map list
            (map order (term-list p))
            (map (lambda (x) (* -1 (coeff x))) (term-list p))))
)

;; システムのほかの部分とのインターフェイス
(define (tag p) (attach-tag 'polynomial p))
(put 'add '(polynomial polynomial)
    (lambda (p1 p2) (tag (add-poly p1 p2))))

(put 'sub '(polynomial polynomial) 
    (lambda (p1 p2) (tag (add-poly p1 (negative p2)))))

;(put 'sub '(polynomial polynomial) 
;    (lambda (p1 p2) (negative p2)))

(put 'mul '(polynomial polynomial)
    (lambda (p1 p2) (tag (mul-poly p1 p2))))

(put '=zero? '(polynomial) =zero-poly?)

(put 'make 'polynomial
    (lambda (var terms) (tag (make-poly var terms)))) 

'done)
(define (make-polynomial var terms)
((get 'make 'polynomial) var terms))

(install-polynomial-package)

(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))
(error
"No method for these types: APPLY-GENERIC"
(list op type-tags ))))))

## Ex 2.87

```lisp

(print "===Ex2.87===")
;2x + 1
(define p0 (make-polynomial 'x (list (list 1 2) (list 0 1))))
;2x**2
(define p1 (make-polynomial 'x (list (list 2 2))))
; 0
(define p2 (make-polynomial 'x (list (list 0 0))))
(define p3 (make-polynomial 'x (list (list 1 0) (list 0 0))))

; Ex 2.87

; これをpolyのパッケージに追加
(define (=zero-poly? p) 
    (= 0 (fold-left + 0 (map coeff (term-list p))))
)

(define (ex-2-87)
    (print "p0: 2x + 1 = " p0)
    (print "p1: 2x ** 2 = " p1)
    (print "p2: 0 = " p2)
    (print "p3: 0x + 0 = " p3)

    (print (contents p0))
    (print (map car (cdr (contents p0))))
    (print (=zero? p0))
    (print (=zero? p1))
    (print (=zero? p2))
    (print (=zero? p3))

    ;p0: 2x + 1 = (polynomial x (1 2) (0 1))
    ;p1: 2x ** 2 = (polynomial x (2 2))
    ;p2: 0 = (polynomial x (0 0))
    ;p3: 0x + 0 = (polynomial x (1 0) (0 0))
    ;(x (1 2) (0 1))
    ;(1 0)
    ;#f
    ;#f
    ;#t
    ;#t
)
(ex-2-87)

Ex 2.88

; packageの中に以下を入れる
(define (negative p)
    (make-poly 
        (variable p) 
        (map list
            (map order (term-list p))
            (map (lambda (x) (* -1 (coeff x))) (term-list p))))
)
(put 'sub '(polynomial polynomial) 
    (lambda (p1 p2) (tag (add-poly p1 (negative p2)))))


(print "===Ex2.88===")
(define (ex-2-88)
    (print "p0: 2x + 1 = " p0)
    (print "p1: 2x ** 2 = " p1)
    (print "p2: 0 = " p2)
    (print "p3: 0x + 0 = " p3)

    (print "p0 + p1 = " (add p0 p1))
    (print "p0 - p1 = " (sub p0 p1))

    ;===Ex2.88===
    ;p0: 2x + 1 = (polynomial x (1 2) (0 1))
    ;p1: 2x ** 2 = (polynomial x (2 2))
    ;p2: 0 = (polynomial x (0 0))
    ;p3: 0x + 0 = (polynomial x (1 0) (0 0))
    ;p0 + p1 = (polynomial x (2 2) (1 2) (0 1))
    ;p0 - p1 = (polynomial x (2 -2) (1 2) (0 1))
)
(ex-2-88)

Ex 2.89

やりかけです

(print "===Ex2.89===")
(define (install-polynomial-package)
    ;; 内部⼿続き
    ;; poly の表現
    (define (make-poly variable coeff-list) (cons variable coeff-list))
    (define (variable p) (car p))
    (define (coeff-list p) (cdr p))

    ;⟨2.3.2 節の same-variable? と variable? ⼿続き⟩
    (define (variable? x) (symbol? x))
    (define (same-variable? v1 v2)
        (and 
            (variable? v1)
            (variable? v2)
            (eq? v1 v2)))
    ;; 項と項リストの表現
    ;⟨下記の adjoin-term . . . coeff ⼿続き
    (define (the-empty-termlist) '())
    (define (first-term term-list) (car term-list))
    (define (rest-terms term-list) (cdr term-list))
    (define (empty-termlist? term-list) (null? term-list))
    (define (make-term order coeff) (list order coeff))
    (define (order term) (car term))
    (define (coeff term) (cadr term))

    (define (add-terms L1 L2)
        (cond 
            ((empty-termlist? L1) L2)
            ((empty-termlist? L2) L1)
        (else
            (let 
                (
                    (t1 (first-term L1))
                    (t2 (first-term L2))
                )
                (cond 
                    ((> (order t1) (order t2))
                        (adjoin-term　t1 (add-terms (rest-terms L1) L2)))
                    ((< (order t1) (order t2))
                        (adjoin-term　t2 (add-terms L1 (rest-terms L2))))
                (else
                    (adjoin-term　(make-term (order t1)
                    (add (coeff t1) (coeff t2)))
                    (add-terms (rest-terms L1)
                    (rest-terms L2))))))
        )))

    (define (mul-terms L1 L2)
        (if 
            (empty-termlist? L1)
            (the-empty-termlist)
            (add-terms (mul-term-by-all-terms (first-term L1) L2)
                (mul-terms (rest-terms L1) L2))))

    (define (mul-term-by-all-terms t1 L)
        (if 
            (empty-termlist? L)
            (the-empty-termlist)
            (let 
                ((t2 (first-term L)))
                (adjoin-term
                    (make-term (+ (order t1) (order t2))
                    (mul (coeff t1) (coeff t2)))
                    (mul-term-by-all-terms t1 (rest-terms L))))))


    (define (add-poly p1 p2) 
        (if 
            #?=(same-variable? (variable p1) (variable p2))
            (make-poly (variable p1)
                (map + (coeff-list p1) (coeff-list p2)))) ;<== mapの長さ揃うやつさがす
            (error "Polys not in same var: ADD-POLY" (list p1 p2) (coeff-list p1) (coeff-list p2)))

    ;(define (mul-poly p1 p2)
    ;    (if 
    ;        (same-variable? (variable p1) (variable p2))
    ;        (make-poly (variable p1)
    ;            (mul-terms (term-list p1) (term-list p2)))
    ;        (error "Polys not in same var: MUL-POLY" (list p1 p2))))

    ; Ex 2.87
    (define (=zero-poly? p) 
        (= 0 (fold-left + 0 (map coeff (term-list p))))
    )

    (define (negative p)
        (make-poly 
            (variable p) 
            (map (lambda (x) (* -1 x)) (coeff-list p)))
    )

    ;; システムのほかの部分とのインターフェイス
    (define (tag p) (attach-tag 'polynomial p))

    (put 'add '(polynomial polynomial)
        (lambda (p1 p2) (tag (add-poly p1 p2))))

    (put 'sub '(polynomial polynomial) 
        (lambda (p1 p2) (tag (add-poly p1 (negative p2)))))


    (put 'mul '(polynomial polynomial)
        (lambda (p1 p2) (tag (mul-poly p1 p2))))

    (put '=zero? '(polynomial) =zero-poly?)

    (put 'make 'polynomial
        (lambda (var terms) (tag (make-poly var terms))))
'done)

(define (make-polynomial var terms)
    ((get 'make 'polynomial) var terms))


(install-polynomial-package)

(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))
                (error
                    "No method for these types: APPLY-GENERIC"
                    (list op type-tags ))))))



(install-polynomial-package)
;2x + 1
(define p0 (make-polynomial 'x (list 1 2)))
;2x**2
(define p1 (make-polynomial 'x (list 0 0 2)))
; 0
(define p2 (make-polynomial 'x (list 0)))
(define p3 (make-polynomial 'x (list 0 0)))

(define (ex-2-89)
    (print "p0: 2x + 1 = " p0)
    (print "p1: 2x ** 2 = " p1)
    (print "p2: 0 = " p2)
    (print "p3: 0x + 0 = " p3)

    (print "p0 + p1 = " (add p0 p1))
    (print "p0 - p1 = " (sub p0 p1))

    ;p0: 2x + 1 = (polynomial x (1 2) (0 1))
    ;p1: 2x ** 2 = (polynomial x (2 2))
    ;p2: 0 = (polynomial x (0 0))
    ;p2: 0x + 0 = (polynomial x (1 0) (0 0))
    ;p0 + p1 = (polynomial x (2 2) (1 2) (0 1))
    ;p0 - p1 = (polynomial x (2 -2) (1 2) (0 1))
)
(ex-2-89)

2.90

5時間粘ったけど何がなんだかわからなくなってきた
SICP/poly2.scm at master · cocodrips/SICP

(print "===Ex 2.90===")

(load "./poly2.scm")

(install-sparse-polynomial-package)
(install-dense-polynomial-package)
(install-polynomial-package)
 挫折。。
(define (ex-2-90)
    ;(x**2) + 2x + 1
    (define dense-p (make-dense-poly 'x (list 1 2 1)))
    (define sparse-p 
        (make-sparse-poly 'x (list (list 2 1) (list 1 2) (list 0 1))))

    ;; make
    (print "dense x^2 + 2x + 1 = \t" dense-p)
    (print "sparse x^2 + 2x + 1 = \t" sparse-p)

    ; type
    (print "type(dense): \t" (type-tag dense-p))
    (print "type(sparse): \t" (type-tag sparse-p))

    (print "term-list(dense): " (term-list dense-p))
    (print "term-list(sparse): " (term-list sparse-p))

    ; Add
    ;(print "add sparse + sparse = " (add sparse-p sparse-p))
)
(ex-2-90)

ドンドン外にだす必要のあるものがでてくる。


諦めて写経

問題2.90 – SICP（計算機プログラムの構造と解釈）その100 : Serendip - Webデザイン・プログラミング

SICP/poly3.scm at master · cocodrips/SICP

(print "===2.90 写経===")
(load "./poly3.scm")
(define (ex-2-90)
    ;(x**2) + 2x + 1

    (define sparse-p 
        (make-polynomial 'x (make-dense-term '(1 -1)) ))
    (define dense-p (make-polynomial 'x (make-sparse-term '((1 2) (0 1)))))
    (print "sparse x - 1: " sparse-p)
    (print "dense 2x + 1: " dense-p)
    (print "Add dense + dense = 4x + 2: " (add dense-p dense-p))
    (print "Add sparse + sparse = 2x - 2: " (add sparse-p sparse-p))
    (print "Add sparse + dense = 3x: " (add sparse-p dense-p))

    (print "Mul dense * dense = 4x^2 + 4x + 1: " (mul dense-p dense-p))
    (print "Mul sparse * sparse = x^2 -2x + 1: " (mul sparse-p sparse-p))
    (print "Mul sparse * dense = 2x^2 - x - 1: " (mul sparse-p dense-p))
    ;(print "Negete" (sub sparse-p sparse-p))
    ;(print "Sub sparse - sparse = x^2 -2x + 1: " (sub sparse-p sparse-p))
)

内部実装は中にもちつつ、termの部分だけ別で実装するのか・・・。

add, mulは動くが、subを動かすことができない。
negateの挙動が定義されていない。

Ex 2.91

sub が動かせず。
無限に時間ばかりかかって溶けないので諦めました(つд⊂)ｴｰﾝ