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 2000 for branches/f4grobner


Ignore:
Timestamp:
2015-06-16T15:22:19-07:00 (10 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/pol.lisp

    r1999 r2000  
    100100
    101101(defclass poly ()
    102   ((termlist :initarg :termlist :accessor termlist)
    103    (sugar    :initarg :sugar    :accessor sugar)
    104    )
    105   (:default-initargs :termlist nil :sugar -1))
    106 
    107 (defun make-poly-from-termlist (termlist &optional (sugar (termlist-sugar termlist)))
     102  ((termlist :initarg :termlist :accessor termlist))
     103  (:default-initargs :termlist nil))
     104
     105(defun make-poly-from-termlist (termlist)
    108106  (make-instance 'poly :termlist termlist :sugar sugar))
    109107
    110108(defun make-poly-zero (&aux (termlist nil) (sugar -1))
    111   (make-instance 'poly :termlist termlist :sugar sugar))
     109  (make-instance 'poly :termlist termlist))
    112110
    113111(defun make-poly-variable (ring nvars pos &optional (power 1)
    114112                           &aux
    115113                             (termlist (list
    116                                         (make-term-variable ring nvars pos power)))
    117                              (sugar power))
    118   (make-instance 'poly :termlist termlist :sugar sugar))
     114                                        (make-term-variable ring nvars pos power))))
     115  (make-instance 'poly :termlist termlist))
    119116
    120117(defun poly-unit (ring dimension
    121118                  &aux
    122                     (termlist (termlist-unit ring dimension))
    123                     (sugar 0))
    124   (make-instance 'poly :termlist termlist :sugar (termlist-sugar termlist)))
    125 
    126 
    127 (defmethod print-object ((poly poly) stream)
    128   (princ (slot-value poly 'termlist)))
    129 
    130 (defmethod poly-termlist ((poly poly))
    131   (slot-value poly 'termlist))
     119                    (termlist (termlist-unit ring dimension)))
     120  (make-instance 'poly :termlist termlist))
     121
     122
     123(defmethod print-object ((self poly) stream)
     124  (princ (slot-value self 'termlist)))
     125
     126(defmethod poly-termlist ((self poly))
     127  (slot-value self 'termlist))
    132128
    133129(defmethod (setf poly-termlist) (new-value (poly poly))
    134130  (setf (slot-value poly 'termlist) new-value))
    135131
    136 ;; Leading term
    137 (defmacro poly-lt (p) `(car (poly-termlist ,p)))
    138 
    139 ;; Second term
    140 (defmacro poly-second-lt (p) `(cadr (poly-termlist ,p)))
    141 
    142 ;; Leading monomial
    143 (defmethod poly-lm ((poly poly))
    144   (term-monom (poly-lt poly)))
    145 
    146 ;; Second monomial
    147 (defmethod poly-second-lm ((poly poly))
    148   (term-monom (poly-second-lt poly)))
    149 
    150 ;; Leading coefficient
    151 (defmethod poly-lc ((poly poly))
    152   (term-coeff (poly-lc poly)))
    153 
    154 ;; Second coefficient
    155 (defmethod poly-second-lc ((poly poly))
    156   (term-coeff (poly-second-lt poly)))
    157 
    158 ;; Testing for a zero polynomial
    159 (defmethod poly-zerop ((poly poly))
    160   (null (poly-termlist poly)))
    161 
    162 ;; The number of terms
    163 (defmethod poly-length ((poly poly))
    164   (length (poly-termlist p)))
    165 
    166 (defmethod poly-reset-sugar ((poly poly))
    167   "(Re)sets the sugar of a polynomial P to the sugar of (POLY-TERMLIST P).
    168 Thus, the sugar is set to the maximum sugar of all monomials of P, or -1
    169 if P is a zero polynomial."
    170   (setf (poly-sugar poly) (termlist-sugar (poly-termlist poly)))
    171   poly)
    172 
    173 (defun scalar-times-poly (ring c p)
    174   "The scalar product of scalar C by a polynomial P. The sugar of the
    175 original polynomial becomes the sugar of the result."
    176   (declare (type ring ring) (type poly p))
    177   (make-poly-from-termlist (scalar-times-termlist ring c (poly-termlist p)) (poly-sugar p)))
    178 
    179 (defun scalar-times-poly-1 (ring c p)
    180   "The scalar product of scalar C by a polynomial P, omitting the head term. The sugar of the
    181 original polynomial becomes the sugar of the result."
    182   (declare (type ring ring) (type poly p))
    183   (make-poly-from-termlist (scalar-times-termlist ring c (cdr (poly-termlist p))) (poly-sugar p)))
    184 
    185 (defun monom-times-poly (m p)
    186   (declare (type monom m) (type poly p))
    187   (make-poly-from-termlist
    188    (monom-times-termlist m (poly-termlist p))
    189    (+ (poly-sugar p) (monom-sugar m))))
    190 
    191 (defun term-times-poly (ring term p)
    192   (declare (type ring ring) (type term term) (type poly p))
    193   (make-poly-from-termlist
    194    (term-times-termlist ring term (poly-termlist p))
    195    (+ (poly-sugar p) (term-sugar term))))
    196 
    197 (defun poly-add (ring-and-order p q)
    198   (declare (type ring-and-order ring-and-order) (type poly p q))
    199   (make-poly-from-termlist
    200    (termlist-add ring-and-order
    201                  (poly-termlist p)
    202                  (poly-termlist q))
    203    (max (poly-sugar p) (poly-sugar q))))
    204 
    205 (defun poly-sub (ring-and-order p q)
    206   (declare (type ring-and-order ring-and-order) (type poly p q))
    207   (make-poly-from-termlist
    208    (termlist-sub ring-and-order (poly-termlist p) (poly-termlist q))
    209    (max (poly-sugar p) (poly-sugar q))))
    210 
    211 (defun poly-uminus (ring p)
    212   (declare (type ring ring) (type poly p))
    213   (make-poly-from-termlist
    214    (termlist-uminus ring (poly-termlist p))
    215    (poly-sugar p)))
    216 
    217 (defun poly-mul (ring-and-order p q)
    218   (declare (type ring-and-order ring-and-order) (type poly p q))
    219   (make-poly-from-termlist
    220    (termlist-mul ring-and-order (poly-termlist p) (poly-termlist q))
    221    (+ (poly-sugar p) (poly-sugar q))))
    222 
    223 (defun poly-expt (ring-and-order p n)
    224   (declare (type ring-and-order ring-and-order) (type poly p))
    225   (make-poly-from-termlist (termlist-expt ring-and-order (poly-termlist p) n) (* n (poly-sugar p))))
    226 
    227 (defun poly-append (&rest plist)
    228   (make-poly-from-termlist (apply #'append (mapcar #'poly-termlist plist))
    229                            (apply #'max (mapcar #'poly-sugar plist))))
    230 
    231 (defun poly-nreverse (p)
    232   "Destructively reverse the order of terms in polynomial P. Returns P"
    233   (declare (type poly p))
    234   (setf (poly-termlist p) (nreverse (poly-termlist p)))
    235   p)
    236 
    237 (defun poly-reverse (p)
    238   "Returns a copy of the polynomial P with terms in reverse order."
    239   (declare (type poly p))
    240   (make-poly-from-termlist (reverse (poly-termlist p))
    241                            (poly-sugar p)))
    242 
    243 
    244 (defun poly-contract (p &optional (k 1))
    245   (declare (type poly p))
    246   (make-poly-from-termlist (termlist-contract (poly-termlist p) k)
    247                            (poly-sugar p)))
    248 
    249 (defun poly-extend (p &optional (m (make-monom :dimension 1)))
    250   (declare (type poly p))
    251   (make-poly-from-termlist
    252    (termlist-extend (poly-termlist p) m)
    253    (+ (poly-sugar p) (monom-sugar m))))
    254 
    255 (defun poly-add-variables (p k)
    256   (declare (type poly p))
    257   (setf (poly-termlist p) (termlist-add-variables (poly-termlist p) k))
    258   p)
    259 
    260 (defun poly-list-add-variables (plist k)
    261   (mapcar #'(lambda (p) (poly-add-variables p k)) plist))
    262 
    263 (defun poly-standard-extension (plist &aux (k (length plist)))
    264   "Calculate [U1*P1,U2*P2,...,UK*PK], where PLIST=[P1,P2,...,PK]."
    265   (declare (list plist) (fixnum k))
    266   (labels ((incf-power (g i)
    267              (dolist (x (poly-termlist g))
    268                (incf (monom-elt (term-monom x) i)))
    269              (incf (poly-sugar g))))
    270     (setf plist (poly-list-add-variables plist k))
    271     (dotimes (i k plist)
    272       (incf-power (nth i plist) i))))
    273 
    274 (defun saturation-extension (ring f plist
    275                              &aux
    276                                (k (length plist))
    277                                (d (monom-dimension (poly-lm (car plist))))
    278                                f-x plist-x)
    279   "Calculate [F, U1*P1-1,U2*P2-1,...,UK*PK-1], where PLIST=[P1,P2,...,PK]."
    280   (declare (type ring ring))
    281   (setf f-x (poly-list-add-variables f k)
    282         plist-x (mapcar #'(lambda (x)
    283                             (setf (poly-termlist x)
    284                                   (nconc (poly-termlist x)
    285                                          (list (make-term :monom (make-monom :dimension d)
    286                                                           :coeff (funcall (ring-uminus ring)
    287                                                                           (funcall (ring-unit ring)))))))
    288                             x)
    289                         (poly-standard-extension plist)))
    290   (append f-x plist-x))
    291 
    292 
    293 (defun polysaturation-extension (ring f plist
    294                                  &aux
    295                                    (k (length plist))
    296                                    (d (+ k (monom-dimension (poly-lm (car plist)))))
    297                                    ;; Add k variables to f
    298                                    (f (poly-list-add-variables f k))
    299                                    ;; Set PLIST to [U1*P1,U2*P2,...,UK*PK]
    300                                    (plist (apply #'poly-append (poly-standard-extension plist))))
    301   "Calculate [F, U1*P1+U2*P2+...+UK*PK-1], where PLIST=[P1,P2,...,PK]. It destructively modifies F."
    302   ;; Add -1 as the last term
    303   (declare (type ring ring))
    304   (setf (cdr (last (poly-termlist plist)))
    305         (list (make-term :monom (make-monom :dimension d)
    306                          :coeff (funcall (ring-uminus ring) (funcall (ring-unit ring))))))
    307   (append f (list plist)))
    308 
    309 (defun saturation-extension-1 (ring f p)
    310   "Calculate [F, U*P-1]. It destructively modifies F."
    311   (declare (type ring ring))
    312   (polysaturation-extension ring f (list p)))
    313 
    314 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    315 ;;
    316 ;; Evaluation of polynomial (prefix) expressions
    317 ;;
    318 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    319 
    320 (defmethod scalar->poly ((ring ring) expr vars)
    321   "Coerce an element of the coefficient ring to a constant polynomial."
    322   ;; Modular arithmetic handler by rat
    323   (make-poly-from-termlist (list (make-term :monom (make-monom :dimension (length vars))
    324                                             :coeff (funcall (ring-parse ring) expr)))
    325                            0))
    326 
    327 (defun poly-eval (expr vars
    328                   &optional
    329                     (ring +ring-of-integers+)
    330                     (order #'lex>)
    331                     (list-marker :[)
    332                   &aux
    333                     (ring-and-order (make-ring-and-order :ring ring :order order)))
     132(defmethod poly-add ((p poly) (q poly)))
     133
     134(defmethod poly-sub ((p poly) (q poly)))
     135
     136(defmethod poly-uminus ((self poly)))
     137
     138(defmethod poly-mul ((p poly) (poly q)))
     139
     140(defmethod poly-expt ((self poly) n))
     141
     142(defmethod initialize-instance :after ((self poly) expr vars)
    334143  "Evaluate Lisp form EXPR to a polynomial or a list of polynomials in
    335144variables VARS. Return the resulting polynomial or list of
     
    339148of polynomials in internal form. A similar operation in another computer
    340149algebra system could be called 'expand' or so."
    341   (declare (type ring ring))
    342   (labels ((p-eval (arg) (poly-eval arg vars ring order))
    343            (p-eval-scalar (arg) (poly-eval-scalar arg))
    344            (p-eval-list (args) (mapcar #'p-eval args))
    345            (p-add (x y) (poly-add ring-and-order x y)))
    346150    (cond
    347151      ((null expr) (error "Empty expression"))
Note: See TracChangeset for help on using the changeset viewer.