source: branches/f4grobner/slow-add.lisp@ 4537

(in-package :polynomial)

(defun f-add (p q order-fn add-fn)
  "Add two polynomials, P and Q, represented as lists of terms.
The operation is destructive to both polynomials, as the terms
of both lists are combined into the result. The operation does not
create any new instance of TERM."
  (do (r)
      ((or (endp p) (endp q))
       ;; NOTE: R contains the result in reverse order. Can it
       ;; be more efficient to produce the terms in correct order?
       (unless (endp q) 
         (setf r (nreconc r q)))
       (unless (endp p)
         (setf r (nreconc r p)))
       r)
    (multiple-value-bind 
          (greater-p equal-p)
        (funcall order-fn (car p) (car q))
      (cond
        (greater-p
         (rotatef (cdr p) r p)
         )
        (equal-p
         (let ((s (funcall add-fn (lc p) (lc q))))
           (cond 
             ((universal-zerop s)
              (setf p (cdr p))
              )
             (t 
              (setf (lc p) s)
              (rotatef (cdr p) r p))))
         (setf q (cdr q))
         )
        (t 
         (rotatef (cdr q) r q))))))

(defun s-add (p q order-fn add-fn &aux result)
  "Non-recursive version of SLOW-ADD."
  (loop 
     (cond
       ((endp p) (return-from s-add (nreconc result q)))
       ((endp q) (return-from s-add (nreconc result p)))
       (t 
        (multiple-value-bind 
              (greater-p equal-p)
            (funcall order-fn (car p) (car q))
          (cond
            (greater-p                  ; (> (car p) (car q))
             (push (pop p) result)
             )
            (equal-p                    ; (= (car p)) (car q))
             (let ((s (funcall add-fn (lc p) (lc q))))
               (cond 
                 ((universal-zerop s)
                  (pop p))
                 (t 
                  ;; Adjust the lc of p
                  (setf (lc p) s)
                  (push (pop p) result)
                  )
                 ))
             (pop q)
             )
            (t      ;(< (car p) (car q))                        
             (push (pop q) result)
             )
            ))))))