Serendip

Web Studio

問題2.89

濃い多項式に対応した多項式の算術演算。

(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))
  ;; 2.3.2 節の手続き same-variable? と variable?
  (define (variable? x) (symbol? x))
  (define (same-variable? v1 v2)
    (and (variable? v1) (variable? v2) (eq? v1 v2)))

  (define (=zero-term? L)
    (or (empty-termlist? L)
        (and (=zero? (coeff (first-term L)))
             (=zero-term? (rest-terms L)))))
  (define (=polynomial-zero? p)
    (=zero-term? (term-list p)))

  ;; 項と項リストの表現
  (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 (make-term order coeff) (list order coeff))
  (define (order term) (length (rest-terms term)))
  (define (coeff term) (first-term term))

  ;; 2つの多項式の和の項リストを構成する手続き
  (define (add-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          (else
            (let ((t1 (first-term L1)) (t2 (first-term L2)) (o1 (order L1)) (o2 (order L2)))
                 (cond ((> o1 o2)
                        (adjoin-term
                          t1 (add-terms (rest-terms L1) L2)))
                       ((< o1 o2)
                        (adjoin-term
                          t2 (add-terms L1 (rest-terms L2))))
                       (else
                         (adjoin-term
                           (add t1 t2)
                           (add-terms (rest-terms L1)
                                      (rest-terms L2)))))))))

  ;;;;
  (define (expand-term L n)
     (if (= n 0)
         L
         (expand-term (adjoin-term (make-integer 0) L) (- n 1))))
  (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 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 (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 (sub-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (add-terms (term-list p1)
                              (negative-term (term-list p2))))
        (error "Polys not in same var -- ADD-POLY" (list p1 p2))))

  (define (negative-poly p)
    (make-poly (variable p) (negative-term (term-list p))))

  (define (negative-term L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t (first-term L)))
             (adjoin-term
               (make-term (order t) (negative (coeff t)))
               (negative-term (rest-terms L))))))

  ;; システムの他の部分とのインターフェース
  (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 'negative '(polynomial)
       (lambda (p) (tag (negative-poly p))))
  (put 'sub '(polynomial polynomial)
       (lambda (p1 p2) (tag (sub-poly p1 p2))))
  (put '=zero? '(polynomial) =polynomial-zero?)
  (put 'make 'polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  'done)

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

(install-polynomial-package)

実行結果

(define p1 (make-polynomial 'x '(3 2 0 1)))
(define p2 (make-polynomial 'x '(3 0 1 1)))
(add p1 p2)
gosh> (polynomial x 6 2 1 2)
(mul p1 p2)
gosh> (polynomial x 9 6 3 8 2 1 1)

計算機プログラムの構造と解釈

posted with amazlet at 08.11.07

ジェラルド・ジェイ サスマン ジュリー サスマン ハロルド エイブルソン
ピアソンエデュケーション
売り上げランキング: 6542

Amazon.co.jp で詳細を見る