Changeset 2604 for branches/f4grobner

Timestamp:

2015-06-20T01:16:29-07:00 (10 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/polynomial.lisp (modified) (3 diffs)

branches/f4grobner/polynomial.lisp

@@ -91 +91 @@
   self)
 
+(defun fast-add-to (p q order-fn)
+  "Fast destructive addition of termlists P and Q, ordered by
+predicate ORDER-FN. Note that this assumes the presence of a dummy
+header."
+  (macrolet ((lt (x) `(cadr ,x))
+             (lc (x) `(r-coeff (cadr ,x))))
+    (do ((p p)
+         (q q))
+        ((or (endp (cdr p)) (endp (cdr q)))
+         p)
+      (multiple-value-bind 
+            (greater-p equal-p)
+          (funcall order-fn (lt q) (lt p))
+        (cond
+          (greater-p
+           (rotatef (cdr p) (cdr q)))
+          (equal-p
+           (let ((s (add-to (lc p) (lc q))))
+             (if (r-zerop s)
+                 (setf (cdr p) (cddr p))
+                 (setf (lc p) s
+                       q (cdr q)))))))
+      (setf p (cdr p)))))
 
 (defmethod add-to ((self poly) (other poly))
@@ -97 +120 @@
 The result is stored in SELF. This implementation does
 no consing, entirely reusing the sells of SELF and OTHER."
-  (flet ((fast-add-to (p q order-fn)
-           ;; Fast destructive addition of termlists Note that this
-           ;; assumes the presence of a dummy header."
-           (macrolet ((lt (x) `(cadr ,x))
-                      (lc (x) `(r-coeff (cadr ,x))))
-             (do ((p p)
-                  (q q))
-                 ((or (endp (cdr p)) (endp (cdr q)))
-                  p)
-               (multiple-value-bind 
-                     (greater-p equal-p)
-                   (funcall order-fn (lt q) (lt p))
-                 (cond
-                   (greater-p
-                    (rotatef (cdr p) (cdr q)))
-                   (equal-p
-                    (let ((s (add-to (lc p) (lc q))))
-                      (if (r-zerop s)
-                          (setf (cdr p) (cddr p))
-                          (setf (lc p) s
-                                q (cdr q)))))))
-               (setf p (cdr p))))))
     (with-slots ((termlist1 termlist) (order1 order))
         self
@@ -134 +135 @@
         (pop termlist1))))
   self)
-
-(defmethod subtract-from ((self poly) (other poly)))
 
 (defmethod unary-uminus ((self poly)))