Changeset 2000 for branches

Timestamp:

2015-06-16T15:22:19-07:00 (9 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

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

branches/f4grobner/pol.lisp

@@ -100 +100 @@
 
 (defclass poly ()
-  ((termlist :initarg :termlist :accessor termlist)
-   (sugar    :initarg :sugar    :accessor sugar)
-   )
-  (:default-initargs :termlist nil :sugar -1))
-
-(defun make-poly-from-termlist (termlist &optional (sugar (termlist-sugar termlist)))
+  ((termlist :initarg :termlist :accessor termlist))
+  (:default-initargs :termlist nil))
+
+(defun make-poly-from-termlist (termlist)
   (make-instance 'poly :termlist termlist :sugar sugar))
 
 (defun make-poly-zero (&aux (termlist nil) (sugar -1))
-  (make-instance 'poly :termlist termlist :sugar sugar))
+  (make-instance 'poly :termlist termlist))
 
 (defun make-poly-variable (ring nvars pos &optional (power 1)
                            &aux
                              (termlist (list
-                                        (make-term-variable ring nvars pos power)))
-                             (sugar power))
-  (make-instance 'poly :termlist termlist :sugar sugar))
+                                        (make-term-variable ring nvars pos power))))
+  (make-instance 'poly :termlist termlist))
 
 (defun poly-unit (ring dimension
                   &aux
-                    (termlist (termlist-unit ring dimension))
-                    (sugar 0))
-  (make-instance 'poly :termlist termlist :sugar (termlist-sugar termlist)))
-
-
-(defmethod print-object ((poly poly) stream)
-  (princ (slot-value poly 'termlist)))
-
-(defmethod poly-termlist ((poly poly))
-  (slot-value poly 'termlist))
+                    (termlist (termlist-unit ring dimension)))
+  (make-instance 'poly :termlist termlist))
+
+
+(defmethod print-object ((self poly) stream)
+  (princ (slot-value self 'termlist)))
+
+(defmethod poly-termlist ((self poly))
+  (slot-value self 'termlist))
 
 (defmethod (setf poly-termlist) (new-value (poly poly))
   (setf (slot-value poly 'termlist) new-value))
 
-;; Leading term
-(defmacro poly-lt (p) `(car (poly-termlist ,p)))
-
-;; Second term
-(defmacro poly-second-lt (p) `(cadr (poly-termlist ,p)))
-
-;; Leading monomial
-(defmethod poly-lm ((poly poly)) 
-  (term-monom (poly-lt poly)))
-
-;; Second monomial
-(defmethod poly-second-lm ((poly poly))
-  (term-monom (poly-second-lt poly)))
-
-;; Leading coefficient
-(defmethod poly-lc ((poly poly))
-  (term-coeff (poly-lc poly)))
-
-;; Second coefficient
-(defmethod poly-second-lc ((poly poly))
-  (term-coeff (poly-second-lt poly)))
-
-;; Testing for a zero polynomial
-(defmethod poly-zerop ((poly poly)) 
-  (null (poly-termlist poly)))
-
-;; The number of terms
-(defmethod poly-length ((poly poly))
-  (length (poly-termlist p)))
-
-(defmethod poly-reset-sugar ((poly poly))
-  "(Re)sets the sugar of a polynomial P to the sugar of (POLY-TERMLIST P).
-Thus, the sugar is set to the maximum sugar of all monomials of P, or -1 
-if P is a zero polynomial."
-  (setf (poly-sugar poly) (termlist-sugar (poly-termlist poly)))
-  poly)
-
-(defun scalar-times-poly (ring c p)
-  "The scalar product of scalar C by a polynomial P. The sugar of the
-original polynomial becomes the sugar of the result."
-  (declare (type ring ring) (type poly p))
-  (make-poly-from-termlist (scalar-times-termlist ring c (poly-termlist p)) (poly-sugar p)))
-
-(defun scalar-times-poly-1 (ring c p)
-  "The scalar product of scalar C by a polynomial P, omitting the head term. The sugar of the
-original polynomial becomes the sugar of the result."
-  (declare (type ring ring) (type poly p))
-  (make-poly-from-termlist (scalar-times-termlist ring c (cdr (poly-termlist p))) (poly-sugar p)))
-
-(defun monom-times-poly (m p)
-  (declare (type monom m) (type poly p))
-  (make-poly-from-termlist 
-   (monom-times-termlist m (poly-termlist p))
-   (+ (poly-sugar p) (monom-sugar m))))
-
-(defun term-times-poly (ring term p)
-  (declare (type ring ring) (type term term) (type poly p))
-  (make-poly-from-termlist 
-   (term-times-termlist ring term (poly-termlist p))
-   (+ (poly-sugar p) (term-sugar term))))
-
-(defun poly-add (ring-and-order p q)
-  (declare (type ring-and-order ring-and-order) (type poly p q))
-  (make-poly-from-termlist 
-   (termlist-add ring-and-order 
-                 (poly-termlist p) 
-                 (poly-termlist q))
-   (max (poly-sugar p) (poly-sugar q))))
-
-(defun poly-sub (ring-and-order p q)
-  (declare (type ring-and-order ring-and-order) (type poly p q))
-  (make-poly-from-termlist 
-   (termlist-sub ring-and-order (poly-termlist p) (poly-termlist q))
-   (max (poly-sugar p) (poly-sugar q))))
-
-(defun poly-uminus (ring p)
-  (declare (type ring ring) (type poly p))
-  (make-poly-from-termlist 
-   (termlist-uminus ring (poly-termlist p))
-   (poly-sugar p)))
-
-(defun poly-mul (ring-and-order p q)
-  (declare (type ring-and-order ring-and-order) (type poly p q))
-  (make-poly-from-termlist
-   (termlist-mul ring-and-order (poly-termlist p) (poly-termlist q))
-   (+ (poly-sugar p) (poly-sugar q))))
-
-(defun poly-expt (ring-and-order p n)
-  (declare (type ring-and-order ring-and-order) (type poly p))
-  (make-poly-from-termlist (termlist-expt ring-and-order (poly-termlist p) n) (* n (poly-sugar p))))
-
-(defun poly-append (&rest plist)
-  (make-poly-from-termlist (apply #'append (mapcar #'poly-termlist plist))
-                           (apply #'max (mapcar #'poly-sugar plist))))
-
-(defun poly-nreverse (p)
-  "Destructively reverse the order of terms in polynomial P. Returns P"
-  (declare (type poly p))
-  (setf (poly-termlist p) (nreverse (poly-termlist p)))
-  p)
-
-(defun poly-reverse (p)
-  "Returns a copy of the polynomial P with terms in reverse order."
-  (declare (type poly p))
-  (make-poly-from-termlist (reverse (poly-termlist p))
-                           (poly-sugar p)))
-
-
-(defun poly-contract (p &optional (k 1))
-  (declare (type poly p))
-  (make-poly-from-termlist (termlist-contract (poly-termlist p) k)
-                           (poly-sugar p)))
-
-(defun poly-extend (p &optional (m (make-monom :dimension 1)))
-  (declare (type poly p))
-  (make-poly-from-termlist
-   (termlist-extend (poly-termlist p) m)
-   (+ (poly-sugar p) (monom-sugar m))))
-
-(defun poly-add-variables (p k)
-  (declare (type poly p))
-  (setf (poly-termlist p) (termlist-add-variables (poly-termlist p) k))
-  p)
-
-(defun poly-list-add-variables (plist k)
-  (mapcar #'(lambda (p) (poly-add-variables p k)) plist))
-
-(defun poly-standard-extension (plist &aux (k (length plist)))
-  "Calculate [U1*P1,U2*P2,...,UK*PK], where PLIST=[P1,P2,...,PK]."
-  (declare (list plist) (fixnum k))
-  (labels ((incf-power (g i)
-             (dolist (x (poly-termlist g))
-               (incf (monom-elt (term-monom x) i)))
-             (incf (poly-sugar g))))
-    (setf plist (poly-list-add-variables plist k))
-    (dotimes (i k plist)
-      (incf-power (nth i plist) i))))
-
-(defun saturation-extension (ring f plist 
-                             &aux 
-                               (k (length plist))
-                               (d (monom-dimension (poly-lm (car plist))))
-                               f-x plist-x)
-  "Calculate [F, U1*P1-1,U2*P2-1,...,UK*PK-1], where PLIST=[P1,P2,...,PK]."
-  (declare (type ring ring))
-  (setf f-x (poly-list-add-variables f k)
-        plist-x (mapcar #'(lambda (x)
-                            (setf (poly-termlist x)
-                                  (nconc (poly-termlist x)
-                                         (list (make-term :monom (make-monom :dimension d)
-                                                          :coeff (funcall (ring-uminus ring) 
-                                                                          (funcall (ring-unit ring)))))))
-                            x)
-                        (poly-standard-extension plist)))
-  (append f-x plist-x))
-
-
-(defun polysaturation-extension (ring f plist 
-                                 &aux 
-                                   (k (length plist))
-                                   (d (+ k (monom-dimension (poly-lm (car plist)))))
-                                   ;; Add k variables to f
-                                   (f (poly-list-add-variables f k))
-                                   ;; Set PLIST to [U1*P1,U2*P2,...,UK*PK]
-                                   (plist (apply #'poly-append (poly-standard-extension plist))))
-  "Calculate [F, U1*P1+U2*P2+...+UK*PK-1], where PLIST=[P1,P2,...,PK]. It destructively modifies F."
-  ;; Add -1 as the last term
-  (declare (type ring ring))
-  (setf (cdr (last (poly-termlist plist)))
-        (list (make-term :monom (make-monom :dimension d)
-                         :coeff (funcall (ring-uminus ring) (funcall (ring-unit ring))))))
-  (append f (list plist)))
-
-(defun saturation-extension-1 (ring f p) 
-  "Calculate [F, U*P-1]. It destructively modifies F."
-  (declare (type ring ring))
-  (polysaturation-extension ring f (list p)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Evaluation of polynomial (prefix) expressions
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmethod scalar->poly ((ring ring) expr vars)
-  "Coerce an element of the coefficient ring to a constant polynomial."
-  ;; Modular arithmetic handler by rat
-  (make-poly-from-termlist (list (make-term :monom (make-monom :dimension (length vars))
-                                            :coeff (funcall (ring-parse ring) expr)))
-                           0))
-
-(defun poly-eval (expr vars 
-                  &optional 
-                    (ring +ring-of-integers+) 
-                    (order #'lex>)
-                    (list-marker :[)
-                  &aux 
-                    (ring-and-order (make-ring-and-order :ring ring :order order)))
+(defmethod poly-add ((p poly) (q poly)))
+
+(defmethod poly-sub ((p poly) (q poly)))
+
+(defmethod poly-uminus ((self poly)))
+
+(defmethod poly-mul ((p poly) (poly q)))
+
+(defmethod poly-expt ((self poly) n))
+
+(defmethod initialize-instance :after ((self poly) expr vars)
   "Evaluate Lisp form EXPR to a polynomial or a list of polynomials in
 variables VARS. Return the resulting polynomial or list of
@@ -339 +148 @@
 of polynomials in internal form. A similar operation in another computer
 algebra system could be called 'expand' or so."
-  (declare (type ring ring))
-  (labels ((p-eval (arg) (poly-eval arg vars ring order))
-           (p-eval-scalar (arg) (poly-eval-scalar arg))
-           (p-eval-list (args) (mapcar #'p-eval args))
-           (p-add (x y) (poly-add ring-and-order x y)))
     (cond
       ((null expr) (error "Empty expression"))