SICP 読み (66) 2.5.2 異る型のデータの統合

scheme SICP

問題 2.83 は p.115 にある raise の実装。手続きを検討する前に実数をどう表現すれば良いのでしょうか。困ったなぁ。小数点の上下って微妙スギです。
がしかし、raise が有理数を実数に変換できなければならない、というのが一つのヒントになるのか。有理数を実数に、な変換ってどうすりゃ良いのだろう。

って、別にそこまでの考慮は不要なのかなぁ。scheme-number って実数も整数も表現可能だし。これを分割した概念を実装するとしても演算はそのままで良いだろうし、異なるのは raise だけな気がするけどこれは検証が必要かも。


とりあえず、2.5.2 節のサンプルを元に integer と real なパケジを盛り込んでおく。と、その前に試験を書いておいた方が良いか。

 ("integer test"
  (setup (lambda () (install-integer-package)))

  ("make-integer test (tag is _integer_)"
   (assert-equal 'integer (type-tag (make-integer 5)))
   )

  ("make-integer test (contents is 5)"
   (assert-equal '5 (contents (make-integer 5)))
   )

  ("add test (tag is _integer_)"
   (assert-equal 'integer (type-tag (add (make-integer 1)
					 (make-integer 2))))
   )

  ("add test (1 + 2 => 3)"
   (assert-equal 3 (contents (add (make-integer 1)
				  (make-integer 2))))
   )

  ("sub test (tag is _integer_)"
   (assert-equal 'integer (type-tag (sub (make-integer 5)
					 (make-integer 2))))
   )

  ("sub test (5 - 2 => 3)"
   (assert-equal 3 (contents (sub (make-integer 5)
				  (make-integer 2))))
   )

  ("mul test (tag is _integer_)"
   (assert-equal 'integer (type-tag (mul (make-integer 3)
					 (make-integer 2))))
   )

  ("mul test (3 * 2 => 6)"
   (assert-equal 6 (contents (mul (make-integer 3)
				  (make-integer 2))))
   )

  ("div test (tag is _integer_)"
   (assert-equal 'integer (type-tag (div (make-integer 6)
					 (make-integer 2))))
   )

  ("div test (6 / 2 => 3)"
   (assert-equal 3 (contents (div (make-integer 6)
				  (make-integer 2))))
   )

  ("equ? test"
   (let ((t1 (make-integer 6))
	 (t2 (make-integer 6))
	 (t3 (make-integer 7)))
     (assert-true (equ? t1 t2))
     (assert-false (equ? t1 t3))
     )
   )

  ("=zero? test"
   (let ((t1 (make-integer 0))
	 (t2 (make-integer 1)))
     (assert-true (=zero? t1))
     (assert-false (=zero? t2)))
   )
  )

 ("real test"
  (setup (lambda () (install-real-package)))

  ("make-real test (tag is _real_)"
   (assert-equal 'real (type-tag (make-real 5)))
   )

  ("make-real test (contents is 5)"
   (assert-equal '5 (contents (make-real 5)))
   )

  ("add test (tag is _real_)"
   (assert-equal 'real (type-tag (add (make-real 1)
				      (make-real 2))))
   )

  ("add test (1.5 + 2.5 => 4.0)"
   (assert-equal 4.0 (contents (add (make-real 1.5)
				    (make-real 2.5))))
   )

  ("sub test (tag is _real_)"
   (assert-equal 'real (type-tag (sub (make-real 5)
				      (make-real 2))))
   )

  ("sub test (5.5 - 2.5 => 3.0)"
   (assert-equal 3.0 (contents (sub (make-real 5.5)
				    (make-real 2.5))))
   )

  ("mul test (tag is _real_)"
   (assert-equal 'real (type-tag (mul (make-real 3)
				      (make-real 2))))
   )

  ("mul test (3.5 * 2.0 => 7.0)"
   (assert-equal 7.0 (contents (mul (make-real 3.5)
				    (make-real 2.0))))
   )

  ("div test (tag is _real_)"
   (assert-equal 'real (type-tag (div (make-real 6)
				      (make-real 2))))
   )

  ("div test (6.0 / 2.0 => 3.0)"
   (assert-equal 3.0 (contents (div (make-real 6.0)
				    (make-real 2.0))))
   )

  ("equ? test"
   (let ((t1 (make-real 6.0))
	 (t2 (make-real 6.0))
	 (t3 (make-real 7.0)))
     (assert-true (equ? t1 t2))
     (assert-false (equ? t1 t3))
     )
   )

  ("=zero? test"
   (let ((t1 (make-real 0.0))
	 (t2 (make-real 1.0)))
     (assert-true (=zero? t1))
     (assert-false (=zero? t2)))
   )
  )

