(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 
       ;;TODO: Eliminate this debugging code
       #+nil
       (progn
	 (format t "~V@{~C~:*~}~%" 80 #\-)
	 (format t "RESULT:      ~S~%" (mapcar #'->list result))
	 (format t "RESULT-LAST: ~S~%" (mapcar #'->list result-last))
	 (format t "P:           ~S~%" (mapcar #'->list p))
	 (format t "Q:           ~S~%" (mapcar #'->list q)))
       (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))