SICP問題2.92 - tmurataの日記

変数に順序をつけることによって異なる変数の多項式に対しても多項式の加算と乗算が出来るようにする。
とりあえず

make-polynomial の第一引数は(variable-list)とし、すべての変数の並びを(variable1 variable2 ...)の要領で受け取るようにする
一つ一つの項は (order-list coeff) とし、order-list は各変数のorderを (variable1-order variable2-order ...) としたlist とする

という方針で考えてみる
(例)
$2x - 1$

(make-polynomial '(x) '(((1) 2) ((0) -1)))

$2x - 1$

(make-polynomial '(x y) '(((1 0) 2) ((0 0) -1)))

$2y - 1$

(make-polynomial '(x y) '(((0 1) 2) ((0 0) -1)))

$2xy - 1$

(make-polynomial '(x y) '(((1 1) 2) ((0 0) -1)))

$x^2 + 2xy - y^2 + 1$

(make-polynomial '(x y) '(((2 0) 1) ((1 1) 2) ((0 2) 1) ((0 0) -1)))

2.88辺りの install-polynomial-package を修正する方向で。

(define (install-polynomial-package)
  ;; 内部手続き
  ;; 多項式の表現
  (define (make-poly variable termlist)
    (cons variable termlist))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  (define (variable? x) (symbol? x))
  ; 変数リストが並び順も含めて全て同じか?
  (define (same-variable-list? v1 v2)
    (define (all-variables? val-list)
      (define (iter x result)
        (cond ((null? x) result)
              ((not result) result)
              ((symbol? (car x)) (iter (cdr x) #t))
              (else #f)))
      (if (null? val-list)
          #f
          (iter val-list #t)))
    (and (all-variables? v1) (all-variables? v2) (equal? v1 v2)))
  ;; 項とリストの表現
  (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 orderlist coeff) (list orderlist coeff))
  (define (order-list term) (car term))
  (define (coeff term) (cadr term))
  (define (same-orderlist? term1 term2)
    (equal? (order-list term1) (order-list term2)))
  (define (adjoin-term term termlist)
    (if (=zero? (coeff term))
        termlist
        (cons term termlist)))
  (define (first-order orderlist) (car orderlist))
  (define (rest-orders orderlist) (cdr orderlist))
  ; 次数の大小比較
  (define (orders-gt? L1 L2)
    (if (null? L1) #f
        (let ((o1 (first-order L1))
              (o2 (first-order L2)))
          (cond ((> o1 o2) #t)
                ((< o1 o2) #f)
                (else (orders-gt? (rest-orders L1) (rest-orders L2)))))))
  (define (orders-lt? L1 L2)
    (if (null? L1) #f
        (let ((o1 (first-order L1))
              (o2 (first-order L2)))
          (cond ((< o1 o2) #t)
                ((> o1 o2) #f)
                (else (orders-lt? (rest-orders L1) (rest-orders L2)))))))
  ; 多項式の和のリストを構成する手続き
  (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 ((orders-gt? (order-list t1) (order-list t2))
                    (adjoin-term 
                     t1 (add-terms (rest-terms L1) L2)))
                   ((orders-lt? (order-list t1) (order-list t2))
                    (adjoin-term
                     t2 (add-terms L1 (rest-terms L2))))
                   (else
                    (adjoin-term
                     (make-term (order-list 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-list (order-list t1) (order-list t2))
                       (mul (coeff t1) (coeff t2)))
            (mul-term-by-all-terms t1 (rest-terms L))))))
  (define (add-order-list o1 o2)
    (if (null? o1)
        '()
        (cons (+ (car o1) (car o2)) (add-order-list (cdr o1) (cdr o2)))))
  (define (add-poly p1 p2)
    (if (same-variable-list? (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-list? (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? L)
    (define (=zero-term? x)
      (or (empty-termlist? x)
          (if (=zero? (coeff (first-term x)))
              (=zero-term? (rest-terms x))
              #f)))
    (=zero-term? (term-list L)))
  (define (negate-termlist L)
    (if (empty-termlist? L)
        L
        (let ((f (first-term L))
              (r (rest-terms L)))
          (adjoin-term
           (make-term (order-list f)
                      (negate (coeff f)))
           (negate-termlist r)))))
  (define (sub-poly x y)
    (add-poly x 
              (make-poly (variable y)
                         (negate-termlist (term-list 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 (make-poly (variable x)
                                   (negate-termlist (term-list 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
 ; x^2 + xy + 2y^2 + 1
 (make-polynomial '(x y) '(((2 0) 1) ((1 1) 1) ((0 2) 2) ((0 0) 1)))
 ; 4x^2 + 3xy + 2y^2 + 1
 (make-polynomial '(x y) '(((2 0) 4) ((1 1) 3) ((0 2) 2) ((0 0) 1)))
)
; ; 5x^2 + 4xy + 4y^2 + 2
; (polynomial (x y) ((2 0) 5) ((1 1) 4) ((0 2) 4) ((0 0) 2))
(mul
 ; x + y
 (make-polynomial '(x y) '(((1 0) 1) ((0 1) 1)))
 ; x - y
 (make-polynomial '(x y) '(((1 0) 1) ((0 1) -1)))
)
; ; x^2 - y^2
; (polynomial (x y) ((2 0) 1) ((0 2) -1))
(mul
 ; x + y
 (make-polynomial '(x y) '(((1 0) 1) ((0 1) 1)))
 ; x - y
 (make-polynomial '(x y) '(((1 0) 1) ((0 1) 1)))
)
; ; x^2 + 2xy + y^2
; (polynomial (x y) ((2 0) 1) ((1 1) 2) ((0 2) 1))