## 2014年6月3日火曜日

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

その他参考書籍

コード(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 (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))))

(if (=zero? (coeff term))
term-list
(cons term term-list)))
(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)
((<-orders orders1 orders2)
(else
(make-term orders1
(coeff orders2)))
(rest-terms L2))))))))))
(if (null? orders1)
'()
(cons (+ (car orders1)
(car orders2))
(cdr orders2)))))
(define (mul-term-by-all-terms t1 L)
(if (empty-termlist? L)
(the-empty-termlist)
(let ((t2 (first-termlist L)))
(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)
(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))))))
(if (same-variables? (variables p1)
(variables p2))
(make-poly variables
(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))
(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))
```

```\$ ./sample.scm
\$
```