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 2534 for branches/f4grobner


Ignore:
Timestamp:
2015-06-19T15:23:10-07:00 (9 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/polynomial.lisp

    r2533 r2534  
    109109  (macrolet ((lt (termlist) `(car ,termlist))
    110110             (lc (termlist) `(term-coeff (lt ,termlist))))
    111     (with-slots ((p termlist) order)
    112       self
    113       (with-slots ((q termlist))
    114         other
    115       (do (r)
    116           ((cond
    117              ((endp p)
    118               (setf p (nconc p q))
    119               t)
    120              ((endp q))
    121              (t
    122               (multiple-value-bind
    123                     (lm-greater lm-equal)
    124                   (funcall order (car p) (car q))
    125                 (cond
    126                   (lm-equal
    127                    (let ((s (r+ (lc p) (lc q))))
    128                      (unless (r-zerop s)
    129                        
    130                   (lm-greater
    131                    (setf r (cons (car p) r)
    132                          p (cdr p)))
    133                   (t (setf r (cons (car q) r)
    134                            q (cdr q)))))
    135               nil))
    136            r)))))))))
     111    (with-slots ((termlist1 termlist))
     112        self
     113      (with-slots ((termlist2 termlist))
     114          other
     115
     116        (do ((p termlist1  (cdr p))
     117             (q termlist2))
     118            ((endp p)
     119             )
     120          ;; Copy all initial terms of q greater than (lt p) into p       
     121          (do ((r q (cdr q)))
     122              ((lex> (lt r) (lt p)))
     123            (push (lt r) p))
     124          ;; Now compare leading terms of p and q
     125          (multiple-value-bind
     126                (lm-greater lm-equal)
     127              (lex> (lt p) (lt q))
     128            (cond
     129              (lm-equal
     130               ;; Simply add coefficients
     131               (setf (lc p) (add-to (lc p) (lc q))))
     132                    (lm-greater
     133                     ;; Since (lt p) > (lt q), we need to insert (lt q) into p
     134                     (setf p (cons (car p) r)
     135                           p (cdr p)))
     136                    (t (setf r (cons (car q) r)
     137                             q (cdr q)))))
     138                nil))
     139             r)))))
    137140  self)
    138141
Note: See TracChangeset for help on using the changeset viewer.