sicp p.109 メッセージパッシング から p.113 問題2.80 まで。2013-02-26 担当分。

q2.75.scm

(define (make-from-mag-ang r a)
  (define (dispatch op)
    (cond ((eq? op 'real-part) (* r (cos a)))
          ((eq? op 'imag-part) (* r (sin a)))
          ((eq? op 'magnitude) r)
          ((eq? op 'angle) a)
          (else
            (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
  dispatch)

(use gauche.test)
(test-start "make-from-mag-ang test")
(define (margin-of-error expected result)
  (< (abs (- expected result)) 0.01))

; 実行例
;
;     /|
;    / |
; 2 /  | (sqrt 3)
;  /   |
; /____|
;   1
(define r 2)
(define a (/ 3.14 3))
(define z (make-from-mag-ang r a))
(test* "magnitude" r (z 'magnitude))
(test* "angle" a (z 'angle))
(test "real-part" 1          (lambda () (z 'real-part))
      (lambda (expected result) (margin-of-error expected result)))
(test "imag-part" (sqrt 3)   (lambda () (z 'imag-part))
      (lambda (expected result) (margin-of-error expected result)))
(test-end)

q2.76.scm

; * 比較 *
; ** 明白な振り分けを持つ汎用演算 **
; （2.4.3の始めの文から2.4.2の「タグを調べて振り分けする実装」のことだと思われる）
;
; 新しい型の追加
; p.104とp.105にある通り、既存の全ての演算に手を加える必要がある
; "例えば複素数システムに、新しい複素数の表現を組み込みたかったとしよう。
;  われわれはこの新しい表現を型と共に認識する必要があり、汎用インターフェース手続きのすべてに
;  新しい型を調べ、その表現に適した選択子を作用させるプログラムを追加しなければならない" - p.105
;
; 新しい演算の追加
; これはそれぞれの型に既にその手続きがあるかどうかによって変わる
; 既にすべての方に存在する手続きならば、汎用演算を追加するだけで良い
; もし存在しない型があるならば、その型にも演算を追加する必要がある
;
; ** データ主導流 **
;
; 新しい型の追加
; 図2.22の型（列）を増やすだけで済む。つまり既存システムに変更点なし。
; "新しい表現をパッケージに追加するにも、既存の手続きを変更する必要はなく、
;  表に新しい項目を追加するだけでよい" - p.105
;
; 新しい演算の追加
; 図2.22の演算（行）を増やすことになる。つまり、
; 1. インターフェースを追加し、
; 2. 各々の方の内部手続きを追加する
; 必要がある
; -> ajiyoshiさん補足：新しいパッケージ増やしてそれをinstallするだけでも済むよ
;
; ** メッセージパッシング **
;
; 新しい型の追加
; 図2.22の型（列）を増やすだけで済む。つまり既存システムに変更点なし。
;
; 新しい演算の追加
; すべての型にその演算がある必要はなく（演算がない場合はerrorになるようにしてあるので）
; そのため追加したい型にだけ変更すれば良い
;
; * まとめ *
;
; 新しい型が絶えず追加される場合にはデータ主導流かメッセージパッシングが良く、
; 新しい演算が絶えず追加される場合にはすべての型に同等の機能を持たせたい場合にはデータ主導流でも良いが、
; 古いシステムはメンテナンスしない（使わなくなる型があってもよい）なら
; メッセージパッシングで新しい型を増やすというやり方が良さそう
; -> データ主導流も既存の型増やさなくても済むよ

q2.77.scm

(load "./s2.5.scm")
(print "==================================== q2.77 ============================================")

(install-rectangular-package)
(install-polar-package)
(install-complex-package)
(define z-real 3)
(define z-imag 4)
(define z (make-complex-from-real-imag z-real z-imag))

(use slib)
(require 'trace)
(trace apply-generic)
; (print (magnitude z))
;=> CALL apply-generic magnitude (complex rectangular 3 . 4)
;=> "error": No method for these types -- APPLY-GENERIC (magnitude (complex))

(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)

(print (magnitude z))
;=> CALL apply-generic magnitude (complex rectangular 3 . 4)
;=>   CALL apply-generic magnitude (rectangular 3 . 4)
;=>   RETN apply-generic 5
;=> RETN apply-generic 5

; どうして動くか？どうして動かないか？
; magnitude の手続きは
; (define (magnitude z) (apply-generic 'magnitude z))
; で、
; apply-generic の手続きは
; (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))))))
; である
; また、
; (put <op> <type> <item>)
; の意味は <item> を表の <op> と <type> のところに設定する
; つまり、<type> タグが付いた <op> という手続きは <item> という手続き
;
; z には図2.24のとおり一番外側に complex のタグが付き、その後に rectangular のタグが付いている
; (magnitude z) を評価すると apply-generic に z が渡されるが、
; この時に 'complex のタグ付いた magnitude がないためエラーになる
; (put 'magnitude '(complex) magnitude) を評価することで 'complex のタグが付いた magnitude ができるため
; 評価され、その返りは magnitude （元々評価したかった rectangular の magnitude）に渡されるため動く

q2.78.scm

(load "./s2.5.scm")
(print "==================================== q2.78 ============================================")

; make-hogehoge をしなくても
; (add x y)
; のようにしよう
; と読み取りました
;
; 通常は car と cdr を使い tag と number に分ける所を、
; mumber? で判別し、数なら scheme-number と見なすように変更すればよい
; ただ、これ 'scheme-number ってのがこの中に表れることになるので、
; そんなハードコーディングしてもいいのかなぁ？
; という感じ

(define (attach-tag type-tag contents)
  (if (eq? type-tag 'scheme-number)
    contents
    (cons type-tag contents)))
(define (type-tag datum)
  (if (number? datum)
    'scheme-number
    (if (pair? datum)
      (car datum)
      (error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
  (if (number? datum)
    datum
    (if (pair? datum)
      (cdr datum)
      (error "Bad tagged datum -- CONTENTS" datum))))

(install-scheme-number-package)

(use gauche.test)
(define x 10)
(define y 5)
(define tagged-x (make-scheme-number x))
(define tagged-y (make-scheme-number y))
(test-start "scheme-number test")
(test* "add number" (+ x y) (add x y))
(test* "add scheme-number" (+ x y) (add tagged-x tagged-y))
(test-end)

q2.79.scm

(load "./s2.5.scm")
(print "==================================== q2.79 ============================================")

; まず始めに外部から実行できるようにdefine
(define (equ? x y) (apply-generic 'equ? x y))

; 注意）すでに定義済みの手続きを書くと長くなってわかりにくくなるので省略

; ================================================================================

; 通常の数
; eq? を使うだけで良い
(define (install-scheme-number-package)
  ;; 内部手続きは基本算術演算のため必要なし

  ;; システムの他の部分へのインターフェース
  (define (tag x)
    (attach-tag 'scheme-number x))
  (put 'equ? '(scheme-number scheme-number)
       (lambda (x y) (tag (eq? x y))))
  'done)

; 実行例
(install-scheme-number-package)
(define x 10)
(define y x)
(define tagged-x (make-scheme-number x))
(define tagged-y (make-scheme-number y))

(use gauche.test)
(test-start "scheme-number test")
(test-section "scheme-number")
(test* "equ?" #t (contents (equ? tagged-x tagged-y)))
(test-end)

; ================================================================================

; 有利数
; number も denom も eq? なら良い
(define (install-rational-package)
  ;; 内部手続き
  (define (number x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (let ((g (gcd n d)))
      (cons (/ n g) (/ d g))))

  (define (equ? x y)
    (and (eq? (number x) (number y))
         (eq? (denom x) (denom y))))

  ;; システムの他の部分へのインターフェース
  (define (tag x)
    (attach-tag 'rational x))
  (put 'equ? '(rational rational)
       (lambda (x y) (tag (equ? x y))))

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

; 実行例
(install-rational-package)
(define tagged-x (make-rational 2 3))
(define tagged-y tagged-x)

(use gauche.test)
(test-start "rational test")
(test-section "rational")
(test* "equ?" #t (contents (equ? tagged-x tagged-y)))
(test-end)

; ================================================================================

; 複素数
; real も imag も eq? なら良い
(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 (equ? z1 z2)
    (and (eq? (real-part z1) (real-part z2))
         (eq? (imag-part z1) (imag-part z2))))

  ;; システムの他の部分へのインターフェース
  (define (tag z)
    (attach-tag 'complex z))
  (put 'equ? '(complex complex)
       (lambda (z1 z2) (tag (equ? 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))))
  'done)

; 実行例
(install-rectangular-package)
(install-polar-package)
(install-complex-package)

(use gauche.test)
(test-start "complex test")

(test-section "rectangular")
(define tagged-z1 (make-complex-from-real-imag 3 4))
(define tagged-z2 tagged-z1)
(test* "equ?" #t (contents (equ? tagged-z1 tagged-z2)))

(test-section "polar")
(define tagged-z1 (make-complex-from-mag-ang 1 (/ 3.14 2)))
(define tagged-z2 tagged-z1)
(test* "equ?" #t (contents (equ? tagged-x tagged-y)))
(test-end)

q2.80.scm

(load "./s2.5.scm")
(print "==================================== q2.80 ============================================")

; まず始めに外部から実行できるようにdefine
(define (=zero? x) (apply-generic '=zero? x))

; 注意）すでに定義済みの手続きを書くと長くなってわかりにくくなるので省略

; ================================================================================

; 通常の数
; eq? を使い0なら#t
(define (install-scheme-number-package)
  ;; 内部手続きは基本算術演算のため必要なし

  ;; システムの他の部分へのインターフェース
  (define (tag x)
    (attach-tag 'scheme-number x))
  (put '=zero? '(scheme-number)
       (lambda (x) (tag (eq? x 0))))
  'done)

; 実行例
(install-scheme-number-package)
(define non-zero 10)
(define zero 0)
(define tagged-non-zero (make-scheme-number non-zero))
(define tagged-zero (make-scheme-number zero))

(use gauche.test)
(test-start "scheme-number test")
(test-section "scheme-number =zero?")
(test* "non-zero" #f (contents (=zero? tagged-non-zero)))
(test* "zero" #t (contents (=zero? tagged-zero)))
(test-end)

; ================================================================================

; 有利数
; denom に関係なく number が0なら#t
(define (install-rational-package)
  ;; 内部手続き
  (define (number x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (let ((g (gcd n d)))
      (cons (/ n g) (/ d g))))

  (define (=zero? x)
    (and (eq? (number x) 0)))

  ;; システムの他の部分へのインターフェース
  (define (tag x)
    (attach-tag 'rational x))
  (put '=zero? '(rational)
       (lambda (x) (tag (=zero? x))))

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

; 実行例
(install-rational-package)
(define tagged-non-zero (make-rational 2 3))
(define tagged-zero (make-rational 0 3))

(use gauche.test)
(test-start "rational test")
(test-section "rational =zero?")
(test* "non-zero" #f (contents (=zero? tagged-non-zero)))
(test* "zero" #t (contents (=zero? tagged-zero)))
(test-end)

; ================================================================================

; 複素数
; magnitude が0なら#t
; （real も imag も0なら#tだと極座標の方で問題あり）
(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 (=zero? z)
    (eq? (magnitude z) 0))

  ;; システムの他の部分へのインターフェース
  (define (tag z)
    (attach-tag 'complex z))
  (put '=zero? '(complex)
       (lambda (z) (tag (=zero? z))))

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

; 実行例
(install-rectangular-package)
(install-polar-package)
(install-complex-package)

(use gauche.test)
(test-start "complex test")

(test-section "rectangular =zero?")
(define tagged-non-zero (make-complex-from-real-imag 3 4))
(define tagged-zero (make-complex-from-real-imag 0 0))
(test* "non-zero" #f (contents (=zero? tagged-non-zero)))
(test* "zero" #t (contents (=zero? tagged-zero)))

(test-section "polar =zero?")
(define tagged-non-zero (make-complex-from-mag-ang 1 (/ 3.14 2)))
(define tagged-zero (make-complex-from-mag-ang 0 (/ 3.14 2)))
(test* "non-zero" #f (contents (=zero? tagged-non-zero)))
(test* "zero" #t (contents (=zero? tagged-zero)))
(test-end)

s2.4.3-p.109.scm

; データ主導プログラミングとメッセージパッシング
;
; まずデータ主導プログラミングの場合
; 図2.22の
; "演算対型の表を行方向に分割し、各汎用演算手続きは、表の行を代表していた" - p.109
;
; 例えば
; real-partという演算
; は
; real-part-polarとreal-part-rectangular
; の代表で、polarかrectangularのパッケージをインストールすることで、
; 環境がreal-part-polarとreal-part-rectangularのどちらの手続きを実行するかを理解していた
;
; これに対してメッセージパッシングの場合には
; 図2.22の
; "表を列方向に分割することで、... 手続き名によって振り分ける「賢明なデータオブジェクト」で
; 仕事をする" - p.109
;
; 例えば
; make-from-real-imag
; を実行するとclosureが返ってきて、このclosureがそれぞれの演算を知っている（賢明なデータオブジェクト）

(define (square x) (* x x))
(define (make-from-real-imag x y)
  (define (dispatch op)
    (cond ((eq? op 'real-part) x)
          ((eq? op 'imag-part) y)
          ((eq? op 'magnitude)
           (sqrt (+ (square x) (square y))))
          ((eq? op 'angle) (atan y x))
          (else
            (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
  dispatch)

; 実行例
;
;      (3 + 4i)
;     /|
;    / |
;   /  | 4
;  /   |
; /____|
;   3
;
(define z (make-from-real-imag 3 4))
(print (z 'real-part))      ;=> 3
(print (z 'imag-part))      ;=> 4
(print (z 'magnitude))      ;=> 5
(print (z 'angle))

; この場合のapply-genericは表へのアクセスが必要なくなり（賢明なデータオブジェクトが全ての演算を知っているので）
; 賢明なデータオブジェクトに演算を渡すだけで済む
(define (apply-generic op arg) (arg op))

; 実行例
(use gauche.test)
(test-start "apply-generic test")
(test* "real-part" (z 'real-part) (apply-generic 'real-part z))
(test* "imag-part" (z 'imag-part) (apply-generic 'imag-part z))
(test* "magnitude" (z 'magnitude) (apply-generic 'magnitude z))
(test* "angle" (z 'angle) (apply-generic 'angle z))
(test-end)

s2.5.scm

; まずは get と put と apply-generic が必要なのでその定義

; p.159
(define true #t)
(define false #f)

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

; ================================================================================

; p.102
(define (attach-tag type-tag contents)
  (cons type-tag contents))
(define (type-tag datum)
  (if (pair? datum)
    (car datum)
    (error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
  (if (pair? datum)
    (cdr datum)
    (error "Bad tagged datum -- CONTENTS" datum)))

; p.107
(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 (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))

; ================================================================================
; 基本算術演算を scheme-number のタグで install する手続き
(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)))
  'done)

; タグ付きの基本の数を作り出す手続き
(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))

; 実行例
(install-scheme-number-package)
(define x 10)
(define y 5)
(define tagged-x (make-scheme-number x))
(define tagged-y (make-scheme-number y))

(use gauche.test)
(test-start "scheme-number test")
(test* "add" (+ x y) (contents (add tagged-x tagged-y)))
(test* "sub" (- x y) (contents (sub tagged-x tagged-y)))
(test* "mul" (* x y) (contents (mul tagged-x tagged-y)))
(test* "div" (/ x y) (contents (div tagged-x tagged-y)))
(test-end)

; ================================================================================
; 有理数算術演算を rational のタグで install する手続き
(define (install-rational-package)
  ;; 内部手続き
  (define (number 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 (+ (* (number x) (denom y))
                 (* (number y) (denom x)))
              (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (number x) (denom y))
                 (* (number y) (denom x)))
              (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (number x) (number y))
              (* (denom y) (denom x))))
  (define (div-rat x y)
    (make-rat (* (number x) (denom y))
              (* (denom x) (number 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))))

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

; タグ付きの有利数を作り出す手続き
(define (make-rational n d)
  ((get 'make 'rational) n d))

; 実行例
(install-rational-package)
(define n-x 2)
(define d-x 3)
(define n-y 1)
(define d-y 2)
(define x (/ n-x d-x))
(define y (/ n-y d-y))
(define tagged-x (make-rational n-x d-x))
(define tagged-y (make-rational n-y d-y))

(use gauche.test)
(test-start "rational test")
(define added (contents (add tagged-x tagged-y)))
(test* "add" (+ x y) (/ (car added) (cdr added)))
(define subed (contents (sub tagged-x tagged-y)))
(test* "sub" (- x y) (/ (car subed) (cdr subed)))
(define muled (contents (mul tagged-x tagged-y)))
(test* "mul" (* x y) (/ (car muled) (cdr muled)))
(define dived (contents (div tagged-x tagged-y)))
(test* "div" (/ x y) (/ (car dived) (cdr dived)))
(test-end)

; ================================================================================
; まずは複素数算術演算のためにp.106の install-{rectangular,polar}-package の2つをdefine
; またそれらを使うための {real,imag}-part と {magnitude,angle} をdefine
(define (square x) (* x x))
(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 (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))


; 複素数算術演算を complex のタグで install する手続き
(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))))

  (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-rectangular-package)
(install-polar-package)
(install-complex-package)
(define z1-real 2)
(define z1-imag 3)
(define z2-real 1)
(define z2-imag 2)
(define tagged-z1 (make-complex-from-real-imag z1-real z1-imag))
(define tagged-z2 (make-complex-from-real-imag z2-real z2-imag))

(test-start "complex test")
(define added (contents (contents (add tagged-z1 tagged-z2))))
(test* "add-real" (+ z1-real z2-real) (car added))
(test* "add-imag" (+ z1-imag z2-imag) (cdr added))
(define subed (contents (contents (sub tagged-z1 tagged-z2))))
(test* "sub-real" (- z1-real z2-real) (car subed))
(test* "sub-imag" (- z1-imag z2-imag) (cdr subed))
(test-end)