close Warning: Can't synchronize with repository "(default)" (The repository directory has changed, you should resynchronize the repository with: trac-admin $ENV repository resync '(default)'). Look in the Trac log for more information.

Ignore:
Timestamp:
2015-06-20T18:20:49-07:00 (9 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/polynomial.lisp

    r2735 r2738  
    102102
    103103
    104 (defun fast-addition (p q order-fn add-fun)
     104(defmacro def-fast-add/subtract (order-fn add/subtract-fun &optional (uminus-fun nil uminus-fun-supplied-p))
    105105  "Returns the sum of two polynomials. Implements an efficient
    106106algorithm to add two polynomials represented as sorted lists of
    107107terms. This function destroys both arguments, reusing the terms to
    108108build the result."
    109   (macrolet ((lc (x) `(r-coeff (car ,x))))
    110     (do ((p p)
    111          (q q)
    112          r)
    113         ((or (endp p) (endp q))
    114          ;; NOTE: R contains the result in reverse order. Can it
    115          ;; be more efficient to produce the terms in correct order?
    116          (unless (endp q) (setf r (nreconc r q)))
    117          r)
    118       (multiple-value-bind
    119             (greater-p equal-p)
    120           (funcall order-fn (car p) (car q))
    121         (cond
    122           (greater-p
    123            (rotatef (cdr p) r p)
    124            )
    125           (equal-p
    126            (let ((s (funcall add-fun (lc p) (lc q))))
    127              (cond
    128                ((r-zerop s)
    129                 (setf p (cdr p))
    130                 )
    131                (t
    132                 (setf (lc p) s)
    133                 (rotatef (cdr p) r p))))
    134            (setf q (cdr q))
    135            )
    136           (t
    137            (rotatef (cdr q) r q)))))))
     109  `(lambda (p q)
     110     (macrolet ((lc (x) `(r-coeff (car ,x))))
     111       (do ((p p)
     112            (q q)
     113            r)
     114           ((or (endp p) (endp q))
     115            ;; NOTE: R contains the result in reverse order. Can it
     116            ;; be more efficient to produce the terms in correct order?
     117            (unless (endp q) (setf r (nreconc r q)))
     118            r)
     119         (multiple-value-bind
     120               (greater-p equal-p)
     121             (funcall ,order-fn (car p) (car q))
     122           (cond
     123             (greater-p
     124              (rotatef (cdr p) r p)
     125              )
     126             (equal-p
     127              (let ((s (funcall ,add/subtract-fun (lc p) (lc q))))
     128                (cond
     129                  ((r-zerop s)
     130                   (setf p (cdr p))
     131                   )
     132                  (t
     133                   (setf (lc p) s)
     134                   (rotatef (cdr p) r p))))
     135              (setf q (cdr q))
     136              )
     137             (t
     138              ;;Negate the term of Q if UMINUS provided
     139              ,@(when uminus-fun-supplied-p
     140                      `((setf (lc q) (funcall ,uminus-fun (lc q)))))
     141              (rotatef (cdr q) r q))))))))
    138142
    139143
Note: See TracChangeset for help on using the changeset viewer.