SICP 問題 2.85（可能であれば型のレベルを下げようね）

も〜んのすげえ疲れた。。まぁでも理解は深まったかなぁ。
「追記（2010/10/30）」の箇所からが正しいコードになる。それより上の記録は削除しちゃおうかと思ったけど、生みの苦しみのログとしてのこしておくことにした。お疲れさん、俺。

問題

本節ではデータオブジェクトを型の塔をできるだけ「単純化」する方法を述べた。問題2.83で述べた塔についてこれを実施する手続きdropを設計せよ。

鍵は何か一般的方法でオブジェクトを下げられるか決める事である。例えば複素数1.5+0iはrealまで下げられ、複素数1+0iはinteger（scheme-number）まで下げられるが、複素数2+3iは全く下げられない。

オブジェクトが下げられるかを決める方法がある。オブジェクトを塔に沿って下へ「押す」汎用演算projectの定義から始める。
例えば複素数の投影は虚部を捨てることである。数をprojectし、結果をraiseして出発した型に戻したとき、出発したのと同じ何かで終われば、数は切り下げられる。オブジェクトをできるだけさげるdrop手続きを書いてこの考えを実装する方法を詳しく述べよ。
いろいろな投影演算を設計し、projectをシステムに汎用に実装する必要がある。また、問題2.79で述べた汎用等価述語を利用する必要がある。最後に答えを「単純化する」ように問題2.84のapply-genericを書き直すのにdropを使え。

解答

なんなんだこの長い上に分かりにくい文章は。projectとdropって同じことやるように読めるんだが俺の脳みそがおかしいのか？
あ、わかった。projectは１レベル下げる手続きで、dropは下げられるとこまで一気に下げる手続きか。

nよし、じゃ、まずは各型の数値オブジェクトを１レベル下げるproject手続きってのを定義してみっか。
ってかこれって各型のパッケージに定義しなきゃダメだな。

calculate-scheme-number.scm

こいつは下に下げる必要がないので変更なし。

calculate-rational.scm

コメントつけた箇所が変更したところ。

;;;==============================
;;;rational演算パッケージ
;;;==============================


(load "./calculate-real.scm")


(define (install-rational-package)
  (define (gcd a b)
    (if (= b 0)
	a
	(gcd b (remainder a b))))
  (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 (contents x) (contents y)))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat (contents x) (contents y)))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat (contents x) (contents y)))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat (contents x) (contents y)))))
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  (put 'equ? '(rational rational)
       (lambda (x y) (equal? x y)))
  (put '=zero? '(rational)
       (lambda (x)
	 (eq? 0 (numer x))))
  (put 'raise '(rational)
       (lambda (x)
	 (make-real (/ (numer (contents x)) (denom (contents x))))))
  ;scheme-numberに強制変換する手続き
  ;無理矢理丸めて整数にしてる。
  (put 'project 'rational
       (lambda (x)
	 (round (/ (numer (contents x)) (denom (contents x))))))
  'done)
(install-rational-package)

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

calcurate-real.scm

;;;==============================
;;;real演算パッケージ
;;;==============================

(load "./calculate-complex.scm")

