SICP 問題2.90（濃い多項式と薄い多項式をマージ）

や、やっと終わった。。。

結局、複素数の表現の違いを参考にしようとしたらどこでバグが入り込んだみたいで動かず。
どこで表現の違いを吸収してるか思い出せないので、参考にするのは諦めた。
今回の「薄い多項式」と「濃い多項式」は、標準の表現を「薄い多項式」として扱うことにした。
で、マージした結果を改めて再掲！

問題

薄い多項式と濃い多項式の両方に効率的な多項式システムが欲しいとしよう。
一つの方法はシステムに両方の項リストの表現を認めることである。この状況は2.4節の、直交表現と極表現を認めた複素数の例に似ている。このためには異なる項リストの型を区別し、項リスト演算を汎用にしなければならない。この一般化を実装するように多項式システムを再設計せよ。これは局所的変更ではなく、大仕事である。

解答

問題2.89を改めて解き直して、それと問題2.88を元に濃い多項式と薄い多項式のマージを行った。
構成としてはこんな感じ。

calculate-polynomial.scm	共通の呼び出しインタフェースを定義。 (polynomial light/heavy 変数シンボル 多項式表現) のオブジェクトを扱う感じ。
calculate-polynomial-light.scm	薄い多項式を扱う手続き群を定義。 (light 変数シンボル 項 ...) のオブジェクトを扱う感じ。
calculate-polynomial-heavy.scm	濃い多項式を扱う手続き群を定義。 (heavy 変数シンボル 最高次元数 係数 ...) のオブジェクトを扱う感じ。

ここら辺の、「どのレベルのオブジェクトを扱うか」というのを意識してないとスンゴイ混乱するので注意。
では実装を掲載。例によって追記、変更してある箇所はコメントで説明してある。

calculate-polynomial.scm

(use srfi-1)
(load "./calculate-polynomial-light.scm")
(load "./calculate-polynomial-heavy.scm")

