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.85.を解いてみる。

その他参考書籍

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

問題 2.85.

コード(BBEdit, Emacs)

sample.scm

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

;; 複素数を除く各型に働く汎用raise演算
(define (raise x) (apply-generic 'raise x))

;; 整数を除く各型に働く汎用project演算
(define (project x) (apply-generic 'product x))

;; オブジェクトを出来るだけ下げる手続き
(define (drop x)
  (let ((a (product x)))
    (if (not a)
        x
        (let ((b (raise a)))
          (if (eq? a b)
              (drop a)
              x)))))

;; 複素数パッケージ
(define (install-complex-package)
  (define (project x)
    (real-part x))

  (put 'project '(complex)
       (lambda (x)
         (make-real (project x))))
  'done)

;; 実数パッケージ
(define (install-real-package)
  (define (project x)
    (round x))

  (put 'project '(complex)
       (lambda (x)
         (make-rational (project x) 1)))
  'done)

;; 有理数パッケージ
(define (install-rational-package)
  (define (project x)
    (round (/ (numer x)
              (denom x))))

  (put 'project '(rational)
       (lambda (x)
         (make-integer (project x))))
  'done)

;; 整数パッケージ
(define (install-integer-package)
  (define (project x) #f)
  (put 'project '(integer) project)
  'done)  

(define (apply-generic op .args)
  (define tower '(complex real rational integer))
  (define (higher type1 type2 tower)
    (if (null? tower)
        #f
        (let ((type (car tower)))
          (cond ((eq? type1 type) type1)
            ((eq? type2 type) type2)
            (else
             (higher type1 type2 (cdr tower)))))))
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (drop (apply proc (map contents args)))
          (if (= (length args) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car args))
                    (a2 (cadr args)))
                (if (eq? type1 type2)
                    (error "No method for these types"
                           (list op type-tags))
                    (let ((type (higher type1 type2 tower)))
                      (cond ((not type)
                             (error "No method for thse types"
                                    (list op type-tags)))
                            ((eq? type1 type)
                             (apply-generic op a1 (raise a2)))
                            (else
                             (apply-generic op (raise a1) a2))))))
              (error "No method for these types"
                     (list op type-tags)))))))

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

$ ./sample.scm
$