符号算术包练习(2)

练习2.89 请定义一些过程，实现不同密度的多项式表表示
练习2.90 假定我们希望有一个多项式系统，它应该对稠密多项式和稀疏多项式都非常有效
上述两个问题可以一并解决，需要从头构建一个包含密度区分的多项式系统。

点击查看代码

;;关于多项式密度的判断，通过对多项式系数0的数量占总数的比例确定
;;超过一半为0则视为稀疏系统
(define (attach-tag type-tags contents)
    (if (or (number? contents)(polynomial? contents))
        contents
        (cons type-tags contents)))
(define (contents datum)
    (if (or (number? datum)(polynomial? datum))
        datum
        (cadr datum)))
(define (type-tag datum)
    (cond ((number? datum) 'scheme-number)
          ((polynomial? datum) 'polynomial)
          (else (car datum))))
(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))
                (error "No method for these types -- APPLY GENERIC" (list op type-tags))))))
;;通用算术
(define (add x y) (apply-generic 'add x y))
(define (mul x y) (apply-generic 'mul x y))
(define (sub x y) (apply-generic 'sub x y))
(define (neg x) (apply-generic 'neg x))
(define (=zero? x) (apply-generic '=zero? x))
;;算术部分
(define (install-scheme-number-package)
  (define (tag-args op)
    (lambda (x y) (attach-tag 'scheme-number (op x y))))
  (put 'add '(scheme-number scheme-number) (tag-args +))
  (put 'sub '(scheme-number scheme-number) (tag-args -))
  (put 'mul '(scheme-number scheme-number) (tag-args *))
  (put 'neg '(scheme-number) (lambda (x) (tag (- x))))
  (put '=zero? '(scheme-number)
       (lambda (x) (= x 0))))
;;多项式部分
(define (install-polynomial-package)
    (define (number->poly variable type n)
        (make-poly variable (adjoin-term (make-term 0 n) (the-empty-termlist type))))
    (define (tag x) (attach-tag 'polynomial' x))
    (define (put-op name op)
        (put 'name '(polynomial polynomial)
                (lambda (x y) (tag (op x y))))
        (put 'name '(polynomial scheme-number)
                (lambda (x y) 
                    (tag (op x (number->poly (variable x)(type-tag (term-list x)) y)))))
        (put 'name '(scheme-number polynomial)
                (lambda (x y) 
                    (tag (op (number->poly (variable y)(type-tag (term-list y)) x)) y))))
    (put-op 'add add-poly)
    (put-op 'sub sub-poly)
    (put-op 'mul mul-poly)
    (put 'neg '(polynomial) (lambda (x) (tag (neg-poly x))))
    (put '=zero? 'polynomial =zero-poly?)
    'done)

(define (polynomial? p)
    (and (pair? p) (eq? (car p) 'polynomial)))
(define (make-poly variable term-list)
    (define (better-termlist-type termlist)
        (if (> (nozero-term termlist) 0.5)
            'dense-termlist
            'sparse-termlist))
    (let ((better-termlist (trans-termlist termlist
                                (better-termlist-type termlist))))
        (cons 'polynomial (cons variable better-termlist))))
(define (variable? p) (symbol? p))
(define (same-variable? p1 p2)
    (and (variable? p1) (variable? p2)(eq? p1 p2)))
(define (variable p)(cadr p))
(define (term-list p)(cddr p))
(define (add-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                    (add-terme (term-list p1)
                               (term-list p2)))
        (error "Polys not in same var -- ADD" (list p1 p2))))
(define (sub-poly p1 p2)
    (add p1 (neg p2)))
(define (mul-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                    (mul-terme (term-list p1)
                               (term-list p2)))
        (error "Polys not in same var -- MUL" (list p1 p2))))
(define (add-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          (else
            (let ((t1 (first-term L1))
                  (t2 (firet-term L2)))
                (cond ((> (order t1) (order t2))
                        (adjoin-term t1 (add-terms (rest-terms L1) L2)))
                      ((> (order t2) (order t1))
                        (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-terms-by-all-terms (first-term L1) L2)
                   (mul-terms (rest-terms L1) L2))))
(define (mul-terms-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-terms-by-all-terms t1 (rest-terms L))))))
;稠密表示
(define (install-dense-termlist-package)
    (define (adjoin-terms term term-list)
        (cond ((=zero? (coeff term)) term-list)
              ((= (order term) (length term-list)) (cons (coeff term) term-list))
              (else (adjoin-terms term (cons 0 term-list)))))
    (define (first-term term-list)
        (make-term (- (length term-list) 1) (car term-list)))
    (define (the-empty-termlist '()))

    (define (nozero-term termlist)
        (define (nozero-count termlist)
            (cond ((null? termlist) 0)
                  ((=zero? (car termlist)) (nozero-count (cdr termlist)))    
                  (else (+ 1 (nozero-count (cdr termlist))))))
        (if (null? termlist)
            0
            (let ((nozero-count (nozero-count termlist))
                  (total-count (length termlist)))
            (/ nozero-count total-count)))))
    (define (tag x) (attach-tag 'dense-termlist x))
    (put 'adjoin 'dense-termlist
        (lambda (term termlist) (tag (adjoin-terms term term-list))))
    (put 'first-term 'dense-termlist first-term)
    (put 'nozero-term 'dense-termlist nozero-term)
    (put 'the-empty-termlist 'dense-termlist (lambda () (tag (the-empty-termlist))))
;稀疏表示
(define (install-sparse-termlist-package)
    (define (adjoin-terms term term-list)
        (if (=zero? (coeff term))
            term-list
            (cons term term-list)))
    (define (first-term term-list)
        (car term-list))
    (define (the-empty-termlist '()))

    (define (nozero-term term-list)
        (if (null? term-list)
            0
            (let ((nozero-count (length term-list))
                    (total-count (+ 1 (order (first-term term-list)))))
                    (/ nozero-count total-count))))
    
    (define (tag x) (attach-tag 'sparse-termlist x))
    (put 'adjoin 'sparse-termlist
        (lambda (term term-list) (tag (adjoin-terms term term-list))))
    (put 'first-term 'sparse-termlist first-term)
    (put 'nozero-term 'sparse-termlist nozero-term)
    (put 'the-empty-termlist 'sparse-termlist (lambda () (tag (the-empty-termlist)))))
;;需要进行对应修改，增加了对type的识别
(define (adjoin-term term term-list)
    ((get 'adjoin-term (type-tag term-list)) term (contents term-list)))
(define (first-term term-list)
  ((get 'first-term (type-tag term-list)) (contents term-list)))
(define (nonzero-terms-ratio term-list)
  ((get 'nonzero-terms-ratio (type-tag term-list)) (contents term-list)))
(define (the-empty-sparse-termlist)
  ((get 'the-empty-termlist 'sparse-termlist)))
(define (the-empty-dense-termlist)
  ((get 'the-empty-termlist 'dense-termlist)))
(define (the-empty-termlist type) 
  ((get 'the-empty-termlist type)))
(define (trans-termlist term-list type)
    (define (make-term-list term-list type)
        (if (empty-termlist? term-list)
            (the-empty-termlist type)
            (let ((t (first-term term-list)))
                (adjoin-term t (make-term-list (rest-of-term term-list) type)))))
    (if (eq? (type-tag term-list) type)
        term-list
        (make-term-list term-list type)))
(define (rest-of-term term-list) 
    (attach-tag (tag-type term-list) (cdr (contents term-list))))

练习2.91 一个单变元多项式可以除以另一个多项式，产生一个商式和一个余式。请补全空缺的表达式。

点击查看代码

(define (div-terms L1 L2)
    (if (empty-termlist? L1)
        (list (the-empty-termlist) (the-empty-termlist))
        (let ((t1 (first-term L1))
              (t2 (first-term L2)))
            (if (> (order t2) (order t1))
                (list (the-empty-termlist) L1))
                (let ((new-c (div (coeff t1) (coeff t2)))
                      (new-o (- (order t1) (order t2))))
;;原被除数减去除数和第一个商的积，得到第二个被除数。进行新一轮除法。
                        **(let ((new-t (make-term new-o new-c)))**
**                            (let ((new-L1 (sub-terms L1 (mul-term-by-all-term new-t L2))))**
**                                (let ((rest-of-result (div-terms new-L1 L2)))**
**                                    (list (adjoin-term new-t (car rest-of-result))**
**                                        (cadr rest-of-result)**))))))))