(define (install-polynomial-package)
  (define (tag p)
    (attach-tag 'polynomial p))
  (define (variable? x)
    (symbol? x))
  (define (same-variable? v1 v2)
    (and (variable? v1)
  	 (variable? v2)
  	 (eq? v1 v2)))

  (define (variable p)
    (car p))

  ;;------------------------------
  ;;汎用演算手続き
  (define (*-poly proc-symbol proc-name polynomial1 polynomial2)
    (let* ((poly1 (contents polynomial1))
	   (poly2 (contents polynomial2))
	   (tag1 (type-tag poly1))
	   (tag2 (type-tag poly2))
	   (p1 (contents poly1))
	   (p2 (contents poly2)))
      (cond ((not (same-variable? (variable p1) (variable p2)))
	     (error "Polys not in same var -- " proc-name
		    (list polynomial1 polynomial2)))
	    ((not (eq? tag1 tag2))
	     ((get proc-symbol '(light light))        ;「薄い多項式」を標準表現として、
	      (contents ((get 'coerce tag1) poly1))   ;poly1を強制型変換
	      (contents ((get 'coerce tag2) poly2)))) ;poly2を強制型変換
	    (else
	     ((get proc-symbol (list tag1 tag2)) p1 p2)))))
  ;;------------------------------

  (define (=zero-poly? poly)
    ((get '=zero-poly? (type-tag poly)) (contents poly)))


  (put 'add '(polynomial polynomial)
       (lambda (polynomial1 polynomial2)
  	 (tag (*-poly 'add-poly "ADD-POLY" polynomial1 polynomial2))))
  (put 'sub '(polynomial polynomial)
       (lambda (polynomial1 polynomial2)
  	 (tag (*-poly 'sub-poly "SUB-POLY" polynomial1 polynomial2))))
  (put 'mul '(polynomial polynomial)
       (lambda (polynomial1 polynomial2)
  	 (tag (*-poly 'mul-poly "MUL-POLY" polynomial1 polynomial2))))
  (put '=zero? '(polynomial)
       (lambda (polynomial)
	 (=zero-poly? (contents polynomial))))

  (put 'make-polynomial-light 'polynomial
       (lambda (var terms)
  	 (tag ((get 'make-polynomial-light 'light) var terms))))
  (put 'make-polynomial-heavy 'polynomial
       (lambda (var highest-order coeffs)
  	 (tag ((get 'make-polynomial-heavy 'heavy)
	       var
	       highest-order
	       coeffs))))
  'done)
(install-polynomial-package)

(define (make-polynomial-light var terms)
  ((get 'make-polynomial-light 'polynomial) var terms))
(define (make-polynomial-heavy var highest-order coeffs)
  ((get 'make-polynomial-heavy 'polynomial) var highest-order coeffs))

calculate-polynomial-light.scm

(use srfi-1)

(define (install-polynomial-light-package)
  (define (tag p)
    (attach-tag 'light p))
  (define (variable? x) (symbol? x))
  (define (same-variable? v1 v2)
    (and (variable? v1)
	 (variable? v2)
	 (eq? v1 v2)))
  (define (make-term order coeff) (list order coeff))
  (define (order term) (car term))
  (define (coeff term) (cadr term))
  (define (first-term term-list) (car term-list))
  (define (rest-terms term-list) (cdr term-list))
  (define (empty-termlist? term-list) (null? term-list))
  (define (the-empty-termlist) '())
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L)
	(the-empty-termlist)
	(let ((t2 (first-term L)))
	  (adjoin-term
	   (make-term (+ (order t1) (order t2))
		      (mul (coeff t1) (coeff t2)))
	   (mul-term-by-all-terms t1 (rest-terms L))))))
  (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-term L1))
		 (t2 (first-term L2)))
	     (cond ((> (order t1) (order t2))
		    (adjoin-term
		     t1 (add-terms (rest-terms L1) L2)))
		   ((< (order t1) (order t2))
		    (adjoin-term
		     t2 (add-terms L1 (rest-terms L2))))
		   (else
		    (adjoin-term
		     (make-term (order t1)
				(add (coeff t1) (coeff t2)))
		     (add-terms (rest-terms L1)
				(rest-terms L2)))))))))
  (define (sub-terms L1 L2)
    (define (reverse-signs terms)
      (map (lambda (term)
	     (make-term (order term) (* -1 (coeff term))))
	   terms))
    (add-terms L1
	       (reverse-signs L2)))

  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
	(the-empty-termlist)
	(add-terms (mul-term-by-all-terms (first-term L1) L2)
		   (mul-terms (rest-terms L1) L2))))

  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))

  ;;------------------------------
  ;;汎用演算手続き
  (define (*-poly make-proc calc-proc p1 p2)
    (if (same-variable? (variable p1) (variable p2))
	(make-proc (variable p1)
		   (calc-proc (term-list p1)
			      (term-list p2)))
	(error "Polys not in same var -- "
	       (x->string proc)
	       (list p1 p2))))
  ;;------------------------------


  ;;------------------------------
  ;;汎用多項式生成手続き
  (define (*-make-poly var result)
    (make-poly var result))
  ;;------------------------------


  ;;------------------------------
  ;;汎用多項式生成手続きを使用するように変更
  (define (add-poly p1 p2)
    (*-poly *-make-poly add-terms p1 p2))
  (define (sub-poly p1 p2)
    (*-poly *-make-poly sub-terms p1 p2))
  (define (mul-poly p1 p2)
    (*-poly *-make-poly mul-terms p1 p2))
  ;;------------------------------


  (define (=zero-poly? polynomial)
    (define (coeff-list term-list)
      (filter-map (lambda (x)
		    (not (=zero? (coeff x))))
		  term-list))
    (let ((terms (term-list polynomial)))
      (cond ((empty-termlist? terms)
	     #t)
	    ((null? (coeff-list terms))
	     #t)
	    (else
	     #f))))

  (put 'add-poly '(light light)
       (lambda (p1 p2)
	 (tag (add-poly p1 p2))))
  (put 'sub-poly '(light light)
       (lambda (p1 p2)
	 (tag (sub-poly p1 p2))))
  (put 'mul-poly '(light light)
       (lambda (p1 p2)
	 (tag (mul-poly p1 p2))))
  (put '=zero-poly? 'light
       (lambda (p)
	 (=zero-poly? p)))
  (put 'make-polynomial-light 'light
       (lambda (var terms)
	 (tag (make-poly var terms))))

  ;;------------------------------
  ;変換（共通表現として「薄い多項式」を返却。）
  (put 'coerce 'light
       (lambda (poly)
	 poly))
  ;;------------------------------

  'done)
(install-polynomial-light-package)

calculate-polynomial-heavy.scm

(use srfi-1)

(define (install-polynomial-heavy-package)
  (define (variable? x)
    (symbol? x))
  (define (same-variable? v1 v2)
    (and (variable? v1)
	 (variable? v2)
	 (eq? v1 v2)))
  (define (tag p)
    (attach-tag 'heavy 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 the-empty-termlist (make-terms 0 '()))

  (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 (regulate-terms t)
    (define (cut-zero number-list)
      (let loop ((count 0)
		 (numbers number-list))
	(if (=zero? (car numbers))
	    (loop (+ 1 count) (cdr numbers))
	    (list count numbers))))
    (let* ((h-order (highest-order t))
	   (coeff-list (coeffs t))
	   (result1 (cut-zero coeff-list))
	   (h-order1 (- h-order (car result1)))
	   (coeff-list1 (cadr result1))
	   (coeff-list2 (reverse (cadr (cut-zero (reverse coeff-list1))))))
      (make-terms h-order1 coeff-list2)))
      


  (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 make-proc calc-proc p1 p2)
    (if (same-variable? (variable p1)
			(variable p2))
	(make-proc (variable p1)
		   (calc-proc (terms p1)
			      (terms p2)))
	(error "Polys not in same var -- "
	       (x->string calc-proc)
	       (list p1 p2))))
  (define (*-make-poly var result)
    (make-poly var
	       (highest-order result)
	       (coeffs result)))
  (define (add-poly p1 p2)
    (*-poly *-make-poly add-terms p1 p2))
  (define (sub-poly p1 p2)
    (*-poly *-make-poly sub-terms p1 p2))
  ;;乗算
  (define (mul-poly p1 p2)
    (*-poly *-make-poly mul-terms 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-poly '(heavy heavy)
       (lambda (p1 p2)
	 (tag (add-poly p1 p2))))
  (put 'sub-poly '(heavy heavy)
       (lambda (p1 p2)
	 (tag (sub-poly p1 p2))))
  (put 'mul-poly '(heavy heavy)
       (lambda (p1 p2)
	 (tag (mul-poly p1 p2))))
  (put 'div-poly '(heavy heavy)
       (lambda (p1 p2)
	 (map tag (div-poly p1 p2))))
  (put '=zero-poly? 'heavy
       (lambda (p)
	 (=zero-poly? p)))
  (put 'make-polynomial-heavy 'heavy
       (lambda (var highest-order coeffs)
	 (tag (make-poly var highest-order coeffs))))

  ;;------------------------------
  ;変換（共通表現として「薄い多項式」を返却。）
  (put 'coerce 'heavy
       (lambda (poly)
	 (let* ((p (contents poly))
		(var (variable p))
		(term-list (terms p))
		(h-order (highest-order term-list))
		(coeff-list (coeffs term-list))
		(orders (iota (length coeff-list)
			      h-order
			      -1)))
	   ((get 'make-polynomial-light 'light)
	    var
	    (map (lambda (order coeff)
		   (list order coeff))
		 orders
		 coeff-list)))))
  ;;------------------------------

  'done)
(install-polynomial-heavy-package)

calculate-polynomial-test.scm

テストも作ったので一緒に掲載。

(define (calculate-polynomial-test)
  (define (make-polynomial-*-test)
    (define (print-test-light answer var terms)
      (let ((p (make-polynomial-light var terms)))
    	(if (equal? p answer)
    	    (print "[ O K ] (print-test-light " var " " terms ")")
    	    (begin
    	      (print "[ERROR] (print-test-light " var " " terms ")")
    	      (print " result:" p)
    	      (print " answer:" answer)))))
    (define (print-test-heavy answer var highest-order coeffs)
      (let ((p (make-polynomial-heavy 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-light '(polynomial light x (3 2) (2 1) (0 4))
    		      'x '((3 2) (2 1) (0 4)))
    (print-test-heavy '(polynomial heavy x 5 1 2 0 4 -2 1)
    		      'x 5 '(1 2 0 4 -2 1))
    )


  (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-light 'x '((3 1) (2 1) (1 1) (0 1))))
    (print-test #f (make-polynomial-light 'x '((3 1) (2 1) (1 1) (0 0))))
    (print-test #f (make-polynomial-light 'x '((3 1) (2 1) (1 0) (0 0))))
    (print-test #f (make-polynomial-light 'x '((3 1) (2 0) (1 0) (0 0))))
    (print-test #t (make-polynomial-light 'x '((3 0) (2 0) (1 0) (0 0))))

    (print-test #f (make-polynomial-heavy 'x 3 '(1 1 1 1)))
    (print-test #f (make-polynomial-heavy 'x 3 '(1 1 1 0)))
    (print-test #f (make-polynomial-heavy 'x 3 '(1 1 0 0)))
    (print-test #f (make-polynomial-heavy 'x 3 '(1 0 0 0)))
    (print-test #t (make-polynomial-heavy 'x 3 '(0 0 0 0))))


  (define (add-test)
    (define (print-test answer p1 p2)
      (let ((result (add p1 p2)))
  	(if (equal? result answer)
  	    (print "[ O K ] " result)
  	    (begin
  	      (print "[ERROR] ")
  	      (print " p1    :" p1)
  	      (print " p2    :" p2)
  	      (print " result:" result)
  	      (print " answer:" answer)))))

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


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

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

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

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

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

表現の混在パターンのテストを追加してみた。では実験。

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

[ O K ] (print-test-light x ((3 2) (2 1) (0 4)))

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

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

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

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

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

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

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

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

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

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

[ O K ] (polynomial heavy x 3 0 0 0 0)<<加算>>

[ O K ] (polynomial light x (3 1) (2 1) (1 -2) (0 1))

[ O K ] (polynomial heavy x 3 1 1 -2 1)

[ O K ] (polynomial light x (3 1) (2 1) (1 -2) (0 1))

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

[ O K ] (polynomial light x (3 -1) (2 3) (1 -4) (0 1))

[ O K ] (polynomial heavy x 3 -1 3 -4 1)

[ O K ] (polynomial light x (3 -1) (2 3) (1 -4) (0 1))

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

[ O K ] (polynomial light x (5 2) (4 -5) (3 6) (2 -4) (1 1))

[ O K ] (polynomial heavy x 5 2 -5 6 -4 1)

[ O K ] (polynomial light x (5 2) (4 -5) (3 6) (2 -4) (1 1))

[ O K ] (polynomial light x (5 2) (4 -5) (3 6) (2 -4) (1 1))

#

gosh> 

よしよし、OKだ〜。