(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)) ))))))))