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 4451


Ignore:
Timestamp:
2016-06-11T15:24:27-07:00 (9 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/polynomial.lisp

    r4447 r4451  
    389389
    390390
     391(defun fast-and-risky-add (p q order-fn add-fn &aux result result-last)
     392  (when (and p q (eq p q)) (warn "FAST-AND-RISKY-ADD: ~S is EQ to ~S" p q))
     393  (flet ((add-to-result (x)
     394           (assert (consp x))
     395           (setf (cdr x) nil)
     396           (if (endp result)
     397               (setf result x
     398                     result-last x)
     399               (setf (cdr result-last) x
     400                     result-last (cdr result-last)))))
     401    (loop
     402       (cond
     403         ((endp p) (unless (endp q) (add-to-result q)) (return result))
     404         ((endp q) (unless (endp p) (add-to-result p)) (return result))
     405         (t
     406          (multiple-value-bind
     407                (greater-p equal-p)
     408              (funcall order-fn (car p) (car q))
     409            (cond
     410              (greater-p                ; (> (car p) (car q))
     411               (let ((tmp (cdr p)))
     412                 (add-to-result p)
     413                 (setf p tmp)))
     414              (equal-p                  ; (= (car p)) (car q))
     415               (let ((s (funcall add-fn (lc p) (lc q))))
     416                 (cond
     417                   ((universal-zerop s)
     418                    ;; Terms cancel, discard both
     419                    (setf p (cdr p)
     420                          q (cdr q)))
     421                   (t
     422                    ;; Terms do not cancel, store the
     423                    ;; sum of coefficients in (lc p)
     424                    (setf (lc p) s)
     425                    (let ((tmp (cdr p)))
     426                      (add-to-result p)
     427                      (setf p tmp
     428                            q (cdr q)))))))
     429              (t                 ;(< (car p) (car q))                   
     430               (let ((tmp (cdr q)))
     431                 (add-to-result q)
     432                 (setf q tmp))
     433               ))))))))
     434
    391435(defun fast-add (p q order-fn add-fn)
    392436  "This version calls SLOW-ADD and is bullet-proof."
    393   (slow-add p q order-fn add-fn))
     437  ;;(slow-add p q order-fn add-fn)
     438  (fast-and-risky-add p q order-fn add-fn)
     439  )
    394440
    395441#|
     
    456502 
    457503
    458 (defmethod subtract-from ((self poly) (other poly) &aux (other-copy (copy-instance other)))
     504(defmethod subtract-from ((self poly) (other poly))
    459505  "Subtracts from polynomial SELF another polynomial OTHER.
    460506This operation destructively modifies both polynomials.
    461507The result is stored in SELF. This implementation does
    462508no consing, entirely reusing the sells of SELF and OTHER."
    463   (change-term-order other-copy self)
     509  (change-term-order other self)
    464510  (setf (poly-termlist self) (subtract-termlists
    465                               (poly-termlist self) (poly-termlist other-copy)
     511                              (poly-termlist self) (poly-termlist other)
    466512                              (poly-term-order self)))
    467513  self)
Note: See TracChangeset for help on using the changeset viewer.