ぅ〜〜〜ッッ！

sicp

今週はお休みです。
代わりになんか書きます。
SICPも2.3章に入るわけなのですが、ここからシンボリックデータを扱えるようになります。
これを利用して、代数的な操作を実装してみようと思う。
これから上げる例は、１変数多項式の展開形を求めるもの。
たとえば、多項式として、 (x^2 + 1)(x +2) = 2 + x + 2x^2 + x^3が成り立つわけですが、多項式の表現から一般に展開形： a_0 + a_1x + a_2x^2 + \cdots + a_nx^n を求めるprocedure"show-poly"を書く。
まず、建前上、多項式の表現を定義します。

(define (variable? x) (symbol? x))
(define (constant? x) (number? x))
(define (polynomial? exp var)
  (cond ((eq? exp var) #t)
	((number? exp) #t)
	((or (eq? (car exp) '+) (eq? (car exp) '*)) (and (polynomial? (car (cdr exp)) var) (polynomial? (car (cdr (cdr exp))) var)))
	(else #f)))

つまりここで多項式は、一つの変数とその他の定数の二項の和と積を再帰的に繰り返して得られたものしか認めないものとしてます。
この時の、１変数多項式の展開は以下の通り：

(define (show-poly exp0 var0)
  (define (sum-seq x y)
    (cond ((null? x) y)
	  ((null? y) x)
	  (else (cons (+ (car x) (car y)) (sum-seq (cdr x) (cdr y))))))

  ;; Convolution, that is, a product rule for polynomials
  (define (conv-seq x y)
    (define (reverse s)
      (define (init-last s) (if (null? (cdr s)) (cons () (car s)) (cons (cons (car s) (car (init-last (cdr s)))) (cdr (init-last (cdr s))))))
      (if (null? s) () (cons (cdr (init-last s)) (reverse (car (init-last s))))))
    (define (convolution a b)
      (define (sum-prod s t)
	(if (and (null? s) (null? t)) 0
	    (+ (* (car s) (car t)) (sum-prod (cdr s) (cdr t)))))
	(sum-prod a (reverse b)))
    (define (conv-seq-itr s t memx memy result)
      (if (and (null? s) (null? t)) result
	  (conv-seq-itr (cdr s) (cdr t) (cons (car s) memx) (cons (car t) memy) (cons (convolution memx memy) result))))
    (cdr (reverse (cons 0 (conv-seq-itr x y () () ())))))

  ;; Calculate normal-form
  (define (normal-form0 exp var deg)
    (define (zero-seq n) (if (= n 0) (list 0) (cons 0 (zero-seq (- n 1)))))
    (define zero-d (zero-seq (+ deg 2)))
    (cond ((null? exp) zero-d)
	  ((number? exp) (sum-seq (list exp) zero-d))
	  ((eq? exp var) (sum-seq (list 0 1) zero-d))
	  ((eq? (car exp) '+) (sum-seq (normal-form0 (car (cdr exp)) var deg) (normal-form0 (car (cdr (cdr exp))) var deg)))
	  ((eq? (car exp) '*) (conv-seq (normal-form0 (car (cdr exp)) var deg) (normal-form0 (car (cdr (cdr exp))) var deg)))))
  (define (degree exp)
    (cond ((null? exp) 0)
	  ((constant? exp) 1)
	  ((variable? exp) 1)
	  ((eq? (car exp) '+) (max (degree (car (cdr exp))) (degree (car (cdr (cdr exp))))))
	  ((eq? (car exp) '*) (+ 1 (max (degree (car (cdr exp))) (degree (car (cdr (cdr exp)))))))))

  (define (normal-form exp var)
    (let ((b (reverse (normal-form0 exp var (degree exp)))))
      (define (whilezero x)
	(if (= (car x) 0) (whilezero (cdr x)) x))
      (reverse (whilezero b))))

  (define (show-normal-form s var)
    (define (all-append s)
      (if (null? s) () (append (car s) (all-append (cdr s)))))
    (define (zipfrom s n) (if (null? s) () (cons (list n (car s)) (zipfrom (cdr s) (+ n 1)))))
    (let ((t (map (lambda (p)
		    (cond  ((= (car (cdr p)) 0) ())
			   ((and (= (car (cdr p)) 1) (= (car p) 1)) (list var '+))
			   ((and (= (car (cdr p)) 1) (= (car p) (- (length s) 1))) (list var '^ (car p)))
			   ((= (car (cdr p)) 1) (list var '^ (car p) '+))
			   ((= (car p) 0) (list (car (cdr p)) '+))
			   ((= (car p) 1) (list (car (cdr p)) var '+))
			   ((= (car p) (- (length s) 1)) (list (car (cdr p)) var '^ (car p)))
			   (else (list (car (cdr p)) var '^ (car p) '+)))) (zipfrom s 0))))
      (for-each (lambda (x) (display x)) (all-append t))))

  (show-normal-form (normal-form exp0 var0) var0)
)

色々と冗長ですが、前回2.2章の分を少しサボっていた、その演習代わりみたいなものなのでお許しを
(reverse とか zip とかいかにもlist構造弄ってる感じしますなあ)。
show-polyは多項式のシンボリックデータとその変数名を受け取り、展開形にして返します：

gosh> (show-poly '(* t (+ (* t t) 1)) 't)
> t+t^3#<undef>
gosh> (show-poly '(+ (* x (* (+ x 1) (+ x 2))) 8) 'x)
> 8+2x+3x^2+x^3#<undef>

コード見るとそんなに綺麗な形ではないので改善の余地ありで、例外処理もしてないし、バグももしかしたら変なものが紛れ込んでいる可能性大です。
とりあえずこんなかんじで。

にゃんにゃんしてません