| 1 | ;;----------------------------------------------------------------
|
|---|
| 2 | ;; File: polynomial.lisp
|
|---|
| 3 | ;;----------------------------------------------------------------
|
|---|
| 4 | ;;
|
|---|
| 5 | ;; Author: Marek Rychlik (rychlik@u.arizona.edu)
|
|---|
| 6 | ;; Date: Thu Aug 27 09:41:24 2015
|
|---|
| 7 | ;; Copying: (C) Marek Rychlik, 2010. All rights reserved.
|
|---|
| 8 | ;;
|
|---|
| 9 | ;;----------------------------------------------------------------
|
|---|
| 10 | ;;; -*- Mode: Lisp -*-
|
|---|
| 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 12 | ;;;
|
|---|
| 13 | ;;; Copyright (C) 1999, 2002, 2009, 2015 Marek Rychlik <rychlik@u.arizona.edu>
|
|---|
| 14 | ;;;
|
|---|
| 15 | ;;; This program is free software; you can redistribute it and/or modify
|
|---|
| 16 | ;;; it under the terms of the GNU General Public License as published by
|
|---|
| 17 | ;;; the Free Software Foundation; either version 2 of the License, or
|
|---|
| 18 | ;;; (at your option) any later version.
|
|---|
| 19 | ;;;
|
|---|
| 20 | ;;; This program is distributed in the hope that it will be useful,
|
|---|
| 21 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|---|
| 22 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|---|
| 23 | ;;; GNU General Public License for more details.
|
|---|
| 24 | ;;;
|
|---|
| 25 | ;;; You should have received a copy of the GNU General Public License
|
|---|
| 26 | ;;; along with this program; if not, write to the Free Software
|
|---|
| 27 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
|---|
| 28 | ;;;
|
|---|
| 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 30 |
|
|---|
| 31 | (defpackage "POLYNOMIAL"
|
|---|
| 32 | (:use :cl :utils :monom)
|
|---|
| 33 | (:export "POLY"
|
|---|
| 34 | "POLY-DIMENSION"
|
|---|
| 35 | "POLY-TERMLIST"
|
|---|
| 36 | "POLY-TERM-ORDER"
|
|---|
| 37 | "CHANGE-TERM-ORDER"
|
|---|
| 38 | "STANDARD-EXTENSION"
|
|---|
| 39 | "STANDARD-EXTENSION-1"
|
|---|
| 40 | "STANDARD-SUM"
|
|---|
| 41 | "SATURATION-EXTENSION"
|
|---|
| 42 | "ALIST->POLY")
|
|---|
| 43 | (:documentation "Implements polynomials. A polynomial is essentially
|
|---|
| 44 | a mapping of monomials of the same degree to coefficients. The
|
|---|
| 45 | momomials are ordered according to a monomial order."))
|
|---|
| 46 |
|
|---|
| 47 | (in-package :polynomial)
|
|---|
| 48 |
|
|---|
| 49 | (proclaim '(optimize (speed 3) (space 0) (safety 0) (debug 0)))
|
|---|
| 50 |
|
|---|
| 51 | (defclass poly ()
|
|---|
| 52 | ((dimension :initform nil
|
|---|
| 53 | :initarg :dimension
|
|---|
| 54 | :accessor poly-dimension
|
|---|
| 55 | :documentation "Shared dimension of all terms, the number of variables")
|
|---|
| 56 | (termlist :initform nil :initarg :termlist :accessor poly-termlist
|
|---|
| 57 | :documentation "List of terms.")
|
|---|
| 58 | (order :initform #'lex> :initarg :order :accessor poly-term-order
|
|---|
| 59 | :documentation "Monomial/term order."))
|
|---|
| 60 | (:default-initargs :dimension nil :termlist nil :order #'lex>)
|
|---|
| 61 | (:documentation "A polynomial with a list of terms TERMLIST, ordered
|
|---|
| 62 | according to term order ORDER, which defaults to LEX>."))
|
|---|
| 63 |
|
|---|
| 64 | (defmethod print-object ((self poly) stream)
|
|---|
| 65 | (print-unreadable-object (self stream :type t :identity t)
|
|---|
| 66 | (with-accessors ((dimension poly-dimension)
|
|---|
| 67 | (termlist poly-termlist)
|
|---|
| 68 | (order poly-term-order))
|
|---|
| 69 | self
|
|---|
| 70 | (format stream "DIMENSION=~A TERMLIST=~A ORDER=~A"
|
|---|
| 71 | dimension termlist order))))
|
|---|
| 72 |
|
|---|
| 73 | (defgeneric change-term-order (self other)
|
|---|
| 74 | (:documentation "Change term order of SELF to the term order of OTHER.")
|
|---|
| 75 | (:method ((self poly) (other poly))
|
|---|
| 76 | (unless (eq (poly-term-order self) (poly-term-order other))
|
|---|
| 77 | (setf (poly-termlist self) (sort (poly-termlist self) (poly-term-order other))
|
|---|
| 78 | (poly-term-order self) (poly-term-order other)))
|
|---|
| 79 | self))
|
|---|
| 80 |
|
|---|
| 81 | (defun alist->poly (alist &aux (poly (make-instance 'poly)))
|
|---|
| 82 | "It reads polynomial from an alist formatted as ( ... (exponents . coeff) ...).
|
|---|
| 83 | It can be used to enter simple polynomials by hand, e.g the polynomial
|
|---|
| 84 | in two variables, X and Y, given in standard notation as:
|
|---|
| 85 |
|
|---|
| 86 | 3*X^2*Y^3+2*Y+7
|
|---|
| 87 |
|
|---|
| 88 | can be entered as
|
|---|
| 89 | (ALIST->POLY '(((2 3) . 3) ((0 1) . 2) ((0 0) . 7))).
|
|---|
| 90 |
|
|---|
| 91 | NOTE: The primary use is for low-level debugging of the package."
|
|---|
| 92 | (dolist (x alist poly)
|
|---|
| 93 | (poly-insert-term poly (make-instance 'monom :exponents (car x)) (cdr x))))
|
|---|
| 94 |
|
|---|
| 95 |
|
|---|
| 96 | (defmethod update-instance-for-different-class :after ((old term) (new poly) &key)
|
|---|
| 97 | "Converts OLD of class TERM to a NEW of class POLY, by making it into a 1-element TERMLIST."
|
|---|
| 98 | (reinitialize-instance new
|
|---|
| 99 | :dimension (monom-dimension old)
|
|---|
| 100 | :termlist (list old)))
|
|---|
| 101 |
|
|---|
| 102 | (defmethod update-instance-for-different-class :after ((old monom) (new poly) &key)
|
|---|
| 103 | "Converts OLD of class MONOM to a NEW of class POLY, by making it into a 1-element TERMLIST."
|
|---|
| 104 | (reinitialize-instance new
|
|---|
| 105 | :dimension (monom-dimension old)
|
|---|
| 106 | :termlist (list (cons monom 1))))
|
|---|
| 107 |
|
|---|
| 108 | (defmethod r-equalp ((self poly) (other poly))
|
|---|
| 109 | "POLY instances are R-EQUALP if they have the same
|
|---|
| 110 | order and if all terms are R-EQUALP."
|
|---|
| 111 | (and (every #'r-equalp (poly-termlist self) (poly-termlist other))
|
|---|
| 112 | (eq (poly-term-order self) (poly-term-order other))))
|
|---|
| 113 |
|
|---|
| 114 | (defgeneric poly-insert-term (self monom coeff)
|
|---|
| 115 | (:method ((self poly) (monom monom) coeff)
|
|---|
| 116 | (cond ((null (poly-dimension self))
|
|---|
| 117 | (setf (poly-dimension self) (monom-dimension monom)))
|
|---|
| 118 | (t (assert (= (poly-dimension self) (monom-dimension monom)))))
|
|---|
| 119 | (push (cons monom coeff) (poly-termlist self))
|
|---|
| 120 | self))
|
|---|
| 121 |
|
|---|
| 122 | (defgeneric poly-append-term (self monom coeff)
|
|---|
| 123 | (:method ((self poly) (monom monom) coeff)
|
|---|
| 124 | (cond ((null (poly-dimension self))
|
|---|
| 125 | (setf (poly-dimension self) (monom-dimension monom)))
|
|---|
| 126 | (t (assert (= (poly-dimension self) (monom-dimension monom)))))
|
|---|
| 127 | (setf (cdr (last (poly-termlist self))) (list (cons monom coeff)))
|
|---|
| 128 | self))
|
|---|
| 129 |
|
|---|
| 130 | ;; Leading term
|
|---|
| 131 | (defgeneric leading-term (object)
|
|---|
| 132 | (:method ((self poly))
|
|---|
| 133 | (car (poly-termlist self)))
|
|---|
| 134 | (:documentation "The leading term of a polynomial, or NIL for zero polynomial."))
|
|---|
| 135 |
|
|---|
| 136 | ;; Second term
|
|---|
| 137 | (defgeneric second-leading-term (object)
|
|---|
| 138 | (:method ((self poly))
|
|---|
| 139 | (cadar (poly-termlist self)))
|
|---|
| 140 | (:documentation "The second leading term of a polynomial, or NIL for a polynomial with at most one term."))
|
|---|
| 141 |
|
|---|
| 142 | ;; Leading coefficient
|
|---|
| 143 | (defgeneric leading-coefficient (object)
|
|---|
| 144 | (:method ((self poly))
|
|---|
| 145 | (scalar-coeff (leading-term self)))
|
|---|
| 146 | (:documentation "The leading coefficient of a polynomial. It signals error for a zero polynomial."))
|
|---|
| 147 |
|
|---|
| 148 | ;; Second coefficient
|
|---|
| 149 | (defgeneric second-leading-coefficient (object)
|
|---|
| 150 | (:method ((self poly))
|
|---|
| 151 | (scalar-coeff (second-leading-term self)))
|
|---|
| 152 | (:documentation "The second leading coefficient of a polynomial. It
|
|---|
| 153 | signals error for a polynomial with at most one term."))
|
|---|
| 154 |
|
|---|
| 155 | ;; Testing for a zero polynomial
|
|---|
| 156 | (defmethod r-zerop ((self poly))
|
|---|
| 157 | (null (poly-termlist self)))
|
|---|
| 158 |
|
|---|
| 159 | ;; The number of terms
|
|---|
| 160 | (defmethod r-length ((self poly))
|
|---|
| 161 | (length (poly-termlist self)))
|
|---|
| 162 |
|
|---|
| 163 | (defmethod multiply-by ((self poly) (other monom))
|
|---|
| 164 | (mapc #'(lambda (term) (multiply-by term other))
|
|---|
| 165 | (poly-termlist self))
|
|---|
| 166 | self)
|
|---|
| 167 |
|
|---|
| 168 | (defmethod multiply-by ((self poly) (other term))
|
|---|
| 169 | (mapc #'(lambda (term) (multiply-by term other))
|
|---|
| 170 | (poly-termlist self))
|
|---|
| 171 | self)
|
|---|
| 172 |
|
|---|
| 173 | (defmethod multiply-by ((self poly) (other scalar))
|
|---|
| 174 | (mapc #'(lambda (term) (multiply-by term other))
|
|---|
| 175 | (poly-termlist self))
|
|---|
| 176 | self)
|
|---|
| 177 |
|
|---|
| 178 |
|
|---|
| 179 | (defmacro fast-add/subtract (p q order-fn add/subtract-fn uminus-fn)
|
|---|
| 180 | "Return an expression which will efficiently adds/subtracts two
|
|---|
| 181 | polynomials, P and Q. The addition/subtraction of coefficients is
|
|---|
| 182 | performed by calling ADD/SUBTRACT-METHOD-NAME. If UMINUS-METHOD-NAME
|
|---|
| 183 | is supplied, it is used to negate the coefficients of Q which do not
|
|---|
| 184 | have a corresponding coefficient in P. The code implements an
|
|---|
| 185 | efficient algorithm to add two polynomials represented as sorted lists
|
|---|
| 186 | of terms. The code destroys both arguments, reusing the terms to build
|
|---|
| 187 | the result."
|
|---|
| 188 | `(macrolet ((lc (x) `(scalar-coeff (car ,x))))
|
|---|
| 189 | (do ((p ,p)
|
|---|
| 190 | (q ,q)
|
|---|
| 191 | r)
|
|---|
| 192 | ((or (endp p) (endp q))
|
|---|
| 193 | ;; NOTE: R contains the result in reverse order. Can it
|
|---|
| 194 | ;; be more efficient to produce the terms in correct order?
|
|---|
| 195 | (unless (endp q)
|
|---|
| 196 | ;; Upon subtraction, we must change the sign of
|
|---|
| 197 | ;; all coefficients in q
|
|---|
| 198 | ,@(when uminus-fn
|
|---|
| 199 | `((mapc #'(lambda (x) (setf x (funcall ,uminus-fn x))) q)))
|
|---|
| 200 | (setf r (nreconc r q)))
|
|---|
| 201 | r)
|
|---|
| 202 | (multiple-value-bind
|
|---|
| 203 | (greater-p equal-p)
|
|---|
| 204 | (funcall ,order-fn (car p) (car q))
|
|---|
| 205 | (cond
|
|---|
| 206 | (greater-p
|
|---|
| 207 | (rotatef (cdr p) r p)
|
|---|
| 208 | )
|
|---|
| 209 | (equal-p
|
|---|
| 210 | (let ((s (funcall ,add/subtract-fn (lc p) (lc q))))
|
|---|
| 211 | (cond
|
|---|
| 212 | ((r-zerop s)
|
|---|
| 213 | (setf p (cdr p))
|
|---|
| 214 | )
|
|---|
| 215 | (t
|
|---|
| 216 | (setf (lc p) s)
|
|---|
| 217 | (rotatef (cdr p) r p))))
|
|---|
| 218 | (setf q (cdr q))
|
|---|
| 219 | )
|
|---|
| 220 | (t
|
|---|
| 221 | ;;Negate the term of Q if UMINUS provided, signallig
|
|---|
| 222 | ;;that we are doing subtraction
|
|---|
| 223 | ,(when uminus-fn
|
|---|
| 224 | `(setf (lc q) (funcall ,uminus-fn (lc q))))
|
|---|
| 225 | (rotatef (cdr q) r q)))))))
|
|---|
| 226 |
|
|---|
| 227 |
|
|---|
| 228 | (defmacro def-add/subtract-method (add/subtract-method-name
|
|---|
| 229 | uminus-method-name
|
|---|
| 230 | &optional
|
|---|
| 231 | (doc-string nil doc-string-supplied-p))
|
|---|
| 232 | "This macro avoids code duplication for two similar operations: ADD-TO and SUBTRACT-FROM."
|
|---|
| 233 | `(defmethod ,add/subtract-method-name ((self poly) (other poly))
|
|---|
| 234 | ,@(when doc-string-supplied-p `(,doc-string))
|
|---|
| 235 | ;; Ensure orders are compatible
|
|---|
| 236 | (change-term-order other self)
|
|---|
| 237 | (setf (poly-termlist self) (fast-add/subtract
|
|---|
| 238 | (poly-termlist self) (poly-termlist other)
|
|---|
| 239 | (poly-term-order self)
|
|---|
| 240 | #',add/subtract-method-name
|
|---|
| 241 | ,(when uminus-method-name `(function ,uminus-method-name))))
|
|---|
| 242 | self))
|
|---|
| 243 |
|
|---|
| 244 | (eval-when (:compile-toplevel :load-toplevel :execute)
|
|---|
| 245 |
|
|---|
| 246 | (def-add/subtract-method add-to nil
|
|---|
| 247 | "Adds to polynomial SELF another polynomial OTHER.
|
|---|
| 248 | This operation destructively modifies both polynomials.
|
|---|
| 249 | The result is stored in SELF. This implementation does
|
|---|
| 250 | no consing, entirely reusing the sells of SELF and OTHER.")
|
|---|
| 251 |
|
|---|
| 252 | (def-add/subtract-method subtract-from unary-minus
|
|---|
| 253 | "Subtracts from polynomial SELF another polynomial OTHER.
|
|---|
| 254 | This operation destructively modifies both polynomials.
|
|---|
| 255 | The result is stored in SELF. This implementation does
|
|---|
| 256 | no consing, entirely reusing the sells of SELF and OTHER.")
|
|---|
| 257 | )
|
|---|
| 258 |
|
|---|
| 259 | (defmethod unary-minus ((self poly))
|
|---|
| 260 | "Destructively modifies the coefficients of the polynomial SELF,
|
|---|
| 261 | by changing their sign."
|
|---|
| 262 | (mapc #'unary-minus (poly-termlist self))
|
|---|
| 263 | self)
|
|---|
| 264 |
|
|---|
| 265 | (defun add-termlists (p q order-fn)
|
|---|
| 266 | "Destructively adds two termlists P and Q ordered according to ORDER-FN."
|
|---|
| 267 | (fast-add/subtract p q order-fn #'add-to nil))
|
|---|
| 268 |
|
|---|
| 269 | (defmacro multiply-term-by-termlist-dropping-zeros (term termlist
|
|---|
| 270 | &optional (reverse-arg-order-P nil))
|
|---|
| 271 | "Multiplies term TERM by a list of term, TERMLIST.
|
|---|
| 272 | Takes into accound divisors of zero in the ring, by
|
|---|
| 273 | deleting zero terms. Optionally, if REVERSE-ARG-ORDER-P
|
|---|
| 274 | is T, change the order of arguments; this may be important
|
|---|
| 275 | if we extend the package to non-commutative rings."
|
|---|
| 276 | `(mapcan #'(lambda (other-term)
|
|---|
| 277 | (let ((prod (r*
|
|---|
| 278 | ,@(cond
|
|---|
| 279 | (reverse-arg-order-p
|
|---|
| 280 | `(other-term ,term))
|
|---|
| 281 | (t
|
|---|
| 282 | `(,term other-term))))))
|
|---|
| 283 | (cond
|
|---|
| 284 | ((r-zerop prod) nil)
|
|---|
| 285 | (t (list prod)))))
|
|---|
| 286 | ,termlist))
|
|---|
| 287 |
|
|---|
| 288 | (defun multiply-termlists (p q order-fn)
|
|---|
| 289 | "A version of polynomial multiplication, operating
|
|---|
| 290 | directly on termlists."
|
|---|
| 291 | (cond
|
|---|
| 292 | ((or (endp p) (endp q))
|
|---|
| 293 | ;;p or q is 0 (represented by NIL)
|
|---|
| 294 | nil)
|
|---|
| 295 | ;; If p= p0+p1 and q=q0+q1 then p*q=p0*q0+p0*q1+p1*q
|
|---|
| 296 | ((endp (cdr p))
|
|---|
| 297 | (multiply-term-by-termlist-dropping-zeros (car p) q))
|
|---|
| 298 | ((endp (cdr q))
|
|---|
| 299 | (multiply-term-by-termlist-dropping-zeros (car q) p t))
|
|---|
| 300 | (t
|
|---|
| 301 | (cons (r* (car p) (car q))
|
|---|
| 302 | (add-termlists
|
|---|
| 303 | (multiply-term-by-termlist-dropping-zeros (car p) (cdr q))
|
|---|
| 304 | (multiply-termlists (cdr p) q order-fn)
|
|---|
| 305 | order-fn)))))
|
|---|
| 306 |
|
|---|
| 307 | (defmethod multiply-by ((self poly) (other poly))
|
|---|
| 308 | (change-term-order other self)
|
|---|
| 309 | (setf (poly-termlist self) (multiply-termlists (poly-termlist self)
|
|---|
| 310 | (poly-termlist other)
|
|---|
| 311 | (poly-term-order self)))
|
|---|
| 312 | self)
|
|---|
| 313 |
|
|---|
| 314 | (defmethod r+ ((poly1 poly) poly2)
|
|---|
| 315 | "Non-destructively add POLY1 by POLY2."
|
|---|
| 316 | (add-to (copy-instance POLY1) (change-class (copy-instance POLY2) 'poly)))
|
|---|
| 317 |
|
|---|
| 318 | (defmethod r- ((minuend poly) &rest subtrahends)
|
|---|
| 319 | "Non-destructively subtract MINUEND and SUBTRAHENDS."
|
|---|
| 320 | (subtract-from (copy-instance minuend)
|
|---|
| 321 | (change-class (reduce #'r+ subtrahends) 'poly)))
|
|---|
| 322 |
|
|---|
| 323 | (defmethod r+ ((poly1 term) poly2)
|
|---|
| 324 | "Non-destructively add POLY1 by POLY2."
|
|---|
| 325 | (add-to (change-class (copy-instance poly1) 'poly)
|
|---|
| 326 | (change-class (copy-instance poly2) 'poly)))
|
|---|
| 327 |
|
|---|
| 328 | (defmethod r- ((minuend term) &rest subtrahends)
|
|---|
| 329 | "Non-destructively subtract MINUEND and SUBTRAHENDS."
|
|---|
| 330 | (subtract-from (change-class (copy-instance minuend) 'poly)
|
|---|
| 331 | (change-class (reduce #'r+ subtrahends) 'poly)))
|
|---|
| 332 |
|
|---|
| 333 | (defmethod r+ ((poly1 monom) poly2)
|
|---|
| 334 | "Non-destructively add POLY1 by POLY2."
|
|---|
| 335 | (add-to (change-class (copy-instance poly1) 'poly)
|
|---|
| 336 | (change-class (copy-instance poly2) 'poly)))
|
|---|
| 337 |
|
|---|
| 338 | (defmethod r- ((minuend monom) &rest subtrahends)
|
|---|
| 339 | "Non-destructively subtract MINUEND and SUBTRAHENDS."
|
|---|
| 340 | (subtract-from (change-class (copy-instance minuend) 'poly)
|
|---|
| 341 | (change-class (reduce #'r+ subtrahends) 'poly)))
|
|---|
| 342 |
|
|---|
| 343 | (defmethod r* ((poly1 poly) (poly2 poly))
|
|---|
| 344 | "Non-destructively multiply POLY1 by POLY2."
|
|---|
| 345 | (multiply-by (copy-instance poly1) (copy-instance poly2)))
|
|---|
| 346 |
|
|---|
| 347 | (defmethod left-tensor-product-by ((self poly) (other term))
|
|---|
| 348 | (setf (poly-termlist self)
|
|---|
| 349 | (mapcan #'(lambda (term)
|
|---|
| 350 | (let ((prod (left-tensor-product-by term other)))
|
|---|
| 351 | (cond
|
|---|
| 352 | ((r-zerop prod) nil)
|
|---|
| 353 | (t (list prod)))))
|
|---|
| 354 | (poly-termlist self)))
|
|---|
| 355 | self)
|
|---|
| 356 |
|
|---|
| 357 | (defmethod right-tensor-product-by ((self poly) (other term))
|
|---|
| 358 | (setf (poly-termlist self)
|
|---|
| 359 | (mapcan #'(lambda (term)
|
|---|
| 360 | (let ((prod (right-tensor-product-by term other)))
|
|---|
| 361 | (cond
|
|---|
| 362 | ((r-zerop prod) nil)
|
|---|
| 363 | (t (list prod)))))
|
|---|
| 364 | (poly-termlist self)))
|
|---|
| 365 | self)
|
|---|
| 366 |
|
|---|
| 367 | (defmethod left-tensor-product-by ((self poly) (other monom))
|
|---|
| 368 | (setf (poly-termlist self)
|
|---|
| 369 | (mapcan #'(lambda (term)
|
|---|
| 370 | (let ((prod (left-tensor-product-by term other)))
|
|---|
| 371 | (cond
|
|---|
| 372 | ((r-zerop prod) nil)
|
|---|
| 373 | (t (list prod)))))
|
|---|
| 374 | (poly-termlist self)))
|
|---|
| 375 | (incf (poly-dimension self) (monom-dimension other))
|
|---|
| 376 | self)
|
|---|
| 377 |
|
|---|
| 378 | (defmethod right-tensor-product-by ((self poly) (other monom))
|
|---|
| 379 | (setf (poly-termlist self)
|
|---|
| 380 | (mapcan #'(lambda (term)
|
|---|
| 381 | (let ((prod (right-tensor-product-by term other)))
|
|---|
| 382 | (cond
|
|---|
| 383 | ((r-zerop prod) nil)
|
|---|
| 384 | (t (list prod)))))
|
|---|
| 385 | (poly-termlist self)))
|
|---|
| 386 | (incf (poly-dimension self) (monom-dimension other))
|
|---|
| 387 | self)
|
|---|
| 388 |
|
|---|
| 389 |
|
|---|
| 390 | (defun standard-extension (plist &aux (k (length plist)) (i 0))
|
|---|
| 391 | "Calculate [U1*P1,U2*P2,...,UK*PK], where PLIST=[P1,P2,...,PK]
|
|---|
| 392 | is a list of polynomials. Destructively modifies PLIST elements."
|
|---|
| 393 | (mapc #'(lambda (poly)
|
|---|
| 394 | (left-tensor-product-by
|
|---|
| 395 | poly
|
|---|
| 396 | (prog1
|
|---|
| 397 | (make-monom-variable k i)
|
|---|
| 398 | (incf i))))
|
|---|
| 399 | plist))
|
|---|
| 400 |
|
|---|
| 401 | (defun standard-extension-1 (plist
|
|---|
| 402 | &aux
|
|---|
| 403 | (plist (standard-extension plist))
|
|---|
| 404 | (nvars (poly-dimension (car plist))))
|
|---|
| 405 | "Calculate [U1*P1-1,U2*P2-1,...,UK*PK-1], where PLIST=[P1,P2,...,PK].
|
|---|
| 406 | Firstly, new K variables U1, U2, ..., UK, are inserted into each
|
|---|
| 407 | polynomial. Subsequently, P1, P2, ..., PK are destructively modified
|
|---|
| 408 | tantamount to replacing PI with UI*PI-1. It assumes that all
|
|---|
| 409 | polynomials have the same dimension, and only the first polynomial
|
|---|
| 410 | is examined to determine this dimension."
|
|---|
| 411 | ;; Implementation note: we use STANDARD-EXTENSION and then subtract
|
|---|
| 412 | ;; 1 from each polynomial; since UI*PI has no constant term,
|
|---|
| 413 | ;; we just need to append the constant term at the end
|
|---|
| 414 | ;; of each termlist.
|
|---|
| 415 | (flet ((subtract-1 (p)
|
|---|
| 416 | (append-item p (make-instance 'monom :coeff -1 :dimension nvars))))
|
|---|
| 417 | (setf plist (mapc #'subtract-1 plist)))
|
|---|
| 418 | plist)
|
|---|
| 419 |
|
|---|
| 420 |
|
|---|
| 421 | (defun standard-sum (plist
|
|---|
| 422 | &aux
|
|---|
| 423 | (plist (standard-extension plist))
|
|---|
| 424 | (nvars (poly-dimension (car plist))))
|
|---|
| 425 | "Calculate the polynomial U1*P1+U2*P2+...+UK*PK-1, where PLIST=[P1,P2,...,PK].
|
|---|
| 426 | Firstly, new K variables, U1, U2, ..., UK, are inserted into each
|
|---|
| 427 | polynomial. Subsequently, P1, P2, ..., PK are destructively modified
|
|---|
| 428 | tantamount to replacing PI with UI*PI, and the resulting polynomials
|
|---|
| 429 | are added. Finally, 1 is subtracted. It should be noted that the term
|
|---|
| 430 | order is not modified, which is equivalent to using a lexicographic
|
|---|
| 431 | order on the first K variables."
|
|---|
| 432 | (flet ((subtract-1 (p)
|
|---|
| 433 | (append-item p (make-instance 'term :coeff -1 :dimension nvars))))
|
|---|
| 434 | (subtract-1
|
|---|
| 435 | (make-instance
|
|---|
| 436 | 'poly
|
|---|
| 437 | :termlist (apply #'nconc (mapcar #'poly-termlist plist))))))
|
|---|
| 438 |
|
|---|
| 439 | #|
|
|---|
| 440 |
|
|---|
| 441 | (defun saturation-extension-1 (ring f p)
|
|---|
| 442 | "Calculate [F, U*P-1]. It destructively modifies F."
|
|---|
| 443 | (declare (type ring ring))
|
|---|
| 444 | (polysaturation-extension ring f (list p)))
|
|---|
| 445 |
|
|---|
| 446 |
|
|---|
| 447 |
|
|---|
| 448 |
|
|---|
| 449 | (defun spoly (ring-and-order f g
|
|---|
| 450 | &aux
|
|---|
| 451 | (ring (ro-ring ring-and-order)))
|
|---|
| 452 | "It yields the S-polynomial of polynomials F and G."
|
|---|
| 453 | (declare (type ring-and-order ring-and-order) (type poly f g))
|
|---|
| 454 | (let* ((lcm (monom-lcm (poly-lm f) (poly-lm g)))
|
|---|
| 455 | (mf (monom-div lcm (poly-lm f)))
|
|---|
| 456 | (mg (monom-div lcm (poly-lm g))))
|
|---|
| 457 | (declare (type monom mf mg))
|
|---|
| 458 | (multiple-value-bind (c cf cg)
|
|---|
| 459 | (funcall (ring-ezgcd ring) (poly-lc f) (poly-lc g))
|
|---|
| 460 | (declare (ignore c))
|
|---|
| 461 | (poly-sub
|
|---|
| 462 | ring-and-order
|
|---|
| 463 | (scalar-times-poly ring cg (monom-times-poly mf f))
|
|---|
| 464 | (scalar-times-poly ring cf (monom-times-poly mg g))))))
|
|---|
| 465 |
|
|---|
| 466 |
|
|---|
| 467 | (defun poly-primitive-part (ring p)
|
|---|
| 468 | "Divide polynomial P with integer coefficients by gcd of its
|
|---|
| 469 | coefficients and return the result."
|
|---|
| 470 | (declare (type ring ring) (type poly p))
|
|---|
| 471 | (if (poly-zerop p)
|
|---|
| 472 | (values p 1)
|
|---|
| 473 | (let ((c (poly-content ring p)))
|
|---|
| 474 | (values (make-poly-from-termlist
|
|---|
| 475 | (mapcar
|
|---|
| 476 | #'(lambda (x)
|
|---|
| 477 | (make-term :monom (term-monom x)
|
|---|
| 478 | :coeff (funcall (ring-div ring) (term-coeff x) c)))
|
|---|
| 479 | (poly-termlist p))
|
|---|
| 480 | (poly-sugar p))
|
|---|
| 481 | c))))
|
|---|
| 482 |
|
|---|
| 483 | (defun poly-content (ring p)
|
|---|
| 484 | "Greatest common divisor of the coefficients of the polynomial P. Use the RING structure
|
|---|
| 485 | to compute the greatest common divisor."
|
|---|
| 486 | (declare (type ring ring) (type poly p))
|
|---|
| 487 | (reduce (ring-gcd ring) (mapcar #'term-coeff (rest (poly-termlist p))) :initial-value (poly-lc p)))
|
|---|
| 488 |
|
|---|
| 489 | |#
|
|---|
