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.

Changeset 2742 for branches/f4grobner


Ignore:
Timestamp:
2015-06-20T18:54:29-07:00 (10 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/polynomial.lisp

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