Changeset 4495 for branches

Timestamp:

2016-06-16T20:49:54-07:00 (8 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/slow-add.lisp (modified) (1 diff)

branches/f4grobner/slow-add.lisp

@@ -1 @@
-(defun slow-add (p q order-fn add-fn)
-  (cond
-    ((endp p) q)
-    ((endp q) p)
-    (t 
-     (multiple-value-bind 
-           (greater-p equal-p)
-         (funcall order-fn (car p) (car q))
-       (cond
-         (greater-p                     ; (> (car p) (car q))
-          (cons (car p) (slow-add (cdr p) q order-fn add-fn))
-          )
-         (equal-p                       ; (= (car p)) (car q))
-          (let ((s (funcall add-fn (lc p) (lc q))))
-            (cond 
-              ((universal-zerop s)
-               (slow-add (cdr p) (cdr q) order-fn add-fn))
-              (t 
-               ;; Adjust the lc of p
-               (setf (lc p) s)
-               (cons (car p) (slow-add (cdr p) (cdr q) order-fn add-fn))
-               ))))
-         (t                    ;(< (car p) (car q))                     
-          (cons (car q) (slow-add p (cdr q) order-fn add-fn))
-          ))))))
+(in-package :polynomial)
+
+(defun f-add (p q order-fn add-fn)
+  "Add two polynomials, P and Q, represented as lists of terms.
+The operation is destructive to both polynomials, as the terms
+of both lists are combined into the result. The operation does not
+create any new instance of TERM."
+  (do (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)))
+       (unless (endp p)
+         (setf r (nreconc r p)))
+       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-fn (lc p) (lc q))))
+           (cond 
+             ((universal-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))))))