(sicp34)m2.87〜2.88

(define (install-polynomial-package)
  ;;internal procedure
  ;;represantation of poly
  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  (define (same-variable? v1 v2)
    (and (eq? v1 v2) (variable? v1) (variable? v2)))
  (define (variable? v) (symbol? v))
  ;;represantatoion of terms and terms lists
  ;;<adjoin-term .. coeff>
  (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 (+ (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 (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))
  ;;=zero?は別のところで定義されている。

  
  (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-term (term-list p1)
                             (term-list p2)))
        (error "Polys not in save var -- MUL-POLY"
              (list p1 p2))))
  
 (define (=zero-term? x)
    (or (empty-termlist? x)
        (and (=zero? (coeff (first-term x)))
             (=zero-term? (rest-terms x)))))
  (define (=zero-poly? p)
    (=zero-term? (term-list p)))

  (define (poly->negative poly)
  ;;試しに近いものを書いてみる
;;   (define (test lst)
;;     (fold-right (lambda (x rest) (cons (cons (car x) (- (cdr x))) rest))
;;           '()
;;           lst))
;;   (test '((1 . 2) (3 . 4)))　　　
    (make-poly (variable poly)
                    (fold-right (lambda (x rest)
                            (cons (make-term (order x) (- (coeff x))) rest))
                          '() (term-list poly))))
  
  (define (sub-poly p1 p2)
    (add-poly p1 (poly->negative p2)))
  
  ;;interface to rest of the system
  (define (tag p) (attach-tag 'polynomial p))
  (put 'sub '(polynomial polynomial)
       (lambda (p1 p2) (tag (sub-poly p1 p2))))
  (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) =zero-poly?)
  (put 'neg '(polynomial) poly->negative)
  'done)

(install-polynomial-package)

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

(print (add (make-polynomial 'x '((3 1) (2 4)))
            (make-polynomial 'x '((4 1) (2 3)))))
;; 68:user> (polynomial x (4 1) (3 1) (2 7))


;;   Exercise 2.87.  Install =zero? for polynomials in the generic arithmetic package. This will allow adjoin-term to work for polynomials with coefficients that are themselves polynomials.
(define (=zero? x)
  (apply-generic 'zero? x))
;;install-polynomial-packageの中に以下を追加
;;  (define (=zero-term? x)
;;     (or (empty-termlist? x)
;;         (and (=zero? (coeff (first-term x)))
;;              (=zero-term? (rest-terms x)))))
;;   (define (=zero-poly? p)
;;     (=zero-term? (term-list p)))
;;   (put 'zero? '(polynomial) =zero-poly?)

(=zero? (make-polynomial 'x '()))
;; 42:user> => #t
(=zero? (make-polynomial 'x '((0 3))))
;; 43:user> => #f

;; Exercise 2.88.  Extend the polynomial system to include subtraction of polynomials. (Hint: You may find it helpful to define a generic negation operation.)


;;install-polynomial-packageに以下の記述を追加
;;   (define (poly->negative poly)
;;     (make-poly (variable poly)
;;                     (fold-right (lambda (x rest)
;;                             (cons (make-term (order x) (- (coeff x))) rest))
;;                           '() (term-list poly))))
  
;;   (define (sub-poly p1 p2)
;;     (add-poly p1 (poly->negative p2)))
;;   (put 'sub '(polynomial polynomial)
;;        (lambda (p1 p2) (tag (sub-poly p1 p2))))

;;片方の符号を逆転させて足せば良いかも
(apply-generic 'neg (make-polynomial 'x '((2 1) (3 4))))
;; 54:user> => (polynomial x (2 -1) (3 -4)) ;;逆転がうまくいっている。


(define (sub . args)
  (apply apply-generic  (cons 'sub args)))

(sub (make-polynomial 'x '((2 2) (1 3) (0 4)))
     (make-polynomial 'x '((5 2) (2 4) (0 -5))))
;; gosh> (polynomial x (5 -2) (2 -2) (1 3) (0 9))
;; できた。