Implement 2.92
That was a hard one. The code is not the cleanest, but I am happy that I was able to get it done. Let's get this chapter done.
This commit is contained in:
parent
443665a099
commit
47e979a30c
@ -728,7 +728,7 @@
|
|||||||
((get 'first-term (type-tag term-list)) (contents term-list)))
|
((get 'first-term (type-tag term-list)) (contents term-list)))
|
||||||
|
|
||||||
(define (adjoin-term term term-list)
|
(define (adjoin-term term term-list)
|
||||||
;(display "ADJOIN-TERM ") (display term) (display term-list) (newline)
|
; (display "ADJOIN-TERM ") (display term) (display term-list) (newline)
|
||||||
((get 'adjoin-term (type-tag term-list)) term (contents term-list)))
|
((get 'adjoin-term (type-tag term-list)) term (contents term-list)))
|
||||||
|
|
||||||
;; sparse implementations
|
;; sparse implementations
|
||||||
@ -788,7 +788,7 @@
|
|||||||
(define (coeff term) (cadr term))
|
(define (coeff term) (cadr term))
|
||||||
|
|
||||||
(define (add-terms L1 L2)
|
(define (add-terms L1 L2)
|
||||||
;(display "ADD-TERMS ") (display L1) (display L2) (newline)
|
; (display "ADD-TERMS ") (display L1) (display L2) (newline)
|
||||||
(cond ((empty-termlist? L1) L2)
|
(cond ((empty-termlist? L1) L2)
|
||||||
((empty-termlist? L2) L1)
|
((empty-termlist? L2) L1)
|
||||||
(else
|
(else
|
||||||
@ -818,23 +818,49 @@
|
|||||||
(else (error "Coercion not supported -- GET-COERCION-TARGET"
|
(else (error "Coercion not supported -- GET-COERCION-TARGET"
|
||||||
(list p1 p2))))))
|
(list p1 p2))))))
|
||||||
|
|
||||||
(define (coerce-terms terms target-var)
|
(define (scale-terms factor terms)
|
||||||
(display "COERCE-TERMS ") (display terms) (newline)
|
; (display "SCALE-TERMS ") (display factor) (display terms) (newline)
|
||||||
(define (coerce-term t)
|
|
||||||
(display "COERCE-TERM ") (display t) (newline)
|
|
||||||
; XXX: implement this
|
|
||||||
(make-term (order t) 1))
|
|
||||||
(if (empty-termlist? terms)
|
(if (empty-termlist? terms)
|
||||||
terms
|
terms
|
||||||
(adjoin-term (coerce-term (first-term terms))
|
(let ((term (first-term terms))
|
||||||
(coerce-terms (rest-terms terms) target-var))))
|
(rest (rest-terms terms)))
|
||||||
|
(adjoin-term (make-term (order term) (mul (coeff term) factor))
|
||||||
|
(scale-terms factor rest)))))
|
||||||
|
|
||||||
|
(put 'mul '(scheme-number polynomial)
|
||||||
|
(lambda (s p) (tag (make-poly (variable p)
|
||||||
|
(scale-terms s (term-list p))))))
|
||||||
|
|
||||||
|
(define (coerce-terms terms source-var target-var)
|
||||||
|
; (display "COERCE-TERMS ") (display terms) (newline)
|
||||||
|
(define (coerce-term t)
|
||||||
|
; (display "COERCE-TERM ") (display t) (newline)
|
||||||
|
(let ((c (coeff t))
|
||||||
|
(o (order t))
|
||||||
|
(new-poly (tag (make-poly-dense
|
||||||
|
source-var
|
||||||
|
(list (list (order t) 1))))))
|
||||||
|
; (display "NEW-POLY ") (display new-poly) (newline)
|
||||||
|
(if (eq? (type-tag c) 'polynomial)
|
||||||
|
(let ((new-poly (tag (make-poly-dense source-var (list (list o 1))))))
|
||||||
|
(scale-terms new-poly (contents (term-list c))))
|
||||||
|
(let ((sub-poly (tag (make-poly-dense
|
||||||
|
source-var
|
||||||
|
(list (list o c))))))
|
||||||
|
(cons 'dense (list (list 0 sub-poly)))))))
|
||||||
|
(if (empty-termlist? terms)
|
||||||
|
terms
|
||||||
|
(add-terms (coerce-term (first-term terms))
|
||||||
|
(coerce-terms (rest-terms terms) source-var target-var))))
|
||||||
|
|
||||||
|
|
||||||
(define (coerce-poly p target-var)
|
(define (coerce-poly p target-var)
|
||||||
(display "COERCE-POLY ") (display p) (newline)
|
; (display "COERCE-POLY ") (display p) (newline)
|
||||||
(if (eq? (variable p) target-var)
|
(if (eq? (variable p) target-var)
|
||||||
p
|
p
|
||||||
(make-poly target-var (coerce-terms (term-list p) target-var))))
|
(let ((coercion-result (coerce-terms (term-list p) (variable p) target-var)))
|
||||||
|
; (display "COERCE-POLY-RESULT ") (display coercion-result) (newline)
|
||||||
|
(make-poly target-var coercion-result))))
|
||||||
|
|
||||||
(define (coerce-polys p1 p2)
|
(define (coerce-polys p1 p2)
|
||||||
(let ((coercion-target-variable (get-coercion-target p1 p2)))
|
(let ((coercion-target-variable (get-coercion-target p1 p2)))
|
||||||
@ -844,15 +870,12 @@
|
|||||||
#f)))
|
#f)))
|
||||||
|
|
||||||
(define (add-poly p1 p2)
|
(define (add-poly p1 p2)
|
||||||
;(display "ADD-POLY ") (display p1) (display p2) (newline)
|
; (display "ADD-POLY ") (display p1) (display p2) (newline)
|
||||||
(if (same-variable? (variable p1) (variable p2))
|
(if (same-variable? (variable p1) (variable p2))
|
||||||
(make-poly (variable p1)
|
(make-poly (variable p1)
|
||||||
(add-terms (term-list p1)
|
(add-terms (term-list p1)
|
||||||
(term-list p2)))
|
(term-list p2)))
|
||||||
(let ((coerced-polys (coerce-polys p1 p2)))
|
(let ((coerced-polys (coerce-polys p1 p2)))
|
||||||
(display "COERCED-POLYS ") (newline)
|
|
||||||
(display "1 ") (display (car coerced-polys)) (newline)
|
|
||||||
(display "2 ") (display (cadr coerced-polys)) (newline)
|
|
||||||
(if coerced-polys
|
(if coerced-polys
|
||||||
(add-poly (car coerced-polys) (cadr coerced-polys))
|
(add-poly (car coerced-polys) (cadr coerced-polys))
|
||||||
(error "Polys not in same var -- ADD-POLY"
|
(error "Polys not in same var -- ADD-POLY"
|
||||||
@ -1004,9 +1027,9 @@
|
|||||||
'((2 1) (0 1)))))))
|
'((2 1) (0 1)))))))
|
||||||
(define p2 (make-poly-dense
|
(define p2 (make-poly-dense
|
||||||
'y
|
'y
|
||||||
(list (list 2 (make-poly-dense
|
(list
|
||||||
'x
|
(list 4 3)
|
||||||
'((2 1) (0 1)))))))
|
(list 2 (make-poly-dense 'x '((2 1) (0 8)))))))
|
||||||
|
|
||||||
(display (add p1 p2)) (newline)
|
(display (add p1 p2)) (newline)
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user