Changeset 4441 for branches/f4grobner

Timestamp:

2016-06-10T19:07:59-07:00 (9 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

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

branches/f4grobner/fast-add.lisp

@@ -1 @@
-(in-package :polynomial)
+(in-package "POLYNOMIAL")
 
-;; Getter/setter of leading coefficient
-(defun lc (x) (term-coeff (car x)))
-(defun (setf lc) (new-value x) (setf (term-coeff (car x)) new-value))
-
-(defun fast-add (p q order-fn add-fn)
-  (cond
-    ((endp p) p)
-    ((endp q) q)
-    (t 
-     (multiple-value-bind 
-           (greater-p equal-p)
-         (funcall order-fn (car p) (car q))
+(defun fast-add (p q order-fn add-fn &aux result result-last)
+  (flet ((add-to-result (x)
+           (assert (consp x))
+           (setf (cdr x) nil)
+           (if (endp result)
+               (setf result x
+                     result-last x)
+               (setf (cdr result-last) x
+                     result-last (cdr result-last)))))
+    (loop 
        (cond
-         (greater-p                     ; (> (cadr h) (car q))
-          (cons (car p) (fast-add (cdr p) q order-fn add-fn))
-          )
-         (equal-p                       ; (= (cadr h)) (car q))
-          (let ((s (funcall add-fn (lc p) (lc q))))
-            (cond 
-              ((universal-zerop s)
-               (fast-add (cdr p) (cdr q) order-fn add-fn))
-              (t 
-               ;; Adjust the lc of p
-               (setf (lc p) s)
-               (cons (car p) (fast-add (cdr p) (cdr q) order-fn add-fn))
-               ))))
-         (t                    ;(< (cadr h) (car q))                    
-          (cons (car q) (fast-add p (cdr q) order-fn add-fn))
-          ))))))
-
-
-
-
-
-
-
-          
+         ((endp p) (unless (endp q) (add-to-result q)) (return result))
+         ((endp q) (unless (endp p) (add-to-result p)) (return result))
+         (t 
+          (multiple-value-bind 
+                (greater-p equal-p)
+              (funcall order-fn (car p) (car q))
+            (cond
+              (greater-p                ; (> (car p) (car q))
+               (let ((tmp (cdr p)))
+                 (add-to-result p)
+                 (setf p tmp)))
+              (equal-p                  ; (= (car p)) (car q))
+               (let ((s (funcall add-fn (lc p) (lc q))))
+                 (cond 
+                   ((universal-zerop s)
+                    ;; Terms cancel, discard both
+                    (setf p (cdr p)
+                          q (cdr q)))
+                   (t 
+                    ;; Terms do not cancel, store the
+                    ;; sum of coefficients in (lc p)
+                    (setf (lc p) s)
+                    (let ((tmp (cdr p)))
+                      (add-to-result p)
+                      (setf p tmp
+                            q (cdr q)))))))
+              (t                 ;(< (car p) (car q))                   
+               (let ((tmp (cdr q)))
+                 (add-to-result q)
+                 (setf q tmp))
+               ))))))))