Changeset 2565 for branches/f4grobner/polynomial.lisp

Timestamp:

2015-06-19T17:23:55-07:00 (9 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

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

branches/f4grobner/polynomial.lisp

@@ -29 +29 @@
 (proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
 
-#|
-             ;;
-             ;; BOA constructor, by default constructs zero polynomial
-             (:constructor make-poly-from-termlist (termlist &optional (sugar (termlist-sugar termlist))))
-             (:constructor make-poly-zero (&aux (termlist nil) (sugar -1)))
-             ;; Constructor of polynomials representing a variable
-             (:constructor make-poly-variable (ring nvars pos &optional (power 1)
-                                               &aux
-                                               (termlist (list
-                                                          (make-term-variable ring nvars pos power)))
-                                               (sugar power)))
-             (:constructor poly-unit (ring dimension
-                                           &aux
-                                           (termlist (termlist-unit ring dimension))
-                                           (sugar 0))))
-
-|#
-
 (defclass poly ()
   ((termlist :initarg :termlist :accessor poly-termlist))
@@ -111 +93 @@
       (with-slots ((termlist2 termlist))
           other
-        (do ((p termlist1  (cdr p))
+        (do ((p termlist1)
              (q termlist2))
-            ((endp p)
-             ;; Include remaining terms of termlist1
-             (setf termlist1 (nconc p q)))
+            ((endp q))
           ;; Copy all initial terms of q greater than (lt p) into p       
-          (do ((r q (cdr r)))
+          (do ()
               ((cond 
-                 ((endp r))
+                 ((endp q))
                  (t 
                   (multiple-value-bind 
                         (greater-p equal-p)
-                      (lex> (lt r) (lt p))
+                      (lex> (lt q) (lt p))
                     (cond
                       (greater-p 
-                       (push (pop r) p))
+                       (psetf (cdr q) p
+                              q (cdr q)
+                              (cdr p) p))
                       (equal-p
-                       (setf (lc p) (add-to (lc p) (lc q)))))
+                       (setf (lc p) (add-to (lc p) (lc q))
+                             p (cdr p))))
                     (not greater-p))))))))))
   self)