Changeset 2534 for branches

Timestamp:

2015-06-19T15:23:10-07:00 (9 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/polynomial.lisp (modified) (1 diff)

branches/f4grobner/polynomial.lisp

@@ -109 +109 @@
   (macrolet ((lt (termlist) `(car ,termlist))
              (lc (termlist) `(term-coeff (lt ,termlist))))
-    (with-slots ((p termlist) order)
-      self
-      (with-slots ((q termlist))
-        other
-      (do (r)
-          ((cond
-             ((endp p)
-              (setf p (nconc p q))
-              t)
-             ((endp q))
-             (t
-              (multiple-value-bind
-                    (lm-greater lm-equal)
-                  (funcall order (car p) (car q))
-                (cond
-                  (lm-equal
-                   (let ((s (r+ (lc p) (lc q))))
-                     (unless (r-zerop s)
-                       
-                  (lm-greater
-                   (setf r (cons (car p) r)
-                         p (cdr p)))
-                  (t (setf r (cons (car q) r)
-                           q (cdr q)))))
-              nil))
-           r)))))))))
+    (with-slots ((termlist1 termlist))
+        self
+      (with-slots ((termlist2 termlist))
+          other
+
+        (do ((p termlist1  (cdr p))
+             (q termlist2))
+            ((endp p)
+             )
+          ;; Copy all initial terms of q greater than (lt p) into p       
+          (do ((r q (cdr q)))
+              ((lex> (lt r) (lt p)))
+            (push (lt r) p))
+          ;; Now compare leading terms of p and q
+          (multiple-value-bind
+                (lm-greater lm-equal)
+              (lex> (lt p) (lt q))
+            (cond
+              (lm-equal
+               ;; Simply add coefficients
+               (setf (lc p) (add-to (lc p) (lc q))))
+                    (lm-greater
+                     ;; Since (lt p) > (lt q), we need to insert (lt q) into p
+                     (setf p (cons (car p) r)
+                           p (cdr p)))
+                    (t (setf r (cons (car q) r)
+                             q (cdr q)))))
+                nil))
+             r)))))
   self)