Changeset 2738 for branches

Timestamp:

2015-06-20T18:20:49-07:00 (9 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

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

branches/f4grobner/polynomial.lisp

@@ -102 +102 @@
 
 
-(defun fast-addition (p q order-fn add-fun)
+(defmacro def-fast-add/subtract (order-fn add/subtract-fun &optional (uminus-fun nil uminus-fun-supplied-p))
   "Returns the sum of two polynomials. Implements an efficient
 algorithm to add two polynomials represented as sorted lists of
 terms. This function destroys both arguments, reusing the terms to
 build the result."
-  (macrolet ((lc (x) `(r-coeff (car ,x))))
-    (do ((p p)
-         (q q)
-         r)
-        ((or (endp p) (endp q))
-         ;; NOTE: R contains the result in reverse order. Can it
-         ;; be more efficient to produce the terms in correct order?
-         (unless (endp q) (setf r (nreconc r q)))
-         r)
-      (multiple-value-bind 
-            (greater-p equal-p)
-          (funcall order-fn (car p) (car q))
-        (cond
-          (greater-p
-           (rotatef (cdr p) r p)
-           )
-          (equal-p
-           (let ((s (funcall add-fun (lc p) (lc q))))
-             (cond 
-               ((r-zerop s)
-                (setf p (cdr p))
-                )
-               (t 
-                (setf (lc p) s)
-                (rotatef (cdr p) r p))))
-           (setf q (cdr q))
-           )
-          (t 
-           (rotatef (cdr q) r q)))))))
+  `(lambda (p q) 
+     (macrolet ((lc (x) `(r-coeff (car ,x))))
+       (do ((p p)
+            (q q)
+            r)
+           ((or (endp p) (endp q))
+            ;; NOTE: R contains the result in reverse order. Can it
+            ;; be more efficient to produce the terms in correct order?
+            (unless (endp q) (setf r (nreconc r q)))
+            r)
+         (multiple-value-bind 
+               (greater-p equal-p)
+             (funcall ,order-fn (car p) (car q))
+           (cond
+             (greater-p
+              (rotatef (cdr p) r p)
+              )
+             (equal-p
+              (let ((s (funcall ,add/subtract-fun (lc p) (lc q))))
+                (cond 
+                  ((r-zerop s)
+                   (setf p (cdr p))
+                   )
+                  (t 
+                   (setf (lc p) s)
+                   (rotatef (cdr p) r p))))
+              (setf q (cdr q))
+              )
+             (t 
+              ;;Negate the term of Q if UMINUS provided
+              ,@(when uminus-fun-supplied-p
+                      `((setf (lc q) (funcall ,uminus-fun (lc q)))))
+              (rotatef (cdr q) r q))))))))