SICP 問題2.88（多項式の減算処理）

問題

多項式システムを、減算ができるよう拡張せよ。（ヒント：汎用符号反転演算を定義するのが有用と思うであろう。）

解答

やっぱり減算も定義するんじゃ〜ん。てことは除算も定義すんのかな。面倒くさそうだな。

calculate-system.scm

index手続きでうまく動作しない箇所があったから修正した気がしたんだけど、どこ修正したか分からんなった。。比較するのが面倒なので、修正後のコードを再掲載。

(load "./sicp-hashtable.scm")
(load "./calculate-scheme-number.scm")
(load "./calculate-rational.scm")
(load "./calculate-real.scm")
(load "./calculate-complex.scm")
(load "./calculate-polynomial.scm")


(define (apply-generic op . args)
  (let* ((type-tags (map type-tag args))
	 (proc (get op type-tags)))
    (if proc
	(drop (apply proc args))
	(let* ((coerced-list (coerce-higher-type-list args))
	       (type-tags (map type-tag coerced-list))
	       (proc (get op type-tags)))
	  (if proc
	      (drop (apply proc coerced-list))
	      (error
	       "No method for these types -- APPLY-GENERIC"
	       (list op type-tags)))))))

(define (coerce-higher-type-list args)
  (define (coerce-to x tag)
    (let loop ((data x))
      (if (eq? (type-tag data) tag)
	  data
	  (let ((proc (get 'raise (type-tag data))))
	    (if proc
		(loop (proc data))
		data)))))
  (let* ((tags (map type-tag args))
	 (highest (fold higher? (car tags) tags)))
    (map (lambda (x)
	   (coerce-to x highest))
	 args)))


(define (higher? tag0 tag1)
  (define tag-tower '(scheme-number rational real complex))

  (define (index tag)
    (let ((order (member tag tag-tower)))
      (if (eq? #f order)
	  (error "No match type -- HIGHER~INDEX?" tag)
	  (- (length tag-tower) (length order)))))

  (let ((index0 (index tag0))
	(index1 (index tag1)))
    (if (< index0 index1)
	tag1
	tag0)))

(define (drop x)
  (define (drop-1 x)
    (guard (exc
	    ((<error> exc)
	     #f))
      (let* ((down ((get 'project (type-tag x)) x))
	     (y ((get 'raise (type-tag down)) down)))
	(if (equ? x y)
	    down
	    #f))))
  (let loop ((src x)
	     (next (drop-1 x)))
    (if next
	(loop next (drop-1 next))
	src)))


(define (attach-tag type-tag contents)
  (if (eq? type-tag 'scheme-number)
      contents
      (cons type-tag contents)))

(define (type-tag datum)
  (cond ((pair? datum)
	 (car datum))
	((number? datum)
	 'scheme-number)
	(else
	 (error "Bad tagged datum -- TYPE-TAG" datum))))

(define (contents datum)
  (cond ((pair? datum)
	 (cdr datum))
	((number? datum)
	 datum)))

(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (=zero? x) (apply-generic '=zero? x))
 

で、この問題の核となるコードを掲載。追加した箇所にコメントを記入してあります。

(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 (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 (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 (add-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
	(make-poly (variable p1)
		   (add-terms (term-list p1)
			      (term-list p2)))
	(error "Polys not in same var -- ADD-POLY"
	       (list p1 p2))))

  ;------------------------------
  ;減算処理を定義
  (define (sub-poly p1 p2)
    ;係数をプラスマイナス反転する手続き
    (define (reverse-signs terms)
      (map (lambda (term)
	     (make-term (order term) (* -1 (coeff term))))
	   terms))

    ;メイン処理
    (if (same-variable? (variable p1) (variable p2))
	(make-poly (variable p1)
		   (add-terms (term-list p1)
			      (reverse-signs (term-list p2))))
	(error "Polys not in same var -- ADD-POLY"
	       (list p1 p2))))
  ;------------------------------

  (define (mul-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
	(make-poly (variable p1)
		   (mul-terms (term-list p1)
			      (term-list p2)))
	(error "Polys not in same var -- MUL-POLY"
	       (list 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))))
  (define (tag p)
    (attach-tag 'polynomial p))

  (put 'add '(polynomial polynomial)
       (lambda (p1 p2) (tag (add-poly p1 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 p1 p2))))
  (put 'make 'polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  (put '=zero? '(polynomial)
       (lambda (x) (=zero-poly? (contents x))))
  'done)
(install-polynomial-package)


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

じゃ、テストを定義しよう。

(define (test-sub)
  (define (print-test p1 p2 answer)
    (let ((result (sub p1 p2)))
      (print (equal? result answer) " : p1     = " p1)
      (print "   : p2     = " p2)
      (print "   : result = " result)
      (print "   : answer = " answer)))

  (print-test '(polynomial x (2 1) (1 4) (0 2))
	      '(polynomial x (2 2) (1 -2) (0 5))
	      '(polynomial x (2 -1) (1 6) (0 -3)))
  (print-test '(polynomial x (3 1) (1 4) (0 2))
	      '(polynomial x (4 2) (2 -2)(0 -3))
	      '(polynomial x (4 -2) (3 1) (2 2) (1 4) (0 5)))
  ;2乗の項、結果の分母にマイナスが付加されているけど、これは有理数の減算処理に問題がある。
  ;数学的には問題ないからかんべんして。
  (print-test '(polynomial x (2 (rational 7 . 5)) (1 4) (0 2))
	      '(polynomial x (2 2) (1 -2) (0 5))
	      '(polynomial x (2 (rational 3 . -5)) (1 6) (0 -3)))
)

テスト数が少ないけど、まぁいいや。じゃ、実験。

gosh> (test-sub)

#t : p1     = (polynomial x (2 1) (1 4) (0 2))

   : p2     = (polynomial x (2 2) (1 -2) (0 5))

   : result = (polynomial x (2 -1) (1 6) (0 -3))

   : answer = (polynomial x (2 -1) (1 6) (0 -3))

#t : p1     = (polynomial x (3 1) (1 4) (0 2))

   : p2     = (polynomial x (4 2) (2 -2) (0 -3))

   : result = (polynomial x (4 -2) (3 1) (2 2) (1 4) (0 5))

   : answer = (polynomial x (4 -2) (3 1) (2 2) (1 4) (0 5))

#t : p1     = (polynomial x (2 (rational 7 . 5)) (1 4) (0 2))

   : p2     = (polynomial x (2 2) (1 -2) (0 5))

   : result = (polynomial x (2 (rational 3 . -5)) (1 6) (0 -3))

   : answer = (polynomial x (2 (rational 3 . -5)) (1 6) (0 -3))

#

gosh> 

テスト手続きの内部にもコメントしてあるけど、有理数を係数にした場合の減算処理で、結果の係数の符号が分母に付与されちまう。でもこれは多項式の減算の問題なので、目をつぶります。。もし今後これが問題になるケースがでてきたら修正します。（そんなケースがでてこないことを祈る。。）