Implement poly GCD and scale down coeffs (2.96)

ex-2_77-97.scm

@@ -809,6 +809,12 @@
   (define (order term) (car term))
   (define (coeff term) (cadr term))
 
+  (define (coeffs term-list)
+    (if (empty-termlist? term-list)
+      '()
+      (cons (coeff (first-term term-list))
+            (coeffs (rest-terms term-list)))))
+
   (define (add-terms L1 L2)
     ; (display "ADD-TERMS ") (display L1) (display L2) (newline)
     (cond ((empty-termlist? L1) L2)
@@ -986,17 +992,18 @@
         (else (=zero?-terms (rest-terms terms)))))
     (=zero?-terms (term-list p)))
 
-  (define (remainder-terms a b)
-    (cadr (div-terms a b)))
-
-  (define (gcd-terms a b)
-    ; (display "GCD-TERMS") (display a) (display b) (newline)
-    (if (empty-termlist? b)
-        a
-        (gcd-terms b (remainder-terms a b))))
 
   (define (gcd-poly p1 p2)
-    (display "GCD-POLY") (display p1) (display p2) (newline)
+    ; (display "GCD-POLY") (display p1) (display p2) (newline)
+    (define (remainder-terms a b)
+      (cadr (div-terms a b)))
+
+    (define (gcd-terms a b)
+      ; (display "GCD-TERMS") (display a) (display b) (newline)
+      (if (empty-termlist? b)
+          a
+          (gcd-terms b (remainder-terms a b))))
+
     (if (same-variable? (variable p1) (variable p2))
         (make-poly (variable p1)
                    (gcd-terms (term-list p1)
@@ -1004,6 +1011,38 @@
         (error "Polys not in same var -- ADD-POLY"
                (list p1 p2))))
 
+  (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 ((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))))
+
   ;; interface to rest of the system
   (define (tag p) (attach-tag 'polynomial p))
   (put 'add '(polynomial polynomial)
@@ -1016,6 +1055,8 @@
        (lambda (p1 p2) (div-poly p1 p2)))
   (put 'greatest-comond-divisor '(polynomial polynomial)
        (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 '=zero? '(polynomial) =zero?-poly)
   (put 'make 'poly-sparse
        (lambda (var terms) (tag (make-poly-sparse var terms))))
@@ -1111,5 +1152,11 @@
 (display (greatest-common-divisor q1 q2)) (newline)
 
 
+(display "\nex-2.96 - pseudoremainder and improved GCD\n")
+
+(define (gcd-poly-pseudo x y) (apply-generic 'greatest-comond-divisor-pseudo x y))
+(assert (gcd-poly-pseudo q1 q2) p1)
+
+(display "\nex-2.97\n")