source: branches/f4grobner/fast-add.lisp@ 4443

(in-package "POLYNOMIAL")

(defun fast-add (p q order-fn add-fn &aux result result-last)
  (assert (not (eq p q)))
  (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
         ((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))
               ))))))))