From 47e979a30cc38c70982dfe8b2458d32660acfd7e Mon Sep 17 00:00:00 2001 From: Felix Martin Date: Wed, 2 Dec 2020 13:27:09 -0500 Subject: [PATCH] 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. --- ex-2_77-97.scm | 61 ++++++++++++++++++++++++++++++++++---------------- 1 file changed, 42 insertions(+), 19 deletions(-) diff --git a/ex-2_77-97.scm b/ex-2_77-97.scm index 8b7fd83..750897f 100644 --- a/ex-2_77-97.scm +++ b/ex-2_77-97.scm @@ -728,7 +728,7 @@ ((get 'first-term (type-tag term-list)) (contents 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))) ;; sparse implementations @@ -788,7 +788,7 @@ (define (coeff term) (cadr term)) (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) ((empty-termlist? L2) L1) (else @@ -818,23 +818,49 @@ (else (error "Coercion not supported -- GET-COERCION-TARGET" (list p1 p2)))))) - (define (coerce-terms terms target-var) - (display "COERCE-TERMS ") (display terms) (newline) - (define (coerce-term t) - (display "COERCE-TERM ") (display t) (newline) - ; XXX: implement this - (make-term (order t) 1)) + (define (scale-terms factor terms) + ; (display "SCALE-TERMS ") (display factor) (display terms) (newline) (if (empty-termlist? terms) terms - (adjoin-term (coerce-term (first-term terms)) - (coerce-terms (rest-terms terms) target-var)))) + (let ((term (first-term terms)) + (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) - (display "COERCE-POLY ") (display p) (newline) + ; (display "COERCE-POLY ") (display p) (newline) (if (eq? (variable p) target-var) 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) (let ((coercion-target-variable (get-coercion-target p1 p2))) @@ -844,15 +870,12 @@ #f))) (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)) (make-poly (variable p1) (add-terms (term-list p1) (term-list 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 (add-poly (car coerced-polys) (cadr coerced-polys)) (error "Polys not in same var -- ADD-POLY" @@ -1004,9 +1027,9 @@ '((2 1) (0 1))))))) (define p2 (make-poly-dense 'y - (list (list 2 (make-poly-dense - 'x - '((2 1) (0 1))))))) + (list + (list 4 3) + (list 2 (make-poly-dense 'x '((2 1) (0 8))))))) (display (add p1 p2)) (newline)