SICP 問題2.89（濃い多項式）

問題

上の濃い多項式に適しているという項リストの表現を実装する手続きを定義せよ。

解答

濃い多項式だって。参考書にも記載されていたけど、次のような多項式

$x^5 + 2x^4 + 3x^2 - 2x -5$

ならば、濃い多項式としての表現はこんな感じになるかなぁ。

(polynomial x 1 2 0 3 -2 -5)

一番ケツが0次オーダーの項ね。最高次はlength手続きで求める感じ？

・・・いや、ダメだな。マイナス次元の項もありえると表現しきれなくなっちまう。

$x^5 + 2x^4 + 3x^2 - 2x - 5 + 2x^{-1}$

薄い多項式の方は現状のままでも対応できてるけど、濃い方は最高次の次元情報を持たないとだめだね。そうすると一個要素を増やしてこんな感じか？

(polynomial x             ;変数
	    5             ;最高次元
	    1 2 0 3 -2 -5 ;係数
	    )

これをもとにまずは構成子を。

;;構成子
;;（まだ内部手続き。タグはputを使って外部に公開する際に付与するのでこの段階では付与しない）
(define (make-poly-heavy variable highest-order . term-list)
  (cons variable (cons highest-order term-list)))

ただconsで連結してるだけ。次に選択子。

;;選択子（変数）
(define (variable p)
  (car p))
;;選択子（項リスト）
(define (term-list p)
  (cdr p))

変数はともかく、項リストは先頭１要素が最高次元を意味する値であることを把握しておく必要があるよなぁ。
あ、でもそれはパッケージを作るときに項リストの直前に型タグを挿入しておけばいいか。
どうせ次の問題で「薄い多項式」と「濃い多項式」を混在させたパッケージを作るから、他の手続きに関してはその時に。重そうだけど、ちょうど今日は金曜だから土日使ってエントリ作れればいいなぁ。

2010/11/23 追記

問題2.90がうまくできなかったので、問題2.89に一度戻って、完全に実装してみた。多分これをちゃんとやってからでないと、問題2.90は解けないような気がする。。

というわけで実装結果を。

;;;;========================================
;;;;濃い多項式用のパッケージ
;;;;========================================

;;依存するパッケージのロード
(use srfi-1)

