Finish exercises for chapter 2

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)