SICP 問題2.87（多項式の再帰を含めた=zero?手続きを実装）

問題

汎用算術演算パッケージに多項式用の=zero?を設定せよ。これはadjoin-termが、その係数自体がまた多項式である多項式に対しても働くことを可能にする。

解答

多項式のリストは、(([次数] [係数]) ([次数] [係数]) ...) という形をしているので、各要素の係数が全て０、またはリスト自体がnullであればそれをゼロとみなすことができると考えれば、こんな感じになった。
ちなみにまたものすごくたくさんバグを発見したので全部修正した。なので全パッケージを再掲しとく。（過去のエントリ・・・どうしよう。。）

calculate-system.scm

(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))

calculate-scheme-number.scm

(define (install-scheme-number-package)
  (define (tag x)
    (attach-tag 'scheme-number x))
  (put 'add '(scheme-number scheme-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(scheme-number scheme-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(scheme-number scheme-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(scheme-number scheme-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'scheme-number
       (lambda (x) (tag x)))
  (put 'equ? '(scheme-number scheme-number)
       (lambda (x y) (eq? x y)))
  (put '=zero? '(scheme-number)
       (lambda (x) (eq? 0 (contents x))))
  (put 'raise 'scheme-number
       (lambda (x)
	 (make-rational x 1)))
  'done)
(install-scheme-number-package)

(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))

calculate-rational.scm

(define (install-rational-package)
  (define (gcd a b)
    (if (= b 0)
	a
	(gcd b (remainder a b))))
  (define (numer x) (car x))
  (define (denom x) (cdr x))
  (define (make-rat n d)
    (let ((g (gcd n d)))
      (cons (/ n g) (/ d g))))
  (define (add-rat x y)
    (make-rat (+ (* (numer x) (denom y))
		 (* (numer y) (denom x)))
	      (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (numer x) (denom y))
		 (* (numer y) (denom x)))
	      (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (numer x) (numer y))
	      (* (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (* (numer x) (denom y))
	      (* (denom x) (numer y))))
  (define (tag x)
    (attach-tag 'rational x))

  (put 'add '(rational rational)
       (lambda (x y) (tag (add-rat (contents x) (contents y)))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat (contents x) (contents y)))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat (contents x) (contents y)))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat (contents x) (contents y)))))
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  (put 'equ? '(rational rational)
       (lambda (x y) (equal? x y)))
  (put '=zero? '(rational)
       (lambda (x)
	 (eq? 0 (numer (contents x)))))
  (put 'raise 'rational
       (lambda (x)
	 (make-real (/ (numer (contents x)) (denom (contents x))))))
  (put 'project 'rational
       (lambda (x)
	 (round (/ (numer (contents x)) (denom (contents x))))))
  'done)
(install-rational-package)

(define (make-rational n d)
  ((get 'make 'rational) n d))

calculate-real.scm

(define (install-real-package)
  (define (project x)
    (define (rational->x value)
      (let ((lis (string-split value "/")))
	(if (eq? 2 (length lis))
	    (let ((n (string->number (car lis)))
		  (d (string->number (cadr lis))))
	      (make-rational n d))
	    #f)))
    (define (decimal->x value)
      (let ((lis (string-split value ".")))
	(if (eq? 2 (length lis))
	    (let ((upper (string->number (car lis)))
		  (lower (string->number (cadr lis)))
		  (denom (expt 10 (string-length (cadr lis)))))
	      (make-rational (+ (* upper denom) lower) denom))
	    #f)))
    (let* ((value (number->string (contents x)))
	   (ans0 (rational->x value))
	   (ans1 (decimal->x value)))
      (cond (ans0 ans0)
	    (ans1 ans1)
	    (else 
	     (make-rational (contents x) 1)))))

  (define (tag x)
    (attach-tag 'real x))
  (put 'add '(real real)
       (lambda (x y) (tag (+ (contents x) (contents y)))))
  (put 'sub '(real real)
       (lambda (x y) (tag (- (contents x) (contents y)))))
  (put 'mul '(real real)
       (lambda (x y) (tag (* (contents x) (contents y)))))
  (put 'div '(real real)
       (lambda (x y) (tag (/ (contents x) (contents y)))))
  (put 'make 'real
       (lambda (x) (tag x)))
  (put 'equ? '(real real)
       (lambda (x y) (equal? (contents x) (contents y))))
  (put '=zero? '(real)
       (lambda (x) (eq? 0 (contents x))))
  (put 'raise 'real
       (lambda (x)
	 (make-complex-from-real-imag (contents x) 0)))
  (put 'project 'real project)
  'done)
(install-real-package)

(define (make-real n)
  ((get 'make 'real) n))

calculate-complex.scm

(load "./calculate-complex-rectangular.scm")
(load "./calculate-complex-polar.scm")

(define (install-complex-package)
  (define (make-from-real-imag x y)
    ((get 'make-from-real-imag 'rectangular) x y))
  (define (make-from-mag-ang r a)
    ((get 'make-from-mag-ang 'polar) r a))
  (define (add-complex z1 z2)
    (make-from-real-imag (+ (real-part z1) (real-part z2))
			 (+ (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (- (real-part z1) (real-part z2))
			 (- (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (* (magunitude z1) (magunitude z2))
		       (+ (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (magunitude z1) (magunitude z2))
		       (- (angle z1) (angle z2))))
  (define (real-part z)
    (apply-generic 'real-part (contents z)))
  (define (imag-part z)
    (apply-generic 'imag-part (contents z)))
  (define (magnitude z)
    (apply-generic 'magnitude (contents z)))
  (define (angle z)
    (apply-generic 'angle (contents z)))
  (define (tag z) (attach-tag 'complex z))
  
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
  (put 'sub '(complex complex)
       (lambda (z1 z2) (tag (sub-complex z1 z2))))
  (put 'mul '(complex complex)
       (lambda (z1 z2) (tag (mul-complex z1 z2))))
  (put 'div '(complex complex)
       (lambda (z1 z2) (tag (div-complex z1 z2))))
  (put 'make-from-real-imag 'complex
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'complex
       (lambda (r a) (tag (make-from-mag-ang r a))))
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  (put 'equ? '(complex complex)
       (lambda (x y) (equal? x y)))
  (put '=zero? '(complex)
       (lambda (x)
	 ((get '=zero? (type-tag (contents x))) (contents x))))
  (put 'project 'complex
       (lambda (x)
	 (make-real (real-part x))))
  'done)
(install-complex-package)

(define (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
  ((get 'make-from-mag-ang 'complex) r a))

(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))

calculate-complex-rectangular.scm

(define (install-rectangular-package)
  (define (square x) (* x x))
  (define (real-part z) (car (contents z)))
  (define (imag-part z) (cdr (contents z)))
  (define (magnitude z)
    (sqrt (+ (square (real-part (contents z)))
	     (square (imag-part (contents z))))))
  (define (angle z)
    (atan (imag-part (contents z))
	  (real-part (contents z))))

  (define (make-from-real-imag x y)
    (cons x y))
  (define (make-from-mag-ang r a)
    (cons (* r (cos a)) (* r (sin a))))
  (define (tag x)
    (attach-tag 'rectangular x))

  (put 'real-part '(rectangular) real-part)
  (put 'imag-part '(rectangular) imag-part)
  (put 'magnitude '(rectangular) magnitude)
  (put 'angle '(rectangular) angle)
  (put 'make-from-real-imag 'rectangular
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'rectangular
       (lambda (r a) (tag (make-from-mag-ang r a))))
  (put 'equ? '(rectangular rectangular)
       (lambda (x y) (equal? x y)))
  (put '=zero? 'rectangular
       (lambda (x)
	 (and (eq? 0 (real-part x))
	      (eq? 0 (imag-part x)))))
  'done)
(install-rectangular-package)

calculate-complex-polar.scm

(define (install-polar-package)
  (define (square x) (* x x))

  (define (magnitude z) (car (contents z)))
  (define (angle z) (cdr (contents z)))
  (define (real-part z)
    (* (magnitude (contents z))
       (cos (angle (contents z)))))
  (define (imag-part z)
    (* (magnitude (contents z))
       (sin (angle (contents z)))))

  (define (make-from-mag-ang r a)
    (cons r a))
  (define (make-from-real-imag x y)
    (cons (sqrt (+ (square x) (square y)))
	  (atan y x)))
  (define (tag x) (attach-tag 'polar x))

  (put 'real-part '(polar) real-part)
  (put 'imag-part '(polar) imag-part)
  (put 'magnitude '(polar) magnitude)
  (put 'angle '(polar) angle)
  (put 'make-from-real-imag 'polar
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'polar
       (lambda (r a) (tag (make-from-mag-ang r a))))
  (put 'equ? '(polar polar)
       (lambda (x y) (equal? x y)))
  (put '=zero? 'polar
       (lambda (x)
	 (eq? 0 (magnitude x))))
  'done)
(install-polar-package)

calculate-polynomial.scm

で、今回の主役。

(use srfi-1) ;filter-mapの為
(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 (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)
    ;多項式の係数だけを=zero?チェックする手続き
    (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 '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-=zero?)
  (define (print-test polynomial answer)
    (let ((result (=zero? polynomial)))
      (print (eq? result answer) " : " polynomial)
      (print "    result = " result)
      (print "    answer = " answer)))

  (print-test '(polynomial x (2 1) (1 4) (0 2)) #f)
  (print-test '(polynomial x (2 0) (1 0) (0 2)) #f)
  (print-test '(polynomial x (2 0) (1 0) (0 0)) #t)
  (print-test '(polynomial x (2 0) ((rational 1 . 3) 0) (0 2)) #f)
  (print-test '(polynomial x (2 0) (0 (rational 1 . 3)) (0 2)) #f)
  (print-test '(polynomial x (2 0) (0 (rational 0 . 3)) (0 0)) #f)
  (print-test '(polynomial x
  			   (2 (complex rectangular 2 . 1))
  			   (1 (rational 1 . 3))
  			   (0 (real . 1.41421356)))
	      #f)
  (print-test '(polynomial x
  			   (2 (complex rectangular 0 . 0))
  			   (1 (rational 0 . 3))
  			   (0 (real . 0)))
	      #t)
  (print-test '(polynomial x
  			   (2 (complex rectangular 0 . 0))
  			   (1 (polynomial y (5 0) (3 0) (0 0)))
  			   (0 (real . 0)))
	      #t)
  )

では実験してみよう。

gosh> (test-=zero?)

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

    result = #f

    answer = #f

#t : (polynomial x (2 0) (1 0) (0 2))

    result = #f

    answer = #f

#t : (polynomial x (2 0) (1 0) (0 0))

    result = #t

    answer = #t

#t : (polynomial x (2 0) ((rational 1 . 3) 0) (0 2))

    result = #f

    answer = #f

#t : (polynomial x (2 0) (0 (rational 1 . 3)) (0 2))

    result = #f

    answer = #f

#t : (polynomial x (2 0) (0 (rational 0 . 3)) (0 0))

    result = #t

    answer = #t

#t : (polynomial x (2 (complex rectangular 2 . 1)) (1 (rational 1 . 3)) (0 (real . 1.41421356)))

    result = #f

    answer = #f

#t : (polynomial x (2 (complex rectangular 0 . 0)) (1 (rational 0 . 3)) (0 (real . 0)))

    result = #t

    answer = #t

#t : (polynomial x (2 (complex rectangular 0 . 0)) (1 (polynomial y (5 0) (3 0) (0 0))) (0 (real . 0)))

    result = #t

    answer = #t

#

gosh> 

よし、いいだろう。