Changeset 4451 for branches/f4grobner

Timestamp:

2016-06-11T15:24:27-07:00 (8 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/polynomial.lisp (modified) (2 diffs)

branches/f4grobner/polynomial.lisp

@@ -389 +389 @@
 
 
+(defun fast-and-risky-add (p q order-fn add-fn &aux result result-last)
+  (when (and p q (eq p q)) (warn "FAST-AND-RISKY-ADD: ~S is EQ to ~S" p q))
+  (flet ((add-to-result (x)
+           (assert (consp x))
+           (setf (cdr x) nil)
+           (if (endp result)
+               (setf result x
+                     result-last x)
+               (setf (cdr result-last) x
+                     result-last (cdr result-last)))))
+    (loop 
+       (cond
+         ((endp p) (unless (endp q) (add-to-result q)) (return result))
+         ((endp q) (unless (endp p) (add-to-result p)) (return result))
+         (t 
+          (multiple-value-bind 
+                (greater-p equal-p)
+              (funcall order-fn (car p) (car q))
+            (cond
+              (greater-p                ; (> (car p) (car q))
+               (let ((tmp (cdr p)))
+                 (add-to-result p)
+                 (setf p tmp)))
+              (equal-p                  ; (= (car p)) (car q))
+               (let ((s (funcall add-fn (lc p) (lc q))))
+                 (cond 
+                   ((universal-zerop s)
+                    ;; Terms cancel, discard both
+                    (setf p (cdr p)
+                          q (cdr q)))
+                   (t 
+                    ;; Terms do not cancel, store the
+                    ;; sum of coefficients in (lc p)
+                    (setf (lc p) s)
+                    (let ((tmp (cdr p)))
+                      (add-to-result p)
+                      (setf p tmp
+                            q (cdr q)))))))
+              (t                 ;(< (car p) (car q))                   
+               (let ((tmp (cdr q)))
+                 (add-to-result q)
+                 (setf q tmp))
+               ))))))))
+
 (defun fast-add (p q order-fn add-fn)
   "This version calls SLOW-ADD and is bullet-proof."
-  (slow-add p q order-fn add-fn))
+  ;;(slow-add p q order-fn add-fn)
+  (fast-and-risky-add p q order-fn add-fn)
+  )
 
 #|
@@ -456 +502 @@
   
 
-(defmethod subtract-from ((self poly) (other poly) &aux (other-copy (copy-instance other)))
+(defmethod subtract-from ((self poly) (other poly))
   "Subtracts from polynomial SELF another polynomial OTHER.
 This operation destructively modifies both polynomials.
 The result is stored in SELF. This implementation does
 no consing, entirely reusing the sells of SELF and OTHER."
-  (change-term-order other-copy self)
+  (change-term-order other self)
   (setf (poly-termlist self) (subtract-termlists
-                              (poly-termlist self) (poly-termlist other-copy)
+                              (poly-termlist self) (poly-termlist other)
                               (poly-term-order self)))
   self)