で、実装を。

(define (install-integer-package)
  (define (tag x)
    (attach-tag 'integer x))
  (put 'add '(integer integer)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(integer integer)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(integer integer)
       (lambda (x y) (tag (* x y))))
  (put 'div '(integer integer)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'integer
       (lambda (x) (tag x)))
  (put 'equ? '(integer integer) =)
  (put '=zero? '(integer) zero?)
  'done)

(define (make-integer n)
  ((get 'make 'integer) n))

(define (install-real-package)
  (define (tag x)
    (attach-tag 'real x))
  (put 'add '(real real)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(real real)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(real real)
       (lambda (x y) (tag (* x y))))
  (put 'div '(real real)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'real
       (lambda (x) (tag x)))
  (put 'equ? '(real real) =)
  (put '=zero? '(real) zero?)
  'done)

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

上記の実装で演算な試験はパス。


で、ようやく raise の検討ですが基本的には

  • integer から rational への raise は分子を 1 にして make すれば良い
  • rational から real への raise は (/ 分子 分母) の演算結果で make すれば良い
  • real から complex への raise は虚数部に 0 をセットして make すれば良い

試験を書いてみた。以下。
まず、integer な raise

  ("raise test (tag is _rational_)"
   (assert-equal 'rational (car (raise (make-integer 5))))
   )

  ("raise test (number is 5)"
   (assert-equal '5 (cadr (raise (make-integer 5))))
   )

  ("raise test (denom is 1)"
   (assert-equal '1 (cddr (raise (make-integer 5))))
   )

次に rational な raise

  ("raise test (tag is _real_)"
   (assert-equal 'real (car (raise (make-rational 2 5))))
   )

  ("raise test (contents is 0.4)"
   (assert-equal '0.4 (cdr (raise (make-rational 2 5))))
   )

最後に real な raise

  ("raise test (tag is _complex_)"
   (assert-equal 'complex (car (raise (make-real 5.0))))
   )

  ("raise test (tag is _rectangular_)"
   (assert-equal 'rectangular (cadr (raise (make-real 5.0))))
   )

  ("raise test (real is 5.0)"
   (assert-equal '5.0 (caddr (raise (make-real 5.0))))
   )

  ("raise test (imag is 0)"
   (assert-equal '0 (cdddr (raise (make-real 5.0))))
   )

実装については最後に纏めてコードをサラした方が良さげ。


で、実装盛り込んで試験してみたのですが、error に。gosh で確認してみると、

  • integer の raise にあたって (install-rational-package) が必要
  • rational の raise にあたって (install-real-package) が必要
  • real の raise にあたって (install-complex-package) と (install-rectangular-package) が必要

という事に気づく。(遅

試験を一応パスした実装を以下に。(長いです

(define (assoc key records)
 (cond ((null? records) #f)
  ((equal? key (caar records)) (car records))
  (else (assoc key (cdr records)))))

(define (make-table)
 (let ((local-table (list '*table*)))
 (define (lookup key-1 key-2)
 (let ((subtable (assoc key-1 (cdr local-table))))
  (if subtable
      (let ((record (assoc key-2 (cdr subtable))))
        (if record
            (cdr record)
            #f))
      #f)))
 (define (insert! key-1 key-2 value)
 (let ((subtable (assoc key-1 (cdr local-table))))
  (if subtable
      (let ((record (assoc key-2 (cdr subtable))))
        (if record
            (set-cdr! record value)
            (set-cdr! subtable
                      (cons (cons key-2 value) (cdr subtable)))))
      (set-cdr! local-table
                (cons (list key-1
                            (cons key-2 value))
                      (cdr local-table)))))
 'ok)
 (define (dispatch m)
 (cond ((eq? m 'lookup-proc) lookup)
      ((eq? m 'insert-proc!) insert!)
      (else (error "Unknown operation -- TABLE" m))))
 dispatch))

(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))

(define (attach-tag type-tag 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))))

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

(define (raise x) (apply-generic 'raise x))
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (=zero? x) (apply-generic '=zero? x))

(define (install-integer-package)
  (define (tag x)
    (attach-tag 'integer x))
  (put 'add '(integer integer)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(integer integer)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(integer integer)
       (lambda (x y) (tag (* x y))))
  (put 'div '(integer integer)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'integer
       (lambda (x) (tag x)))
  (put 'equ? '(integer integer) =)
  (put '=zero? '(integer) zero?)
  (put 'raise '(integer)
       (lambda (x) (make-rational x 1)))
  'done)

(define (make-integer n)
  ((get 'make 'integer) n))

(define (install-real-package)
  (define (tag x)
    (attach-tag 'real x))
  (put 'add '(real real)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(real real)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(real real)
       (lambda (x y) (tag (* x y))))
  (put 'div '(real real)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'real
       (lambda (x) (tag x)))
  (put 'equ? '(real real) =)
  (put '=zero? '(real) zero?)
  (put 'raise '(real)
       (lambda (x) (make-complex-from-real-imag x 0)))
  'done)

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

(define (install-rational-package)
 ;; internal procedures
 (define (numer x) (car x))
 (define (denom x) (cdr x))
 (define (make-rat n d)
 (let ((g (gcd n d)))
  (if (zero? g)
      (cons 0 0)
      (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 (equ-rat? x y)
 (and (= (numer x) (numer y))
     (= (denom x) (denom y))))
 (define (=zero-rat? x)
 (and (zero? (numer x)) (zero? (denom x))))
 ;; interface to rest of the system
 (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))))

 (put 'make 'rational
   (lambda (n d) (tag (make-rat n d))))
 (put 'equ? '(rational rational) equ-rat?)
 (put '=zero? '(rational) =zero-rat?)
 (put 'raise '(rational)
      (lambda (x) (make-real (/ (numer x) (denom x)))))
 'done)

(define (make-rational n d)
 ((get 'make 'rational) n d))

(define (install-rectangular-package)
 ;; internal procedures
 (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 (equ-polar? x y)
 (and (= (real-part x) (real-part y))
     (= (imag-part x) (imag-part y))))
 (define (=zero-rect? x) (and (zero? (real-part x)) (zero? (imag-part x))))
 (define (make-from-mag-ang r a)
 (cons (* r (cos a)) (* r (sin a))))
 ;; interface to the rest of the system
 (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 'equ? '(rectangular rectangular) equ-polar?)
 (put '=zero? '(rectangular) =zero-rect?)
 (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)
 ;; internal procedures
 (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 (equ-polar? x y)
 (and (= (magnitude x) (magnitude y))
     (= (angle x) (angle y))))
 (define (=zero-polar? x) (and (zero? (magnitude x)) (zero? (angle x))))
 (define (make-from-real-imag x y)
 (cons (sqrt (+ (square x) (square y)))
     (atan y x)))
 ;; interface to the rest of the system
 (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 'equ? '(polar polar) equ-polar?)
 (put '=zero? '(polar) =zero-polar?)
 (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 (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))

(define (square x) (* x x))

(define (install-complex-package)
 ;; imported procedures from rectangular and polar packages
 (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))
 ;; internal procedures
 (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))))
 ;; interface to rest of the system
 (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))))
 (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))))
;; problem 2.77
 (put 'real-part '(complex) real-part)
 (put 'imag-part '(complex) imag-part)
 (put 'magnitude '(complex) magnitude)
 (put 'angle '(complex) angle)
;; problem 2.77
 (put 'equ? '(complex complex) equ?)
 (put '=zero? '(complex) =zero?)
 '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))