- Timestamp:
- 2015-06-16T15:22:19-07:00 (10 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/f4grobner/pol.lisp
r1999 r2000 100 100 101 101 (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) 108 106 (make-instance 'poly :termlist termlist :sugar sugar)) 109 107 110 108 (defun make-poly-zero (&aux (termlist nil) (sugar -1)) 111 (make-instance 'poly :termlist termlist :sugar sugar))109 (make-instance 'poly :termlist termlist)) 112 110 113 111 (defun make-poly-variable (ring nvars pos &optional (power 1) 114 112 &aux 115 113 (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)) 119 116 120 117 (defun poly-unit (ring dimension 121 118 &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)) 132 128 133 129 (defmethod (setf poly-termlist) (new-value (poly poly)) 134 130 (setf (slot-value poly 'termlist) new-value)) 135 131 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) 334 143 "Evaluate Lisp form EXPR to a polynomial or a list of polynomials in 335 144 variables VARS. Return the resulting polynomial or list of … … 339 148 of polynomials in internal form. A similar operation in another computer 340 149 algebra 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)))346 150 (cond 347 151 ((null expr) (error "Empty expression"))
Note:
See TracChangeset
for help on using the changeset viewer.