(in-package "POLYNOMIAL")

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