;;濃い多項式パッケージ定義手続き
(define (install-polynomial-package)
  ;;;------------------------------
  ;;;前提として必要な手続き群
  ;;;
  ;;変数かどうかチェック
  (define (variable? x)
    (symbol? x))
  ;;同一変数かどうかチェック
  (define (same-variable? v1 v2)
    (and (variable? v1)
	 (variable? v2)
	 (eq? v1 v2)))
  ;;タグ付与
  (define (tag p)
    (attach-tag 'polynomial p))

  
  ;;;------------------------------
  ;;;多項式に関する手続き群
  ;;;
  ;;構成子
  (define (make-poly variable highest-order coeffs)
    (cons variable (cons highest-order coeffs)))
  ;;選択子（変数）
  (define (variable p) (car p))
  ;;選択子（項リスト）
  (define (terms p) (cdr p))


  ;;;------------------------------
  ;;;項リストに関する手続き群
  ;;;
  ;;構成子（通常）
  (define (make-terms highest-order coeffs)
    (cons highest-order coeffs))
  ;;構成子（最高次元、最低次元を指定して、項リストを再構成）
  (define (make-terms-padding high low terms)
    (let ((h (highest-order terms))
	  (l (lowest-order terms)))
      (if (or (< high h) (< l low))
	  (error "Illegal highest-order or lowest-order.")
	  (let ((h-pad (iota (- high h) 0 0))
		(l-pad (iota (- l low) 0 0)))
	    (cons high (append h-pad (coeffs terms) l-pad))))))

  ;;選択子（係数リストを取得）
  (define (coeffs t)
    (cdr t))
  ;;選択子（最高次元数を取得）
  (define (highest-order t)
    (car t))
  ;;選択子（最低次元数を取得）
  (define (lowest-order t)
    (+ (- (highest-order t)
	  (length (coeffs t)))
       1))


  ;;;------------------------------
  ;;;項リストベースの計算処理
  ;;;
  ;;加減算用の基本手続き
  (define (+/-terms +/- terms1 terms2)
    (let* ((h-order (max (highest-order terms1)
			 (highest-order terms2)))
	   (l-order (min (lowest-order terms1)
			 (lowest-order terms2)))
	   (p-terms1 (make-terms-padding h-order l-order terms1))
	   (p-terms2 (make-terms-padding h-order l-order terms2)))
      (make-terms h-order (map (lambda (c1 c2)
				 (+/- c1 c2))
			       (coeffs p-terms1)
			       (coeffs p-terms2)))))
  ;;加算
  (define (add-terms terms1 terms2)
    (+/-terms + terms1 terms2))
  ;;減算
  (define (sub-terms terms1 terms2)
    (+/-terms - terms1 terms2))
  ;;乗算
  (define (mul-terms terms1 terms2)
    (let ((high1 (highest-order terms1))
	  (high2 (highest-order terms2))
	  (coeffs1 (coeffs terms1))
	  (coeffs2 (coeffs terms2)))
      (let loop ((current-order high2)
		 (current-coeffs coeffs2)
		 (ans-terms (make-terms 0 '())))
	(cond (;乗算する側の係数が存在しなければ終了
	       (null? current-coeffs)
	       ans-terms)
	      (;係数が０なら何もせずに次の係数で再帰処理
	       (=zero? (car current-coeffs))
	       (loop (- current-order 1)
		     (cdr current-coeffs)
		     ans-terms))
	      (;係数が０以外ならば係数及び次数を計算して項リストを累計し、再帰処理
	       else
	       (loop (- current-order 1)
		     (cdr current-coeffs)
		     (add-terms ans-terms
				(make-terms (+ high1 current-order)
					    (map (lambda (x)
						   (* x (car current-coeffs)))
						 coeffs1)))))))))
  ;;;------------------------------
  ;;;濃い多項式ベースの計算処理
  ;;;
  ;;汎用演算手続き
  (define (*-poly *-terms error-message p1 p2)
    (if (same-variable? (variable p1)
			(variable p2))
	(let ((ans-terms (*-terms (terms p1)
				  (terms p2))))
	  (make-poly (variable p1)
		     (highest-order ans-terms)
		     (coeffs ans-terms)))
	(error error-message
	       (list p1 p2))))
  ;;加算
  (define (add-poly p1 p2)
    (*-poly add-terms
	    "Polys not in same var -- ADD-POLY"
	    p1 p2))
  ;;減算
  (define (sub-poly p1 p2)
    (*-poly sub-terms
	    "Polys not in same var -- SUB-POLY"
	    p1 p2))
  ;;乗算
  (define (mul-poly p1 p2)
    (*-poly mul-terms
	    "Polys not in same var -- MUL-POLY"
	    p1 p2))
  ;;ゼロ確認
  (define (=zero-poly? p)
    (let* ((ts (terms p))
	   (cs (coeffs ts))
	   (filterd (filter-map (lambda (x)
				  (not (=zero? x)))
				cs)))
      (null? filterd)))


  ;;------------------------------
  ;;公開手続き
  ;;
  (put 'add '(polynomial polynomial)
       (lambda (p1 p2)
	 (tag (add-poly (contents p1) (contents p2)))))
  (put 'sub '(polynomial polynomial)
       (lambda (p1 p2)
	 (tag (sub-poly (contents p1) (contents p2)))))
  (put 'mul '(polynomial polynomial)
       (lambda (p1 p2)
	 (tag (mul-poly (contents p1) (contents p2)))))
  (put 'make 'polynomial
       (lambda (var highest-order coeffs)
	 (tag (make-poly var highest-order coeffs))))
  (put '=zero? '(polynomial)
       (lambda (x) (=zero-poly? (contents x))))
  'done)
(install-polynomial-package)

;;公開用
(define (make-polynomial var highest-order coeffs)
    ((get 'make 'polynomial) var highest-order coeffs))

で、テストコードも掲載。

;==============================
;濃い多項式演算パッケージのテスト
;==============================
(define (calculate-polynomial-heavy-test)
  ;------------------------------
  ;構成子のテスト
  (define (make-polynomial-test)
    ;単体テスト手続き
    (define (print-test answer var highest-order coeffs)
      (let ((p (make-polynomial var highest-order coeffs)))
    	(if (equal? p answer)
    	    (print "[ O K ] (print-test-heavy "
    		   var " " highest-order " " coeffs ")")
    	    (begin
    	      (print "[ERROR] (print-test-heavy "
    		     var " " highest-order " " coeffs ")")
    	      (print " result:" p)
    	      (print " answer:" answer)))))

    (print "<<構成子のテスト>>")
    (print-test '(polynomial x 5 1 2 0 4 -2 1)
		'x 5 '(1 2 0 4 -2 1))
    (print-test '(polynomial x 3 1 -1 3 2 -4)
		'x 3 '(1 -1 3 2 -4))
    )


  ;------------------------------
  ;ゼロ確認テスト
  (define (=zero?-test)
    ;単体テスト手続き
    (define (print-test answer p)
      (let ((result (=zero? p)))
  	(if (equal? result answer)
  	    (print "[ O K ] " p)
  	    (begin
  	      (print "[ERROR] " p)
  	      (print " result:" result)
  	      (print " answer:" answer)))))

    (print "<<ゼロ確認>>")
    (print-test #f (make-polynomial 'x 3 '(1 1 1 1)))
    (print-test #f (make-polynomial 'x 3 '(1 1 1 0)))
    (print-test #f (make-polynomial 'x 3 '(1 1 0 0)))
    (print-test #f (make-polynomial 'x 3 '(1 0 0 0)))
    (print-test #t (make-polynomial 'x 3 '(0 0 0 0)))
    (print-test #t (make-polynomial 'x 3 '(0 (rational 0 . 3) 0 0 0)))
    (print-test #t (make-polynomial 'x 3 '(0
					   (rational 0 . 3)
					   0
					   (complex rectangular 0 . 0))))
    )

  ;------------------------------
  ;加算
  (define (add-poly-test)
    ;単体テスト手続き
    (define (print-test answer p1 p2)
      (let* ((result (add p1 p2)))
  	(if (equal? result answer)
  	    (print "[ O K ] " answer)
  	    (begin
  	      (print "[ERROR] ")
  	      (print " p1    :" p1)
  	      (print " p2    :" p2)
  	      (print " result:" result)
  	      (print " answer:" answer)))))

    (print "<<加算>>")
    (print-test (make-polynomial 'x 5 '(3 0 1 1 3 2 -4))
		(make-polynomial 'x 5 '(3 0 0 2))
		(make-polynomial 'x 3 '(1 -1 3 2 -4))))

  ;------------------------------
  ;減算
  (define (sub-poly-test)
    ;単体テスト手続き
    (define (print-test answer p1 p2)
      (let* ((result (sub p1 p2)))
  	(if (equal? result answer)
  	    (print "[ O K ] " answer)
  	    (begin
  	      (print "[ERROR]")
  	      (print " p1    :" p1)
  	      (print " p2    :" p2)
  	      (print " result:" result)
  	      (print " answer:" answer)))))

    (print "<<減算>>")
    (print-test (make-polynomial 'x 5 '(3 0 -1 3 -3 -2 4))
		(make-polynomial 'x 5 '(3 0 0 2))
		(make-polynomial 'x 3 '(1 -1 3 2 -4)))
    )


  ;------------------------------
  ;乗算
  (define (mul-poly-test)
    ;単体テスト手続き
    (define (print-test answer p1 p2)
      (let* ((result (mul p1 p2)))
  	(if (equal? result answer)
  	    (print "[ O K ] " answer)
  	    (begin
  	      (print "[ERROR]")
  	      (print " p1    :" p1)
  	      (print " p2    :" p2)
  	      (print " result:" result)
  	      (print " answer:" answer)))))

    (print "<<乗算>>")
    (print-test (make-polynomial 'x 8 '(3 -3 9 8 -14 6 4 -8))
		(make-polynomial 'x 5 '(3 0 0 2))
		(make-polynomial 'x 3 '(1 -1 3 2 -4)))
    )


  (make-polynomial-test)
  (=zero?-test)
  (add-poly-test)
  (sub-poly-test)
  (mul-poly-test)
)

では確認。（つってもすんごい簡単なケースしか試してない・・・）



gosh> (calculate-polynomial-heavy-test)<<構成子のテスト>>

[ O K ] (print-test-heavy x 5 (1 2 0 4 -2 1))

[ O K ] (print-test-heavy x 3 (1 -1 3 2 -4))<<ゼロ確認>>

[ O K ] (polynomial x 3 1 1 1 1)

[ O K ] (polynomial x 3 1 1 1 0)

[ O K ] (polynomial x 3 1 1 0 0)

[ O K ] (polynomial x 3 1 0 0 0)

[ O K ] (polynomial x 3 0 0 0 0)

[ O K ] (polynomial x 3 0 (rational 0 . 3) 0 0 0)

[ O K ] (polynomial x 3 0 (rational 0 . 3) 0 (complex rectangular 0 . 0))<<加算>>

[ O K ] (polynomial x 5 3 0 1 1 3 2 -4)<<減算>>

[ O K ] (polynomial x 5 3 0 -1 3 -3 -2 4)<<乗算>>

[ O K ] (polynomial x 8 3 -3 9 8 -14 6 4 -8)

#

gosh>

よし、おっけーということにしておこう。
これでやっと濃い多項式と薄い多項式の表現混在の問題の入り口に立てた。