Scheme - データによる抽象の構築(汎用演算のシステム(例: 記号代数(多項式の算術演算、項リストの表現、記号代数における型の階層構造(複元多項式の加算と乗算の実装))))

計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著) ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著) Julie Sussman (原著)
Gerald Jay Sussman (原著) 和田 英一 (翻訳)

開発環境

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

計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の2(データによる抽象の構築)、2.5(汎用演算のシステム)、2.5.3(例: 記号代数)、多項式の算術演算、項リストの表現、記号代数における型の階層構造、問題 2.92.を解いてみる。

その他参考書籍

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

問題 2.92.

コード(BBEdit, Emacs)

sample.scm

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

(define (install-polynomial-package)
  ;; 内部手続き
  ;; ;; 変数に順序をつける x y z
  ;; 項の表現
  ;; xy^2 ((1 2 0) 1)
  ;; 10 ((0 0 0) 10)
  ;; 構成子
  (define (make-term orders coeff)
    (list orders coeff))
  ;; 選択子
  (define (orders term) (car term))
  (define (coeff term) (cadr term))

  (define (empty-termlist? term-list) (null? term-list))
  (define (first-termlist term-list) (car term-list))
  (define (rest-terms term-list) (cdr term-list))
  (define (the-empty-termlist) '())

  (define (>-orders orders1 orders2)
    (define (iter orders1 orders2)
      (if (null? orders1)
          #f
          (let ((o1 (car orders1))
                (o2 (car orders2)))
            (cond ((> o1 o2) #t)
                  ((< o1 o2) #f)
                  (else
                   (iter (cdr orders1) (cdr orders2)))))))
    (iter orders1 orders2))
  (define (<-orders orders1 orders2)
    (define (iter orders1 orders2)
      (if (null? orders1)
          #f
          (let ((o1 (car orders1))
                (o2 (car orders2)))
            (cond ((< o1 o2) #t)
                  ((> o1 o2) #f)
                  (else
                   (iter (cdr orders1) (cdr orders2)))))))
    (iter orders1 orders2))
  (define (=-orders orders1 orders2)
    (and (not (>-orders orders1 orders2))
         (not (<-orders orders1 orders2))))

  (define (adjoin-term term term-list)
    (if (=zero? (coeff term))
        term-list
        (cons term term-list)))
  (define (add-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          (else
           (let ((t1 (first-termlist L1))
                 (t2 (first-termlist L2)))
             (let ((orders1 (orders t1))
                   (orders2 (orders t2)))
               (cond ((>-orders orders1 orders2)
                      (adjoin-term
                       t1 (add-terms (rest-terms L1) L2)))
                     ((<-orders orders1 orders2)
                      (adjoin-term
                       t2 (adjoin-term L1 (rest-terms L2))))
                     (else
                      (adjoin-term
                       (make-term orders1
                                  (add (coeff orders1)
                                       (coeff orders2)))
                       (add-terms (rest-terms L1)
                                  (rest-terms L2))))))))))
  (define (add-orders orders1 orders2)
    (if (null? orders1)
        '()
        (cons (+ (car orders1)
                 (car orders2))
              (add-orders (cdr orders1)
                          (cdr orders2)))))
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t2 (first-termlist L)))
          (adjoin-term
           (make-term (add-orders (orders t1)
                                  (orders t2))
                      (mul (coeff t1) (coeff t2)))
           (mul-term-by-all-terms t1 (rest-terms L))))))
  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (first-termlist L1) L2)
                   (mul-term-by-all-terms (rest-terms L1) L2))))
  (define (make-poly variables term-list)
    (cons variables term-list))
  (define (variables p) (car p))
  (define (term-list p) (cdr p))
  (define (variable? x) (symbol? x))
  (define (same-variable? x y)
    (and (variable? x) (variable? y) (eq? x y)))
  (define (same-variables? variables1 variables2)
    (cond ((and (null? variables1) (null? variables2)) #t)
          ((and (not (null? variables1)) (null? variables2)) #f)
          ((and (null? variables1) (not (null? variables2))) #f)
          (else
           (and (same-variable? (car variables1)
                                (car variables2))
                (same-variables? (cdr variables1)
                                 (cdr variables2))))))
  (define (add-poly p1 p2)
    (if (same-variables? (variables p1)
                         (variables p2))
        (make-poly variables
                   (add-terms (term-list p1)
                              (term-list p2)))
        (error "Poly not in same variables -- ADD-POLY"
               (list p1 p2))))
  (define (mul-poly p1 p2)
    (if (same-variables? (variables p1)
                         (variables p2))
        (make-poly variables
                   (mul-terms (term-list p1)
                              (term-list p2)))
        (error "Poly not in same var -- MUL-POLY"
               (list p1 p2))))
  (define (mul-poly p1 p2)
    (make-poly variables
               (mul-terms (term-list p1)
                          (term-list p2))))

  ;; システムの他の部分とのインターフェース
  (define (tag p) (attach-tag 'polynomial p))
  (put 'add '(polynomial polynomial)
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial polynomial)
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put 'make 'polynomial
       (lambda (vars terms) (tag (make-poly vars terms))))
  'done)

(define (make-polynomial vars terms)
  ((get 'make 'polynomial) vars terms))

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

$ ./sample.scm
$