Scheme - データによる抽象の構築(汎用演算のシステム(異なる方のデータの統合(強制型変換、型の階層構造、階層構造の不適切さ(複素数を拡張))))

計算機プログラムの構造と解釈
Gerald Jay Sussman, Julie Sussman
Harold Abelson (原著) 和田 英一 (翻訳)
異なる出版社で予約受付中

開発環境

• OS X Mavericks - Apple(OS)
• Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
• Scheme (プログラミング言語)
• Gauche (処理系)

計算機プログラムの構造と解釈(Gerald Jay Sussman(原著)、Julie Sussman(原著)、Harold Abelson(原著)、和田 英一(翻訳)、ピアソンエデュケーション、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の2(データによる抽象の構築)、2.5(汎用演算のシステム)、2.5.2(異なる方のデータの統合)、強制型変換、型の階層構造、階層構造の不適切さ、問題 2.86.を解いてみる。

その他参考書籍

• Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
• プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)

問題 2.86.

コード(BBEdit, Emacs)

sample.scm

#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-

(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 (square-root x) (apply-generic 'square-root x))
(define (square x) (apply-generic 'square x))
(define (arctangent x) (apply-generic 'arctangent x))
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine 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)
    (square-root (add (square (real-part z)))))
  (define (angle z)
    (arctangent (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)
    (mul (magnitude z) (cosine (angle z))))
  (define (imag-part z)
    (mul (magnitude z) (sine (angle z))))
  (define (make-from-real-imag x y)
    (cons (square-root (add (square x)
                            (square y)))
          (arctangent 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-scheme-number)
  ;; 追加
  (define (square-root x) (sqrt x))
  (define (square x) (* x x))
  (define (arctangent x) (atan x))
  (define (sine x) (sin x))
  (define (cosine x) (cos x))

  ;; 追加
  (define (tag x) (attach-tag 'scheme-number x))
  (put 'square-root '(scheme-number)
       (lambda (x)
         (tag (square-root x))))
  (put 'square '(scheme-number)
       (lambda (x)
         (tag (square x))))
  (put 'arctangent '(scheme-number)
       (lambda (x)
         (tag (arctangent x))))
  (put 'sine '(scheme-number)
       (lambda (x)
         (tag (sine x))))
  (put 'cosine '(scheme-number)
       (lambda (x)
         (tag (cosine x))))
  'done)

(define (install-rational-number)
  ;; 追加
  (define (square-root x)
    (make-rat (sqrt (* (numer x) (numuer x)))
              (sqrt ((* (denom x) (denom x))))))
  (define (square x) (mul-rat x x))
  (define (arctangent x y)
    (make-rat
     (atan (/ (numuer x) (denom x))
           (/ (numuer y) (denom y)))
     1))
  (define (sine x)
    (make-rat (/ (numuer x) (denom x)) 1))
  (define (cosine x)
    (make-rat (/ (numuer x) (denom x)) 1))
  
  ;; 追加
  (define (tag x) (attach-tag 'rational))
  (put 'square-root '(rational)
       (lambda (x)
         (tag (square-root x))))
  (put 'square '(rational)
       (lambda (x)
         (tag (square x))))
  (put 'arctangent '(rational rational)
       (lambda (x y)
         (tag (arctangent x y))))
  (put 'sine '(rational)
       (lambda (x)
         (tag (sine x))))
  (put 'cosine '(rational)
       (lambda (x)
         (tag (cosine x))))
  'done)

(define (install-complex-number)
  (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-real-imag (mul (real-part z1)
                              (real-part z2))
                         (mul (imag-part z1)
                              (imag-part z2))))
  (define (div-complex z1 z2)
    (make-from-real-imag (div (real-part z1)
                              (real-part z2))
                         (div (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))))
  'done)

入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))

$ ./sample.scm
$