SICP問題2.90 - tmurataの日記

薄い多項式と濃い多項式の両方に効率的な多項式システムの設計。(システムに両方の項リストの表現を認めることで実現する)

ここで

sparse: 薄い
dense: 濃い

で、
以下の多項式の表現は
$x^5 + 2x^4 + 3x^2 - 2x - 5$
薄い多項式での表現の場合

(polynomial x 1 2 0 3 -2 -5)

濃い多項式での表現の場合

(polynomial x (5 1) (4 2) (1 -2) (0 5))

となる。
表現の違いが項の表現の部分なので、そこを以下の要領で型づけするとこんな感じ。

(polynomial x (sparse-term 1 2 0 3 -2 -5))
(polynomial x (dense-term (5 1) (4 2) (1 -2) (0 5)))

「薄い多項式と濃い多項式両方に効率的」ということなので、強制型変換が入ってる問題2.81のapply-genericを使用する。

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
    (apply proc (map contents args))
    (if (= (length args) 2)
        (let ((type1 (car type-tags))
        (type2 (cadr type-tags))
        (a1 (car args))
        (a2 (cadr args)))
    (if (eq? type1 type2)
        (error "Not method for these types"
         (list op type-tags))
        (let ((t1->t2 (get-coercion type1 type2))
        (t2->t1 (get-coercion type2 type1)))
          (cond (t1->t2
           (apply-generic op (t1->t2 a1) a2))
          (t2->t1
           (apply-generic op a1 (t2->t1 a2)))
          (else
           (error "Not method for these types"
            (list op type-tags)))))))
        (error "Not method for these types"
         (list op type-tags)))))))

薄い多項式表現のパッケージ sparse-term-package

