From a92aa63fc129d2ac09eb68f4707f27331aa37c7c Mon Sep 17 00:00:00 2001 From: Felix Martin Date: Tue, 8 Dec 2020 21:39:02 -0500 Subject: [PATCH] Finish exercises for chapter 2 --- ex-2_77-97.scm | 96 +++++++++++++++++++++++++++++++++++++------------- 1 file changed, 71 insertions(+), 25 deletions(-) diff --git a/ex-2_77-97.scm b/ex-2_77-97.scm index b87ca69..6ce34f2 100644 --- a/ex-2_77-97.scm +++ b/ex-2_77-97.scm @@ -63,6 +63,13 @@ (if (and (integer? a) (integer? b)) (if (= b 0) (abs a) (gcd-scheme b (remainder a b))) 'nogcd)) + (define (reduce-integers n d) + (if (and (integer? n) (integer? d)) + (let ((g (gcd n d))) + (list (/ n g) (/ d g))) + 'noreduce)) + (put 'reduce '(scheme-number scheme-number) + (lambda (x y) (reduce-integers x y))) (put 'add '(scheme-number scheme-number) (lambda (x y) (tag (+ x y)))) (put 'sub '(scheme-number scheme-number) @@ -94,10 +101,10 @@ (define (numer x) (car x)) (define (denom x) (cdr x)) (define (make-rat n d) - (let ((g (gcd n d))) - (if (eq? g 'nogcd) + (let ((reduced (reduce n d))) + (if (eq? reduced 'noreduce) (cons n d) - (cons (div n g) (div d g))))) + (cons (car reduced) (cadr reduced))))) (define (add-rat x y) (let ((new-n (add (mul (numer x) (denom y)) (mul (numer y) (denom x)))) @@ -336,6 +343,10 @@ (if (procedure? (get 'gcd (list (type-tag x) (type-tag y)))) (apply-generic 'gcd x y) 'nogcd)) +(define (reduce x y) + (if (procedure? (get 'reduce (list (type-tag x) (type-tag y)))) + (apply-generic 'reduce x y) + 'noreduce)) (install-scheme-number-package) (install-rational-package) @@ -958,6 +969,7 @@ (list p1 p2)))) (define (div-terms L1 L2) + ; (display "DIV-TERMS ") (display L1) (display L2) (newline) (define (negate-term t) (make-term (order t) (negate (coeff t)))) (define (negate-terms terms) @@ -1011,38 +1023,56 @@ (error "Polys not in same var -- ADD-POLY" (list p1 p2)))) + (define (remainder-terms-pseudo p q) + (let ((o1 (order (first-term p))) + (o2 (order (first-term q))) + (c (coeff (first-term q)))) + (let ((integerizing-factor + (expt c (+ 1 o1 (- o2))))) + (cadr (div-terms (scale-terms integerizing-factor p) + q))))) + + (define (gcd-terms-pseudo a b) + ; (display "GCD-TERMS-PSEUDO") (display a) (display b) (newline) + (if (empty-termlist? b) + a + (gcd-terms-pseudo b (remainder-terms-pseudo a b)))) + + ; Returns the coefficients for a list of integers. + (define (gcd-list xs) + (cond + ((null? xs) 1) + ((null? (cdr xs)) (car xs)) + (else (gcd-list (cons (gcd (car xs) (cadr xs)) (cddr xs)))))) + (define (gcd-poly-pseudo p1 p2) ; (display "GCD-POLY-PSEUDO") (display p1) (display p2) (newline) - (define (pseudo-remainder-terms p q) - (let ((o1 (order (first-term p))) - (o2 (order (first-term q))) - (c (coeff (first-term q)))) - (let ((integerizing-factor - (expt c (+ 1 o1 (- o2))))) - (cadr (div-terms (scale-terms integerizing-factor p) - q))))) - - (define (gcd-list xs) - (cond - ((null? xs) 1) - ((null? (cdr xs)) (car xs)) - (else (gcd-list (cons (gcd (car xs) (cadr xs)) (cddr xs)))))) - - (define (gcd-terms a b) - ; (display "GCD-TERMS-PSEUDO") (display a) (display b) (newline) - (if (empty-termlist? b) - a - (gcd-terms b (pseudo-remainder-terms a b)))) (if (same-variable? (variable p1) (variable p2)) - (let ((result-terms (gcd-terms (term-list p1) - (term-list p2)))) + (let ((result-terms (gcd-terms-pseudo (term-list p1) + (term-list p2)))) (let ((gcd-result (gcd-list (coeffs result-terms)))) (make-poly (variable p1) (scale-terms (/ 1 gcd-result) result-terms)))) (error "Polys not in same var -- ADD-POLY" (list p1 p2)))) + (define (reduce-terms a b) + (let ((g (gcd-terms-pseudo a b))) + (let ((gcd-result (gcd-list (coeffs g)))) + (let ((g-scaled (scale-terms (/ 1 gcd-result) g))) + (list (car (div-terms a g-scaled)) (car (div-terms b g-scaled))))))) + + (define (reduce-poly p1 p2) + ; (display "REDUCE-POLY ") (display p1) (display p2) (newline) + (if (same-variable? (variable p1) (variable p2)) + (let ((reduced-list (reduce-terms (term-list p1) + (term-list p2)))) + (list (tag (make-poly (variable p1) (car reduced-list))) + (tag (make-poly (variable p2) (cadr reduced-list))))) + (error "Polys not in same var -- ADD-POLY" + (list p1 p2)))) + ;; interface to rest of the system (define (tag p) (attach-tag 'polynomial p)) (put 'add '(polynomial polynomial) @@ -1057,6 +1087,8 @@ (lambda (p1 p2) (tag (gcd-poly p1 p2)))) (put 'greatest-comond-divisor-pseudo '(polynomial polynomial) (lambda (p1 p2) (tag (gcd-poly-pseudo p1 p2)))) + (put 'reduce '(polynomial polynomial) + (lambda (p1 p2) (reduce-poly p1 p2))) (put '=zero? '(polynomial) =zero?-poly) (put 'make 'poly-sparse (lambda (var terms) (tag (make-poly-sparse var terms)))) @@ -1159,4 +1191,18 @@ (display "\nex-2.97\n") +(assert (car (reduce q1 q2)) p2) +(assert (cadr (reduce q1 q2)) p3) +(assert (reduce 8 14.242) 'noreduce) +(assert (reduce 6 8) (list 3 4)) +(assert (cadr (make-rational q1 q2)) p2) +(define p1 (make-poly-sparse 'x '((1 1)(0 1)))) +(define p2 (make-poly-sparse 'x '((3 1)(0 -1)))) +(define p3 (make-poly-sparse 'x '((1 1)))) +(define p4 (make-poly-sparse 'x '((2 1)(0 -1)))) + +(define rf1 (make-rational p1 p2)) +(define rf2 (make-rational p3 p4)) + +(display (add rf1 rf2)) (newline)