Chat (Lingr.com)
Informaiton
Daily
Column
- MySQL日本語の旅(5/1)
- アクセス向上秘伝(5/9)
- 一風変ったHaskellλ門(6/13)
- SICP Answer Book (5/31) 問題3.26追加
Zope Solution
Extra
アーカイブ
OSS案内所
Site Info
関連リンク
##(link2sicp "book-Z-H-18.html#%_thm_2.89" "Exercise 2.89")
解答例
install-polynomial-package
(define (install-polynomial-package)
(define (make-poly variable term-list)
(cons variable term-list))
(define (variable p) (car p))
(define (term-list p) (cdr p))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
(and (variable? v1)
(variable? v2)
(eq? v1 v2)))
(define (adjoin-term term term-list)
(cons term term-list))
(define (the-empty-termlist) '())
(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 (order-term term-list) (length (rest-terms term-list)))
(define (coeff-term term-list) (first-term term-list))
(define (=zero-term? L)
(or (empty-termlist? L)
(and (=zero? (coeff (first-term L)))
(=zero-term? (rest-terms L)))))
(define (=zero-poly? p)
(=zero-term? (term-list 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 (normalize-term L)
(cond ((empty-termlist? L) L)
((=zero? (first-term L)) (normalize-term (rest-terms L)))
(else L)))
(define (add-terms L1 L2)
(define (add-rterms R1 R2)
(cond ((empty-termlist? R1) R2)
((empty-termlist? R2) R1)
(else (adjoin-term (add (first-term R1) (first-term R2))
(add-rterms (cdr R1) (cdr R2))))))
(cond ((empty-termlist? L1) L2)
((empty-termlist? L2) L1)
(else
(normalize-term (reverse (add-rterms (reverse L1) (reverse L2)))))))
(define (expand-term L n)
(if (= n 0)
L
(expand-term (adjoin-term (make-scheme-number 0) L) (- n 1))))
(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 (mul-terms L1 L2)
(define (mul-terms-sub n L1 L2)
(if (= n 0)
(mul-term-by-all-terms 0 (first-term L1) L2)
(add-terms (mul-term-by-all-terms n (first-term L1) L2)
(mul-terms-sub (- n 1) (rest-terms L1) L2))))
(if (or (empty-termlist? L1) (empty-termlist? L2))
(the-empty-termlist)
(mul-terms-sub (order-term L1) L1 L2)))
(define (mul-term-by-all-terms n t1 L)
(reverse (expand-term (map (lambda (t) (mul t1 t)) (reverse L)) n)))
(define (negate-poly p)
(make-poly (variable p) (negate-term (term-list p))))
(define (negate-term L) (map negate L))
(define (sub-poly p1 p2)
(add-poly p1 (negate-poly p2)))
(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 p1 p2))))
(put 'mul '(polynomial polynomial)
(lambda (p1 p2) (tag (mul-poly p1 p2))))
(put '=zero? '(polynomial) =zero-poly?)
(put 'negate '(polynomial)
(lambda (p) (tag (negate-poly p))))
(put 'make 'polynomial
(lambda (var terms) (tag (make-poly var terms))))
'done)
実行例
gosh> (install-polynomial-package) done gosh> (define p1 (make-polynomial 'y '(2 1))) p1 gosh> (define p2 (make-polynomial 'y '(2 -1))) p2 gosh> (mul p1 p2) (polynomial y 4 0 -1)
コード
##(sicp-answer-code "ex-2.89.scm")
