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 2565


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

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/polynomial.lisp

    r2564 r2565  
    2929(proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
    3030
    31 #|
    32              ;;
    33              ;; BOA constructor, by default constructs zero polynomial
    34              (:constructor make-poly-from-termlist (termlist &optional (sugar (termlist-sugar termlist))))
    35              (:constructor make-poly-zero (&aux (termlist nil) (sugar -1)))
    36              ;; Constructor of polynomials representing a variable
    37              (:constructor make-poly-variable (ring nvars pos &optional (power 1)
    38                                                &aux
    39                                                (termlist (list
    40                                                           (make-term-variable ring nvars pos power)))
    41                                                (sugar power)))
    42              (:constructor poly-unit (ring dimension
    43                                            &aux
    44                                            (termlist (termlist-unit ring dimension))
    45                                            (sugar 0))))
    46 
    47 |#
    48 
    4931(defclass poly ()
    5032  ((termlist :initarg :termlist :accessor poly-termlist))
     
    11193      (with-slots ((termlist2 termlist))
    11294          other
    113         (do ((p termlist1  (cdr p))
     95        (do ((p termlist1)
    11496             (q termlist2))
    115             ((endp p)
    116              ;; Include remaining terms of termlist1
    117              (setf termlist1 (nconc p q)))
     97            ((endp q))
    11898          ;; Copy all initial terms of q greater than (lt p) into p       
    119           (do ((r q (cdr r)))
     99          (do ()
    120100              ((cond
    121                  ((endp r))
     101                 ((endp q))
    122102                 (t
    123103                  (multiple-value-bind
    124104                        (greater-p equal-p)
    125                       (lex> (lt r) (lt p))
     105                      (lex> (lt q) (lt p))
    126106                    (cond
    127107                      (greater-p
    128                        (push (pop r) p))
     108                       (psetf (cdr q) p
     109                              q (cdr q)
     110                              (cdr p) p))
    129111                      (equal-p
    130                        (setf (lc p) (add-to (lc p) (lc q)))))
     112                       (setf (lc p) (add-to (lc p) (lc q))
     113                             p (cdr p))))
    131114                    (not greater-p))))))))))
    132115  self)
Note: See TracChangeset for help on using the changeset viewer.