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

(in-package "POLYNOMIAL")

(defun fast-and-risky-add (p q order-fn add-fn &aux result result-last)
  (when (and p q (eq p q)) (warn "FAST-AND-RISKY-ADD: ~S is EQ to ~S" 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))
               ))))))))

(defun fast-add (p q order-fn add-fn)
  (let ((r1 (slow-add p q order-fn add-fn))
        (r2 (fast-and-risky-add p q order-fn add-fn)))
    (unless (every #'universal-equalp r1 r2)
      (format t "~&Error in addition of ~%~A~% and~%~A~% should be:~%" (mapcar #'->list p) (mapcar #'->list q))
      (princ (mapcar #'->list r1))
      (format t "~&Actually is:~%")
      (princ (mapcar #'->list r2))
      )
    r2))