(define (install-real-package)
;------------------------------
;有理数に強制変換する内部関数を追加
;------------------------------
(define (project x)
;---------
;有理数表記を有理数として返却
(define (rational->x value)
;数字の「文字列」を受け取って"/"で分割し、
(let *1
;分割できていれば有理数表現とみなして分子と分母を数値化して有理数を生成。
(let *2
;分割できていなければ#fを返却
#f)))
;---------
;浮動少数表記を有理数として返却
(define (decimal->x value)
;数字の「文字列」を受け取って"."で分割し、
(let *3
;分割できていれば浮動少数表現とみなして桁数をチェックし、
;分子と分母を計算して有理数を生成。
(let *4
;分割できていなければ#fを返却
#f)))
;メイン処理
(let* *5 ;有理数表現から変換
(ans1 (decimal->x value))) ;浮動小数点表現から変換
(cond (ans0 ans0)
(ans1 ans1)
(else
;有理数表現でも浮動少数表現でもなければ整数とみなしてそのまま返却
(make-rational (contents x) 1)))))

(define (tag x)
(attach-tag 'real x))
(put 'add '(real real)
(lambda (x y) (tag (+ (contents x) (contents y)))))
(put 'sub '(real real)
(lambda (x y) (tag (- (contents x) (contents y)))))
(put 'mul '(real real)
(lambda (x y) (tag (* (contents x) (contents y)))))
(put 'div '(real real)
(lambda (x y) (tag (/ (contents x) (contents y)))))
(put 'make 'real
(lambda (x) (tag x)))
(put 'equ? '(real real)
(lambda (x y) (equal? (contents x) (contents y))))
(put '=zero? '(real)
(lambda (x) (eq? 0 (contents x))))
(put 'raise '(real)
(lambda (x)
(make-complex-from-real-imag (contents x) 0)))
;;;有理数への強制型変換を公開
(put 'project 'real project)

'done)
(install-real-package)

(define (make-real n)
*6
|

calculate-complex.scm

equ?の実装にバグがあったのでそこも修正。（eq?を使ってた。。）

(load "./calculate-complex-rectanglar.scm")
(load "./calculate-complex-polar.scm")


(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 (* (magunitude z1) (magunitude z2))
		       (+ (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (magunitude z1) (magunitude z2))
		       (- (angle z1) (angle z2))))
  (define (real-part z)
    (apply-generic 'real-part (contents z)))
  (define (imag-part z)
    (apply-generic 'imag-part (contents z)))
  (define (magnitude z)
    (apply-generic 'magnitude (contents z)))
  (define (angle z)
    (apply-generic 'angle (contents z)))
  (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))))
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  (put 'equ? '(complex complex)
       ;equal?を使わないとダメだったのにeq?を使っていたので修正。。
       (lambda (x y) (equal? x y)))
  (put '=zero? '(complex)
       (lambda (x)
	 (apply-generic '=zero? x)))
  ;実数へ強制型変換する手続きを公開（虚数パートを削除して、実数パートを返却するだけ。）
  (put 'project 'complex
       (lambda (x)
	 (make-real (real-part x))))
  'done)
(install-complex-package)

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

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

calculate-complex-rectanglar.scm

前エントリと同じ。

calculate-complex-polar.scm

前エントリと同じ。

こんなとこか。ここまで書けば勘の悪い俺でも汎用手続きprojectが定義できるね。

calculate-system.scm

このファイルはこのエントリで修正される箇所をまとめたやつを最後にアップするので、ここでは必要な手続きだけを記載します。

;;１レベル下げる汎用手続き
(define (project x)
  ((get 'project (type-tag x)) x))

ではテストを書こう。

(define (test-project)
  ;単体テスト
  (define (print-test x answer)
    (guard (exc
	    ((<error> exc)
	     (begin
	       (print (eq? #f answer) " : x = " x)
	       (print "   : y = #f"))))
      ;ここが実際に実行されるロジック部分
      (let* ((y (raise (project x)))
	     (result (eq? answer (equ? x y))))
	(print result " : x = " x)
	(print "   : y = " y))))

  ;テストメイン処理
  (print "")
  (print-test (make-scheme-number 2) #f) ;下げられないので
  (print-test (make-rational 2 1) #t)
  (print-test (make-rational 2 2) #t)
  (print-test (make-rational 2 3) #f) ;整数にできないので。
  (print-test (make-real 3) #t)
  (print-test (make-real 3.0) #f) ;浮動少数点型を有理数にしてもschemeの内部表現として元の浮動少数点の数値には戻りません。この場合は整数になってしまいます。
  (print-test (make-real 3.1) #f) ;上と同じ理由で整数になってしまいます。
  (print-test (make-real 3.1415) #f) ;上と同じ理由ですが、schemeの内部表現として有理数の数値になってしまいます。
  (print-test (make-real 3.01415) #f) ;上と同じ理由で同じ値にはなりません。
  (print-test (make-real 1/3) #t)
  (print-test (make-real 0.025) #f) ;上と同じ理由で同じ値にはなりません。
  (print-test (make-real 1.025) #f) ;上と同じ理由で同じ値にはなりません。
  (print-test (make-complex-from-real-imag 0 0) #t)
  (print-test (make-complex-from-real-imag 0 1) #f)
  (print-test (make-complex-from-real-imag 1 1) #f)
  (print-test (make-complex-from-real-imag 1.5 0) #t)
  (print-test (make-complex-from-real-imag 1/5 0) #t)
  (print-test (make-complex-from-real-imag 3.141592 0) #t)
  (print-test (make-complex-from-real-imag 3.0141592 0) #t)
)
(test-project)

とりあえずこんなモンで試してみよう。

gosh> 

#t : x = 2

   : y = #f

#t : x = (rational 2 . 1)

   : y = (rational 2 . 1)

#t : x = (rational 1 . 1)

   : y = (rational 1 . 1)

#t : x = (rational 2 . 3)

   : y = (rational 1 . 1)

#t : x = (real . 3)

   : y = (real . 3)

#t : x = (real . 3.0)

   : y = (real . 3)

#t : x = (real . 3.1)

   : y = (real . 31/10)

#t : x = (real . 3.1415)

   : y = (real . 6283/2000)

#t : x = (real . 3.01415)

   : y = (real . 60283/20000)

#t : x = (real . 1/3)

   : y = (real . 1/3)

#t : x = (real . 0.025)

   : y = (real . 1/40)

#t : x = (real . 1.025)

   : y = (real . 41/40)

#t : x = (complex rectangular 0 . 0)

   : y = (complex rectangular 0 . 0)

#t : x = (complex rectangular 0 . 1)

   : y = (complex rectangular 0 . 0)

#t : x = (complex rectangular 1 . 1)

   : y = (complex rectangular 1 . 0)

#t : x = (complex rectangular 1.5 . 0)

   : y = (complex rectangular 1.5 . 0)

#t : x = (complex rectangular 1/5 . 0)

   : y = (complex rectangular 1/5 . 0)

#t : x = (complex rectangular 3.141592 . 0)

   : y = (complex rectangular 3.141592 . 0)

#t : x = (complex rectangular 3.0141592 . 0)

   : y = (complex rectangular 3.0141592 . 0)

#

gosh> 

いいねぇ〜。じゃ、次にアレだ。dropの実装だ。定義する場所はcalculate-system.scm。

calculate-system.scm

先ほどと同じく、必要な手続きだけを記載します。

;可能な限りレベルを下げていく手続き
(define (drop x)
  ;１レベルだけ下げてみる手続き
  (define (drop-1 x)
    (guard (exc
	    ((<error> exc)
	     ;エラーが発生した場合はdropできない
	     #f))
      (let* ((down (project x))
	     (y (raise down)))
	(if (equ? x y)
	    down
	    #f))))
  ;メインの処理
  (let loop ((src x)
	     (next (drop-1 x)))
    (if next
	(loop next (drop-1 next))
	src)))

こいつもテストを書いてみよう。

(define (test-drop)
  ;単体テスト
  (define (print-test x answer)
    (guard (exc
	    ((<error> exc)
	     (begin
	       (print (eq? #f answer) " : input  = " x)
	       (print "   : output = #f"))))
      ;ここが実際に実行されるロジック部分
      (let* ((y (drop x))
	     (result (equ? answer y)))
	(print result " : input  = " x)
	(print "   : output = " y))))

  ;テストメイン処理
  (print "")
  (print-test (make-scheme-number 2) 2)
  (print-test (make-rational 2 1) 2)
  (print-test (make-rational 2 2) 1)
  (print-test (make-rational 2 3) (make-rational 2 3))
  (print-test (make-real 3) 3)
  (print-test (make-real 3.0) (make-real 3.0))
  (print-test (make-real 3.1) (make-real 3.1))
  (print-test (make-real 3.1415) (make-real 3.1415))
  (print-test (make-real 3.01415) (make-real 3.01415))
  (print-test (make-real 1/3) (make-rational 1 3))
  (print-test (make-real 0.025) (make-real 0.025))
  (print-test (make-real 1.025) (make-real 1.025))
  (print-test (make-complex-from-real-imag 0 0) 0)
  (print-test (make-complex-from-real-imag 0 1) (make-complex-from-real-imag 0 1))
  (print-test (make-complex-from-real-imag 1 1) (make-complex-from-real-imag 1 1))
  (print-test (make-complex-from-real-imag 1.5 0) (make-real 1.5))
  (print-test (make-complex-from-real-imag 1/5 0) (make-rational 1 5))
  (print-test (make-complex-from-real-imag 3.141592 0) (make-real 3.141592))
  (print-test (make-complex-from-real-imag 3.0141592 0) (make-real 3.0141592))
)
(test-drop)

では実験。

gosh> 

#t : input  = 2

   : output = 2

#t : input  = (rational 2 . 1)

   : output = 2

#t : input  = (rational 1 . 1)

   : output = 1

#t : input  = (rational 2 . 3)

   : output = (rational 2 . 3)

#t : input  = (real . 3)

   : output = 3

#t : input  = (real . 3.0)

   : output = (real . 3.0)

#t : input  = (real . 3.1)

   : output = (real . 3.1)

#t : input  = (real . 3.1415)

   : output = (real . 3.1415)

#t : input  = (real . 3.01415)

   : output = (real . 3.01415)

#t : input  = (real . 1/3)

   : output = (rational 1 . 3)

#t : input  = (real . 0.025)

   : output = (real . 0.025)

#t : input  = (real . 1.025)

   : output = (real . 1.025)

#t : input  = (complex rectangular 0 . 0)

   : output = 0

#t : input  = (complex rectangular 0 . 1)

   : output = (complex rectangular 0 . 1)

#t : input  = (complex rectangular 1 . 1)

   : output = (complex rectangular 1 . 1)

#t : input  = (complex rectangular 1.5 . 0)

   : output = (real . 1.5)

#t : input  = (complex rectangular 1/5 . 0)

   : output = (rational 1 . 5)

#t : input  = (complex rectangular 3.141592 . 0)

   : output = (real . 3.141592)

#t : input  = (complex rectangular 3.0141592 . 0)

   : output = (real . 3.0141592)

#

gosh> 

テスト項目に抜けありまくりだけどまぁいいっす。
さて、最後にこいつを使ってapply-genericの評価結果を最適化すると。定義する場所は例によってcalculate-system.scm。先ほどと同じく、必要な手続きだけを記載します。

calculate-system.scm

(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
	 (proc (get op type-tags)))
    (if proc
	(drop (apply proc args))
	(let* ((coerced-list (coerce-higher-type-list args))
	       (type-tags (map type-tag coerced-list))
	       (proc (get op type-tags)))
	  (if proc
	      (drop (apply proc coerced-list))
	      (error
	       "No method for these types -- APPLY-GENERIC"
	       (list op type-tags)))))))

こんだけでいいんじゃね？
じゃ、例によってテストを。ってアホみたいにテストデータが多くなる上に総当たりかよ！どーしよ。map使って、評価結果を目視すればいいにしようか。。

(define (add-test)
  ;テスト用データ
  (define s (list 5 3))

  (define ra (list (make-rational 2 1)
		   (make-rational 6 2)
		   (make-rational 1 3)
		   (make-rational 2 3)))

  (define re (list (make-real 4)
		   (make-real 4/2)
		   (make-real 4/3)
		   (make-real 3.141592)
		   (make-real 2.858408)
		   (make-real 2.358408)))

  (define co (list (make-complex-from-real-imag 2 0)
		   (make-complex-from-real-imag 2/1 0)
		   (make-complex-from-real-imag 6/2 0)
		   (make-complex-from-real-imag 2/3 0)
		   (make-complex-from-real-imag 5/3 0)
		   (make-complex-from-real-imag 5/3 0)
		   (make-complex-from-real-imag 2 7)
		   (make-complex-from-real-imag 2 -7)
		   (make-complex-from-real-imag 1.5 -7)
		   (make-complex-from-real-imag 1/3 -7)))

  ;項目のテスト
  (define (print-test proc x y answer)
    (let ((result (proc x y)))
      (print (equal? result answer) " : (" proc " " x " " y ")")
      (print "        > result=" result)
      (print "        > answer=" answer)))

  ;テスト実施
  (print "")
  (print "<<整数と整数>>")
  (print-test add (ref s 0) (ref s 1) 8)
  (print "<<整数と有理数>>")
  (print-test add (ref s 0) (ref ra 0) 7)
  (print-test add (ref s 0) (ref ra 1) 8)
  (print-test add (ref s 0) (ref ra 2) (make-rational 16 3))
  (print-test add (ref s 0) (ref ra 3) (make-rational 17 3))
  (print "<<整数と実数>>")
  (print-test add (ref s 0) (ref re 0) 9)
  (print-test add (ref s 0) (ref re 1) 7)
  (print-test add (ref s 0) (ref re 2) (make-rational 19 3))
  (print-test add (ref s 0) (ref re 3) (make-real 8.141592))
  (print-test add (ref s 0) (ref re 4) (make-real 7.858408))
  (print-test add (ref s 0) (ref re 5) (make-real 7.358408))
  (print "<<整数と複素数>>")
  (print-test add (ref s 0) (ref co 0) 7)
  (print-test add (ref s 0) (ref co 1) 7)
  (print-test add (ref s 0) (ref co 2) 8)
  (print-test add (ref s 0) (ref co 3) (make-rational 17 3))
  (print-test add (ref s 0) (ref co 4) (make-rational 20 3))
  (print-test add (ref s 0) (ref co 5) (make-rational 20 3))
  (print-test add (ref s 0) (ref co 6) (make-complex-from-real-imag 7 7))
  (print-test add (ref s 0) (ref co 7) (make-complex-from-real-imag 7 -7))
  (print-test add (ref s 0) (ref co 8) (make-complex-from-real-imag 6.5 -7))
  (print-test add (ref s 0) (ref co 9) (make-complex-from-real-imag 16/3 -7))
)
(add-test)

これで試してみたら２番目の項目で無限ループに！なぜだ！？

追記（2010/10/30）

理由が分かった！
raiseとprojectは、型のレベルその物が重要なわけで、自動的に最適化してしまうと本来の意図通りに動かないってのが理由っぽい。
例えばprojectを汎用演算としてapply-generic使って実処理を呼び出そうとすると、例えばrealに適用した場合こうなってしまう。

(project '(real . 3.0)) ;意図する動作は(rational 3 . 1)が返ってきて欲しい感じ。

↓

内部ではapply-genericが呼び出されるので、apply-genericが返そうとする値に対してdropが適用される。

↓

(project '(real . 3.0))の評価結果としては、(rational 3 . 1)が帰ってきて欲しいのに、dropが適用されると3が返却されてしまう？実はこの解釈も違う！

実はdropの中では更に「汎用手続き」であるprojectやraiseが呼び出されているので、ここで無限ループが発生。

この問題を回避するため、raiseとprojectは「(get 'project '[data-type])」のように、apply-genericを使わずに呼び出すようにし、かつ各型パッケージのputで公開しているところは型タグをリストではなくアトムに修正したところ、正常に動作するようになってくれましたよ。あ〜しんどかった、何度諦めかけたことか。。
さて、では最終的に作成したモジュール群を再掲載しよう。

calculate-system.scm

(load "./sicp-hashtable.scm")
(load "./calculate-scheme-number.scm")


(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
	 (proc (get op type-tags)))
    (if proc
	;dropで最適化する
	(drop (apply proc args))
	(let* ((coerced-list (coerce-higher-type-list args))
	       (type-tags (map type-tag coerced-list))
	       (proc (get op type-tags)))
	  (if proc
	      ;dropで最適化する
	      (drop (apply proc coerced-list))
	      (error
	       "No method for these types -- APPLY-GENERIC"
	       (list op type-tags)))))))

(define (coerce-higher-type-list args)
  (define (coerce-to x tag)
    (let loop ((data x))
      (if (eq? (type-tag data) tag)
	  data
	  (let ((proc (get 'raise (type-tag data)))) ;汎用手続きではないraiseを取り出す
	    (if proc
		(loop (proc data))
		data)))))
  (let* ((tags (map type-tag args))
	 (highest (fold higher? (car tags) tags)))
    (map (lambda (x)
	   (coerce-to x highest))
	 args)))


(define (higher? tag0 tag1)
  (define tag-tower '(scheme-number rational real complex))

  (define (index tag)
    (let ((order (member tag tag-tower)))
      (if (eq? #f order)
	  (error "No match type -- HIGHER~INDEX?" tag)
	  (- (length tag-tower) (length order)))))

  (let ((index0 (index tag0))
	(index1 (index tag1)))
    (if (< index0 index1)
	tag1
	tag0)))

;可能な限りレベルを下げていく手続き
(define (drop x)
  ;１レベルだけ下げてみる内部手続き
  (define (drop-1 x)
    (guard (exc
	    ((<error> exc)
	     ;エラーが発生した場合はdropできない
	     #f))
      ;ここでも汎用手続きではないprojectとraiseを取り出して適用
      (let* ((down ((get 'project (type-tag x)) x))
	     (y ((get 'raise (type-tag down)) down)))
	(if (equ? x y)
	    down
	    #f))))
  (let loop ((src x)
	     (next (drop-1 x)))
    (if next
	(loop next (drop-1 next))
	src)))


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

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

(define (contents datum)
  (cond ((pair? datum)
	 (cdr datum))
	((number? datum)
	 datum)))

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

calculate-scheme-number.scm

(load "./calculate-rational.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))))
  (put 'make 'scheme-number
       (lambda (x) (tag x)))
  (put 'equ? '(scheme-number scheme-number)
       (lambda (x y) (eq? x y)))
  (put '=zero? '(scheme-number)
       (lambda (x) (eq? 0 (contents x))))
  ;'(scheme-number)ではなく、'scheme-numberに変更
  (put 'raise 'scheme-number
       (lambda (x)
	 (make-rational x 1)))

  'done)
(install-scheme-number-package)

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

calculate-rational.scm

(load "./calculate-real.scm")


(define (install-rational-package)
  (define (gcd a b)
    (if (= b 0)
	a
	(gcd b (remainder a b))))
  (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 (contents x) (contents y)))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat (contents x) (contents y)))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat (contents x) (contents y)))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat (contents x) (contents y)))))
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  (put 'equ? '(rational rational)
       (lambda (x y) (equal? x y)))
  (put '=zero? '(rational)
       (lambda (x)
	 (eq? 0 (numer x))))
  ;'(rational)ではなく、'rationalに変更
  (put 'raise 'rational
       (lambda (x)
	 (make-real (/ (numer (contents x)) (denom (contents x))))))
  ;'(rational)ではなく、'rationalに変更
  (put 'project 'rational 
       (lambda (x)
	 (round (/ (numer (contents x)) (denom (contents x))))))
  'done)
(install-rational-package)

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

calculate-real.scm

(load "./calculate-complex.scm")


(define (install-real-package)
  ;有理数に強制変換する内部関数
  (define (project x)
    ;有理数表記を有理数として返却
    (define (rational->x value)
      (let ((lis (string-split value "/")))
	(if (eq? 2 (length lis))
	    (let ((n (string->number (car lis)))
		  (d (string->number (cadr lis))))
	      (make-rational n d))
	    #f)))
    ;浮動少数表記を有理数として返却
    (define (decimal->x value)
      (let ((lis (string-split value ".")))
	(if (eq? 2 (length lis))
	    (let ((upper (string->number (car lis)))
		  (lower (string->number (cadr lis)))
		  (denom (expt 10 (string-length (cadr lis)))))
	      (make-rational (+ (* upper denom) lower) denom))
	    #f)))
    ;メイン処理
    (let* ((value (number->string (contents x)))
	   (ans0 (rational->x value))
	   (ans1 (decimal->x value)))
      (cond (ans0 ans0)
	    (ans1 ans1)
	    (else 
	     (make-rational (contents x) 1)))))

  (define (tag x)
    (attach-tag 'real x))
  (put 'add '(real real)
       (lambda (x y) (tag (+ (contents x) (contents y)))))
  (put 'sub '(real real)
       (lambda (x y) (tag (- (contents x) (contents y)))))
  (put 'mul '(real real)
       (lambda (x y) (tag (* (contents x) (contents y)))))
  (put 'div '(real real)
       (lambda (x y) (tag (/ (contents x) (contents y)))))
  (put 'make 'real
       (lambda (x) (tag x)))
  (put 'equ? '(real real)
       (lambda (x y) (equal? (contents x) (contents y))))
  (put '=zero? '(real)
       (lambda (x) (eq? 0 (contents x))))
  ;'(real)ではなく、'realに変更
  (put 'raise 'real
       (lambda (x)
	 (make-complex-from-real-imag (contents x) 0)))
  ;'(real)ではなく、'realに変更
  (put 'project 'real project)

  'done)
(install-real-package)

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

calculate-complex.scm

(load "./calculate-complex-rectanglar.scm")
(load "./calculate-complex-polar.scm")


(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 (* (magunitude z1) (magunitude z2))
		       (+ (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (magunitude z1) (magunitude z2))
		       (- (angle z1) (angle z2))))
  (define (real-part z)
    (apply-generic 'real-part (contents z)))
  (define (imag-part z)
    (apply-generic 'imag-part (contents z)))
  (define (magnitude z)
    (apply-generic 'magnitude (contents z)))
  (define (angle z)
    (apply-generic 'angle (contents z)))
  (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))))
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  (put 'equ? '(complex complex)
       (lambda (x y) (equal? x y)))
  (put '=zero? '(complex)
       (lambda (x)
	 (apply-generic '=zero? x)))
  ;'(complex)ではなく、'complexに変更
  (put 'project 'complex
       (lambda (x)
	 (make-real (real-part x))))
  'done)
(install-complex-package)

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

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

calculate-complex-rectanglar.scm

変更なし。

calculate-complex-polar.scm

変更なし。

こんな感じ。で、テストしようとしたんだけど、組み合わせがアホみたいに大量にあるんだよねぇ。
途中で力尽きたけど、まぁやりたい意図は伝わると思うし、うまく動いている風だからこんだけにしておこ。先に進みたいし。

(define (add-test)
  ;項目のテスト
  (define (print-test proc x y answer)
    (let ((result (proc x y)))
      (print (equal? result answer) " : (" proc " " x " " y ")")
      (print "        > result=" result)
      (print "        > answer=" answer)))

  ;テスト実施
  (print "")
  (print "<<整数と整数>>")
  (print-test add 3 5 8)
  (print "<<整数と有理数>>")
  (print-test add 3 (make-rational 4 1) 7) ;結果が整数
  (print-test add 3 (make-rational 2 3) (make-rational 11 3)) ;結果が有理数
  (print "<<整数と実数>>")
  (print-test add 3 (make-real 2) 5) ;結果が整数
  (print-test add 3 (make-real 4/2) 5) ;結果が整数
  (print-test add 3 (make-real 5.0) (make-real 8.0)) ;結果が実数
  (print-test add 3 (make-real 2/3) (make-rational 11 3)) ;結果が有理数
  (print-test add 3 (make-real 2.1) (make-real 5.1)) ;結果が実数
  (print "<<整数と複素数>>")
  (print-test add 3 (make-complex-from-real-imag 2 0) 5)
  (print-test add 3 (make-complex-from-real-imag 2/3 0) (make-rational 2 3))
  (print-test add 3 (make-complex-from-real-imag 2.1 0) (make-real 5.1))
  (print-test add 3 (make-complex-from-real-imag 2.1 2) (make-complex-from-real-imag 5.1 2))  
  (print "<<有理数と有理数>>")
  (print-test add (make-rational 3 1) (make-rational 4 2) 5) ;結果が整数
  (print-test add (make-rational 2 3) (make-rational 1 3) 1) ;結果が整数
  (print-test add (make-rational 2 3) (make-rational 1 4) (make-rational 11 12)) ;結果が有理数
  (print "<<有理数と実数>>")
  (print-test add (make-rational 3 1) (make-rational 4 2) 5) ;結果が整数
  (print-test add (make-rational 2 3) (make-rational 1 3) 1) ;結果が整数
  (print-test add (make-rational 2 3) (make-rational 1 4) (make-rational 11 12)) ;結果が有理数
  (print "<<有理数と複素数>>")
  (print-test add
	      (make-rational 3 1)
	      (make-complex-from-real-imag 2 0) 5) ;結果が整数
  (print-test add
	      (make-rational 2 3)
	      (make-complex-from-real-imag 1/3 0) 1) ;結果が整数
  (print-test add
	      (make-rational 2 3)
	      (make-complex-from-real-imag 1/4 0) (make-rational 11 12)) ;結果が有理数
  (print-test add
	      (make-rational 2 3)
	      (make-complex-from-real-imag 1.12 0) (make-real 1.7866666666666668)) ;結果が実数
)

実行結果がこれ。

gosh> (add-test)<<整数と整数>>

#t : (# 3 5)

        > result=8

        > answer=8<<整数と有理数>>

#t : (# 3 (rational 4 . 1))

        > result=7

        > answer=7

#t : (# 3 (rational 2 . 3))

        > result=(rational 11 . 3)

        > answer=(rational 11 . 3)<<整数と実数>>

#t : (# 3 (real . 2))

        > result=5

        > answer=5

#t : (# 3 (real . 2))

        > result=5

        > answer=5

#t : (# 3 (real . 5.0))

        > result=(real . 8.0)

        > answer=(real . 8.0)

#t : (# 3 (real . 2/3))

        > result=(rational 11 . 3)

        > answer=(rational 11 . 3)

#t : (# 3 (real . 2.1))

        > result=(real . 5.1)

        > answer=(real . 5.1)<<整数と複素数>>

#t : (# 3 (complex rectangular 2 . 0))

        > result=5

        > answer=5

#f : (# 3 (complex rectangular 2/3 . 0))

        > result=(rational 11 . 3)

        > answer=(rational 2 . 3)

#t : (# 3 (complex rectangular 2.1 . 0))

        > result=(real . 5.1)

        > answer=(real . 5.1)

#t : (# 3 (complex rectangular 2.1 . 2))

        > result=(complex rectangular 5.1 . 2)

        > answer=(complex rectangular 5.1 . 2)<<有理数と有理数>>

#t : (# (rational 3 . 1) (rational 2 . 1))

        > result=5

        > answer=5

#t : (# (rational 2 . 3) (rational 1 . 3))

        > result=1

        > answer=1

#t : (# (rational 2 . 3) (rational 1 . 4))

        > result=(rational 11 . 12)

        > answer=(rational 11 . 12)<<有理数と実数>>

#t : (# (rational 3 . 1) (rational 2 . 1))

        > result=5

        > answer=5

#t : (# (rational 2 . 3) (rational 1 . 3))

        > result=1

        > answer=1

#t : (# (rational 2 . 3) (rational 1 . 4))

        > result=(rational 11 . 12)

        > answer=(rational 11 . 12)<<有理数と複素数>>

#t : (# (rational 3 . 1) (complex rectangular 2 . 0))

        > result=5

        > answer=5

#t : (# (rational 2 . 3) (complex rectangular 1/3 . 0))

        > result=1

        > answer=1

#t : (# (rational 2 . 3) (complex rectangular 1/4 . 0))

        > result=(rational 11 . 12)

        > answer=(rational 11 . 12)

#f : (# (rational 2 . 3) (complex rectangular 1.12 . 0))

        > result=(real . 1.7866666666666668)

        > answer=(rational 11 . 12)

#

gosh> add-test

gosh> (add-test)<<整数と整数>>

#t : (# 3 5)

        > result=8

        > answer=8<<整数と有理数>>

#t : (# 3 (rational 4 . 1))

        > result=7

        > answer=7

#t : (# 3 (rational 2 . 3))

        > result=(rational 11 . 3)

        > answer=(rational 11 . 3)<<整数と実数>>

#t : (# 3 (real . 2))

        > result=5

        > answer=5

#t : (# 3 (real . 2))

        > result=5

        > answer=5

#t : (# 3 (real . 5.0))

        > result=(real . 8.0)

        > answer=(real . 8.0)

#t : (# 3 (real . 2/3))

        > result=(rational 11 . 3)

        > answer=(rational 11 . 3)

#t : (# 3 (real . 2.1))

        > result=(real . 5.1)

        > answer=(real . 5.1)<<整数と複素数>>

#t : (# 3 (complex rectangular 2 . 0))

        > result=5

        > answer=5

#f : (# 3 (complex rectangular 2/3 . 0))

        > result=(rational 11 . 3)

        > answer=(rational 2 . 3)

#t : (# 3 (complex rectangular 2.1 . 0))

        > result=(real . 5.1)

        > answer=(real . 5.1)

#t : (# 3 (complex rectangular 2.1 . 2))

        > result=(complex rectangular 5.1 . 2)

        > answer=(complex rectangular 5.1 . 2)<<有理数と有理数>>

#t : (# (rational 3 . 1) (rational 2 . 1))

        > result=5

        > answer=5

#t : (# (rational 2 . 3) (rational 1 . 3))

        > result=1

        > answer=1

#t : (# (rational 2 . 3) (rational 1 . 4))

        > result=(rational 11 . 12)

        > answer=(rational 11 . 12)<<有理数と実数>>

#t : (# (rational 3 . 1) (rational 2 . 1))

        > result=5

        > answer=5

#t : (# (rational 2 . 3) (rational 1 . 3))

        > result=1

        > answer=1

#t : (# (rational 2 . 3) (rational 1 . 4))

        > result=(rational 11 . 12)

        > answer=(rational 11 . 12)<<有理数と複素数>>

#t : (# (rational 3 . 1) (complex rectangular 2 . 0))

        > result=5

        > answer=5

#t : (# (rational 2 . 3) (complex rectangular 1/3 . 0))

        > result=1

        > answer=1

#t : (# (rational 2 . 3) (complex rectangular 1/4 . 0))

        > result=(rational 11 . 12)

        > answer=(rational 11 . 12)

#t : (# (rational 2 . 3) (complex rectangular 1.12 . 0))

        > result=(real . 1.7866666666666668)

        > answer=(real . 1.7866666666666668)

#

gosh> 

もういいら？

*1:lis (string-split value "/"))) (if (eq? 2 (length lis

*2:n (string->number (car lis))) (d (string->number (cadr lis)))) (make-rational n d

*3:lis (string-split value "."))) (if (eq? 2 (length lis

*4:upper (string->number (car lis))) (lower (string->number (cadr lis))) (denom (expt 10 (string-length (cadr lis))))) (make-rational (+ (* upper denom) lower) denom

*5:value (number->string (contents x))) (ans0 (rational->x value

*6:get 'make 'real) n