(define (install-sparse-term-package)
  (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) (car term))
  (define (coeff term) (cadr term))
  ; 多項式の和のリストを構成する手続き
  (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 (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t2 (first-term L)))
          (adjoin-term
            (make-term (add (order t1) (order t2))
                       (mul (coeff t1) (coeff t2)))
            (mul-term-by-all-terms t1 (rest-terms L))))))
  (define (adjoin-term term termlist)
    (if (=zero? (coeff term))
        termlist
        (cons term termlist)))
  (define (negate-termlist L)
    (if (empty-termlist? L)
        L
        (let ((f (first-term L))
              (r (rest-terms L)))
          (adjoin-term
           (make-term (order f)
                      (negate (coeff f)))
           (negate-termlist r)))))
  (define (=zero-term? x)
    (or (empty-termlist? x)
        (if (=zero? (coeff (first-term x)))
            (=zero-term? (rest-terms x))
            #f)))
  (define (sub-terms L1 L2)
    (add-terms L1 (negate-termlist L2)))
  ;; システムの他の部分とのインタフェース
  (define (tag p) (attach-tag 'sparse-term p))
  (put 'add '(sparse-term sparse-term)
       (lambda (p1 p2) (tag (add-terms p1 p2))))
  (put 'mul '(sparse-term sparse-term)
       (lambda (p1 p2) (tag (mul-terms p1 p2))))
  (put '=zero? '(sparse-term)
       (lambda (x) (=zero-term? x)))
  (put 'negate '(sparse-term)
       (lambda (x) (tag (negate-termlist x))))
  (put 'sub '(sparse-term sparse-term)
       (lambda (p1 p2) (tag (sub-terms p1 p2))))
  (put 'make-from-sparse-term 'sparse-term
       (lambda (x) (tag x)))
  (put 'make-from-dense-term 'sparse-term
       (lambda (x) (tag (dense-term->sparse-term x))))
  'done)
(install-sparse-term-package)

(define (make-sparse-term terms)
  ((get 'make-from-sparse-term 'sparse-term) terms))

濃い多項式表現のパッケージ(dense-term-package)

(define (install-dense-term-package)
  (define (the-empty-termlist) '())
  (define (first-term termlist) (car termlist))
  (define (rest-terms termlist) (cdr termlist))
  (define (empty-termlist? termlist) (null? termlist))
  (define (make-term order coeff) coeff)
  (define (order termlist) (if (pair? termlist)
                               (- (length termlist) 1)
                                0))
  (define (coeff term) term)
   ; 多項式の和のリストを構成する手続き
  (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 L1) (order L2))
                    (adjoin-term 
                     t1 (add-terms (rest-terms L1) L2)))
                   ((< (order L1) (order L2))
                    (adjoin-term
                     t2 (add-terms L1 (rest-terms L2))))
                   (else
                    (adjoin-term
                     (make-term (order L1) ; order の修正に伴い修正
                                (add (coeff t1) (coeff t2)))
                     (add-terms (rest-terms L1) (rest-terms L2))))))))) ; 修正
  
  ; 二つの多項式の乗の項リスト
  (define (extend-term L n)
    (define (extend-term-sub Ls ns)
      (if (<= ns 0)
          Ls
          (extend-term-sub (adjoin-term 0 Ls) (- ns 1))))
    (reverse (extend-term-sub (reverse L) (- n (order L)))))
  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (order L1) (first-term L1) L2)
                   (mul-terms (rest-terms L1) L2))))
  (define (mul-term-by-all-terms n t1 L)
    (map (lambda (x) (* t1 x)) (extend-term L (+ n (order L)))))
  (define (adjoin-term term termlist)
    (cons term termlist))
  (define (negate-termlist L)
    (if (empty-termlist? L)
        L
        (let ((f (first-term L))
              (r (rest-terms L)))
          (adjoin-term
           (make-term (order L) ; order の修正に伴い修正
                      (negate (coeff f)))
           (negate-termlist r)))))
  (define (=zero-term? x)
    (or (empty-termlist? x)
        (if (=zero? (first-term x))
            (=zero-term? (rest-terms x))
            #f)))
  (define (sub-terms L1 L2)
    (add-terms L1 (negate-termlist L2)))
  ;; システムの他の部分とのインタフェース
  (define (tag p) (attach-tag 'dense-term p))
  (put 'add '(dense-term dense-term)
       (lambda (p1 p2) (tag (add-terms p1 p2))))
  (put 'mul '(dense-term dense-term)
       (lambda (p1 p2) (tag (mul-terms p1 p2))))
  (put '=zero? '(dense-term)
       (lambda (x) (=zero-term? x)))
  (put 'negate '(dense-term)
       (lambda (x) (tag (negate-termlist x))))
  (put 'sub '(dense-term dense-term)
       (lambda (p1 p2) (tag (sub-terms p1 p2))))
  (put 'make-from-sparse-term 'dense-term
       (lambda (x) (tag (sparse-term->dense-term x))))
  (put 'make-from-dense-term 'dense-term
       (lambda (x) (tag x)))
  'done)
(install-dense-term-package)
(define (make-dense-term terms)
  ((get 'make-from-dense-term 'dense-term ) terms))

この辺りまでの分のテスト

(make-dense-term '(5 1))
; (dense-term 5 1)
(negate (make-dense-term '(5 0 1)))
; (dense-term -5 0 -1)
(add (make-dense-term '(1 0 5 2))
     (make-dense-term '(1 0 5 2)))
; (dense-term 2 0 10 4)
(mul (make-dense-term '(5 1))
     (make-dense-term '(5 -1)))
; (dense-term 25 0 -1)
(sub (make-dense-term '(1 0 5 2))
     (make-dense-term '(1 0 5 2)))
; (dense-term 0 0 0 0)
(make-sparse-term '((5 1) (2 1) (0 1)))
; (sparse-term (5 1) (2 1) (0 1))
(negate (make-sparse-term '((5 3) (2 1) (0 1))))
; (sparse-term (5 -3) (2 -1) (0 -1))
(add (make-sparse-term '((5 1) (2 1) (0 1)))
     (make-sparse-term '((5 1) (3 1) (0 1))))
; (sparse-term (5 2) (3 1) (2 1) (0 2))
(sub (make-sparse-term '((5 1) (3 1) (0 1)))
     (make-sparse-term '((5 3) (2 1) (0 1))))
; (sparse-term (5 -2) (3 1) (2 -1))
(mul (make-sparse-term '((1 5) (0 1)))
     (make-sparse-term '((1 5) (0 -1))))
; (sparse-term (2 25) (0 -1))
(=zero? (make-dense-term '(5 1)))
; #f
(=zero? (make-dense-term '()))
; #t
(=zero? (make-dense-term '(0 1)))
; #f
(=zero? (make-dense-term '(0 0)))
; #t
(=zero? (make-sparse-term '()))
; #t
(=zero? (make-sparse-term '((3 0))))
; #t
(=zero? (make-sparse-term '((5 0) (0 1))))
; #f

型の強制変換

(define (sparse-term->dense-term x)
  (define (iter order termlist rest-terms)
    (if (null? rest-terms)
        termlist
        (let ((term (car rest-terms)))
          (let ((term-order (car term)))
            (if (= order term-order)
                (iter (+ order 1) (append termlist (cdr term)) (cdr rest-terms))
                (iter (+ order 1) (append termlist '(0)) rest-terms))))))
  (reverse (iter 0 '() (reverse x))))
(define (dense-term->sparse-term x)
  (if (null? x)
      ()
      (if (=zero? (car x))
          (dense-term->sparse-term (cdr x))
          (cons (list (- (length x) 1) (car x))
                (dense-term->sparse-term (cdr x))))))
(put-coercion 'dense-term 'sparse-term
              (lambda (x) (make-sparse-term (dense-term->sparse-term (contents x)))))
(put-coercion 'sparse-term 'dense-term
              (lambda (x) (make-dense-term (sparse-term->dense-term (contents x)))))
(put-coercion 'sparse-term 'sparse-term identity)
(put-coercion 'dense-term 'dense-term identity)

この辺りのテスト

(sparse-term->dense-term '((5 1) (3 2) (0 1)))
; (1 0 2 0 0 1)
(dense-term->sparse-term '(3 0 1 5 2))
; ((4 3) (2 1) (1 5) (0 2))

多項式パッケージ(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 (add-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (add (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 (term-list p1)
                        (term-list p2)))
        (error "Polys not in same var -- MUL-POLY"
               (list p1 p2))))
  (define (=zero-poly? x)
    (=zero? (term-list x)))
  (define (negate-poly x)
    (make-poly (variable x)
               (negate (term-list x))))
  (define (sub-poly x y)
    (add-poly x (negate-poly y)))
  ;; システムの他の部分とのインタフェース
  (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? x)))
  (put 'negate '(polynomial)
       (lambda (x) (tag (negate-poly x))))
  (put 'sub '(polynomial polynomial)
       (lambda (p1 p2) (tag (sub-poly p1 p2))))
  'done)
(install-polynomial-package)
(define (make-polynomial var terms)
  ((get 'make 'polynomial) var terms))

テスト

(add
 (make-polynomial 'x (make-sparse-term '((5 1) (3 2) (1 0) (0 2))))
 (make-polynomial 'x (make-sparse-term '((5 1) (4 3) (2 0) (0 2)))))
; (polynomial x sparse-term (5 2) (4 3) (3 2) (0 4))
(sub
 (make-polynomial 'x (make-sparse-term '((5 1) (3 2) (1 0) (0 2))))
 (make-polynomial 'x (make-sparse-term '((5 1) (4 3) (2 0) (0 2)))))
; (polynomial x sparse-term (4 -3) (3 2))
(mul
 (make-polynomial 'x (make-sparse-term '((2 1) (0 2))))
 (make-polynomial 'x (make-sparse-term '((2 1) (0 -2)))))
; (polynomial x sparse-term (4 1) (0 -4))
(add
 (make-polynomial 'x (make-dense-term '(4 3 5 2)))
 (make-polynomial 'x (make-dense-term '(5 0 1 0 1))))
; (polynomial x dense-term 5 4 4 5 3)
(sub
 (make-polynomial 'x (make-dense-term '(4 3 5 2)))
 (make-polynomial 'x (make-dense-term '(5 0 1 0 1))))
; (polynomial x dense-term -5 4 2 5 1)
(mul
 (make-polynomial 'x (make-dense-term '(2 0 1)))
 (make-polynomial 'x (make-dense-term '(2 0 -1))))
; (polynomial x dense-term 4 0 0 0 -1)
(add
 (make-polynomial 'x (make-sparse-term '((5 1) (3 2) (1 0) (0 2))))
 (make-polynomial 'x (make-dense-term '(5 0 1 0 1))))
; (polynomial x dense-term 1 5 2 1 0 3)
(add
 (make-polynomial 'x (make-dense-term '(5 0 1 0 1)))
 (make-polynomial 'x (make-sparse-term '((5 1) (3 2) (1 0) (0 2)))))
; (polynomial x sparse-term (5 1) (4 5) (3 2) (2 1) (0 3))
(sub
 (make-polynomial 'x (make-sparse-term '((5 1) (3 2) (1 0) (0 2))))
 (make-polynomial 'x (make-dense-term '(5 0 1 0 1))))
; (polynomial x dense-term 1 -5 2 -1 0 1)
(sub
 (make-polynomial 'x (make-dense-term '(5 0 1 0 1)))
 (make-polynomial 'x (make-sparse-term '((5 1) (3 2) (1 0) (0 2)))))
; (polynomial x sparse-term (5 -1) (4 5) (3 -2) (2 1) (0 -1))
(mul
 (make-polynomial 'x (make-dense-term '(2 0 1)))
 (make-polynomial 'x (make-sparse-term '((2 2) (0 -1)))))
; (polynomial x sparse-term (4 4) (0 -1))
(mul
 (make-polynomial 'x (make-sparse-term '((2 2) (0 -1))))
 (make-polynomial 'x (make-dense-term '(2 0 1))))
; (polynomial x dense-term 4 0 0 0 -1)