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