Serendip

Web Studio

問題2.86

complex 型の drop は省いている。

integer, real 型の sin, cos, atan, square, sqrt を実装し、complex, rectangular, polar 型を変更する。

(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
(define (atang y x) (apply-generic 'atang y x))
(define (square x) (apply-generic 'square x))
(define (square-root x) (apply-generic 'square-root x))

;;; 整数(integer)演算パッケージ
(define (install-integer-package)
...
  (put 'sine '(integer)
       (lambda (x) (tag (sin x))))
  (put 'cosine '(integer)
       (lambda (x) (tag (cos x))))
  (put 'atang '(integer integer)
       (lambda (y x) (tag (atan y x))))
  (put 'square '(integer)
       (lambda (x) (tag (* x x))))
  (put 'square-root '(integer)
       (lambda (x) (tag (sqrt x))))
...
  'done)

;;; 実数(real)演算パッケージ
(define (install-real-package)
...
  (put 'sine '(real)
       (lambda (x) (tag (sin x))))
  (put 'cosine '(real)
       (lambda (x) (tag (cos x))))
  (put 'atang '(real real)
       (lambda (y x) (tag (atan y x))))
  (put 'square '(real)
       (lambda (x) (tag (* x x))))
  (put 'square-root '(real)
       (lambda (x) (tag (sqrt x))))
...
  'done)

;;;;; 直交座標形式の表現
(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)
    (square-root (add (square (real-part z))
             (square (imag-part z)))))
  (define (angle z)
    (atang (imag-part z) (real-part z)))
  (define (make-from-mag-ang r a)
    (cons (mul r (cosine a)) (mul r (sine 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) (cosine (angle z))))
  (define (imag-part z)
    (* (magnitude z) (sine (angle z))))
  (define (make-from-real-imag x y)
    (cons (square-root (add (mul x x) (mul y y)))
          (atang 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)

(install-rectangular-package)
(install-polar-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))

;;; 複素数(complex)演算パッケージ
(define (install-complex-package)
  (define (make-from-real-imag x y)
    ((get 'make-from-real-imag 'rectangular) x y))
  (define (make-complex-from-mag-ang r a)
    ((get 'make-from-mag-ang 'rectangular) r a))
  ;;
  (define (add-complex z1 z2)
    (make-from-real-imag (add (real-part z1) (real-part z2))
                         (add (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (sub (real-part z1) (real-part z2))
                         (sub (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (mul (magnitude z1) (magnitude z2))
                       (add (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (div (magnitude z1) (magnitude z2))
                       (sub (angle z1) (angle z2))))
  (define (=complex-zero? z1)
    (and (= (real-part z1) 0)
         (= (imag-part z1) 0)))
  (define (complex-equ? z1 z2)
    (and (equ? (real-part z1) (real-part z2))
         (equ? (imag-part z1) (imag-part 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))))
  (put 'equ? '(complex complex)
       complex-equ?)
  (put '=zero? '(complex)
       (lambda (z) (=complex-zero? z)))
  (put 'real-part 'complex real-part)
  (put 'imag-part 'complex imag-part)
  (put 'magnitude 'complex magnitude)
  (put 'angle 'complex angle)
  '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 int (make-integer 2))
(define rat (make-rational 2 4))
(define rel (make-real 3.5))
(define cpx (make-complex-from-real-imag 2.4 0))
(add int cpx)
gosh> (complex rectangular (real . 4.4) integer . 0)
(add cpx rel)
gosh> (complex rectangular (real . 5.9) integer . 0)
(add cpx cpx)
gosh> (complex rectangular (real . 4.8) integer . 0)
(sub cpx int)
gosh> (complex rectangular (real . 0.3999999999999999) integer . 0)
(mul cpx int)
gosh> (complex polar (real . 4.8) integer . 0)
(div cpx rat)
gosh> (complex polar (real . 4.8) integer . 0)
(mul cpx cpx)
gosh> (complex polar (real . 5.76) integer . 0)
(div cpx cpx)
gosh> (complex polar (integer . 1) integer . 0)

計算機プログラムの構造と解釈

posted with amazlet at 08.11.07

ジェラルド・ジェイ サスマン ジュリー サスマン ハロルド エイブルソン
ピアソンエデュケーション
売り上げランキング: 6542

Amazon.co.jp で詳細を見る