[73] | 1 | ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*-
|
---|
| 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 |
|
---|
[67] | 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 23 | ;;
|
---|
| 24 | ;; Operations in ideal theory
|
---|
| 25 | ;;
|
---|
| 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
---|
| 27 |
|
---|
[502] | 28 | (defpackage "IDEAL"
|
---|
| 29 | (:use :cl)
|
---|
| 30 | (:export))
|
---|
| 31 |
|
---|
| 32 | (in-package :ideal)
|
---|
| 33 |
|
---|
[67] | 34 | ;; Does the term depend on variable K?
|
---|
| 35 | (defun term-depends-p (term k)
|
---|
| 36 | "Return T if the term TERM depends on variable number K."
|
---|
| 37 | (monom-depends-p (term-monom term) k))
|
---|
| 38 |
|
---|
| 39 | ;; Does the polynomial P depend on variable K?
|
---|
| 40 | (defun poly-depends-p (p k)
|
---|
| 41 | "Return T if the term polynomial P depends on variable number K."
|
---|
| 42 | (some #'(lambda (term) (term-depends-p term k)) (poly-termlist p)))
|
---|
| 43 |
|
---|
| 44 | (defun ring-intersection (plist k)
|
---|
| 45 | "This function assumes that polynomial list PLIST is a Grobner basis
|
---|
| 46 | and it calculates the intersection with the ring R[x[k+1],...,x[n]], i.e.
|
---|
| 47 | it discards polynomials which depend on variables x[0], x[1], ..., x[k]."
|
---|
| 48 | (dotimes (i k plist)
|
---|
| 49 | (setf plist
|
---|
| 50 | (remove-if #'(lambda (p)
|
---|
| 51 | (poly-depends-p p i))
|
---|
| 52 | plist))))
|
---|
| 53 |
|
---|
| 54 | (defun elimination-ideal (ring flist k
|
---|
| 55 | &optional (top-reduction-only $poly_top_reduction_only) (start 0)
|
---|
| 56 | &aux (*monomial-order*
|
---|
| 57 | (or *elimination-order*
|
---|
| 58 | (elimination-order k))))
|
---|
| 59 | (ring-intersection (reduced-grobner ring flist start top-reduction-only) k))
|
---|
| 60 |
|
---|
| 61 | (defun colon-ideal (ring f g &optional (top-reduction-only $poly_top_reduction_only))
|
---|
| 62 | "Returns the reduced Grobner basis of the colon ideal Id(F):Id(G),
|
---|
| 63 | where F and G are two lists of polynomials. The colon ideal I:J is
|
---|
| 64 | defined as the set of polynomials H such that for all polynomials W in
|
---|
| 65 | J the polynomial W*H belongs to I."
|
---|
| 66 | (cond
|
---|
| 67 | ((endp g)
|
---|
| 68 | ;;Id(G) consists of 0 only so W*0=0 belongs to Id(F)
|
---|
| 69 | (if (every #'poly-zerop f)
|
---|
| 70 | (error "First ideal must be non-zero.")
|
---|
[156] | 71 | (list (make-poly-from-termlist
|
---|
[67] | 72 | (list (make-term
|
---|
| 73 | (make-monom (monom-dimension (poly-lm (find-if-not #'poly-zerop f)))
|
---|
| 74 | :initial-element 0)
|
---|
| 75 | (funcall (ring-unit ring))))))))
|
---|
| 76 | ((endp (cdr g))
|
---|
| 77 | (colon-ideal-1 ring f (car g) top-reduction-only))
|
---|
| 78 | (t
|
---|
| 79 | (ideal-intersection ring
|
---|
| 80 | (colon-ideal-1 ring f (car g) top-reduction-only)
|
---|
| 81 | (colon-ideal ring f (rest g) top-reduction-only)
|
---|
| 82 | top-reduction-only))))
|
---|
| 83 |
|
---|
| 84 | (defun colon-ideal-1 (ring f g &optional (top-reduction-only $poly_top_reduction_only))
|
---|
| 85 | "Returns the reduced Grobner basis of the colon ideal Id(F):Id({G}), where
|
---|
| 86 | F is a list of polynomials and G is a polynomial."
|
---|
| 87 | (mapcar #'(lambda (x) (poly-exact-divide ring x g)) (ideal-intersection ring f (list g) top-reduction-only)))
|
---|
| 88 |
|
---|
| 89 |
|
---|
| 90 | (defun ideal-intersection (ring f g &optional (top-reduction-only $poly_top_reduction_only)
|
---|
| 91 | &aux (*monomial-order* (or *elimination-order*
|
---|
| 92 | #'elimination-order-1)))
|
---|
| 93 | (mapcar #'poly-contract
|
---|
| 94 | (ring-intersection
|
---|
| 95 | (reduced-grobner
|
---|
| 96 | ring
|
---|
| 97 | (append (mapcar #'(lambda (p) (poly-extend p (make-monom 1 :initial-element 1))) f)
|
---|
| 98 | (mapcar #'(lambda (p)
|
---|
| 99 | (poly-append (poly-extend (poly-uminus ring p)
|
---|
| 100 | (make-monom 1 :initial-element 1))
|
---|
| 101 | (poly-extend p)))
|
---|
| 102 | g))
|
---|
| 103 | 0
|
---|
| 104 | top-reduction-only)
|
---|
| 105 | 1)))
|
---|
| 106 |
|
---|
| 107 | (defun poly-lcm (ring f g)
|
---|
| 108 | "Return LCM (least common multiple) of two polynomials F and G.
|
---|
| 109 | The polynomials must be ordered according to monomial order PRED
|
---|
| 110 | and their coefficients must be compatible with the RING structure
|
---|
| 111 | defined in the COEFFICIENT-RING package."
|
---|
| 112 | (cond
|
---|
| 113 | ((poly-zerop f) f)
|
---|
| 114 | ((poly-zerop g) g)
|
---|
| 115 | ((and (endp (cdr (poly-termlist f))) (endp (cdr (poly-termlist g))))
|
---|
| 116 | (let ((m (monom-lcm (poly-lm f) (poly-lm g))))
|
---|
| 117 | (make-poly-from-termlist (list (make-term m (funcall (ring-lcm ring) (poly-lc f) (poly-lc g)))))))
|
---|
| 118 | (t
|
---|
| 119 | (multiple-value-bind (f f-cont)
|
---|
| 120 | (poly-primitive-part ring f)
|
---|
| 121 | (multiple-value-bind (g g-cont)
|
---|
| 122 | (poly-primitive-part ring g)
|
---|
| 123 | (scalar-times-poly
|
---|
| 124 | ring
|
---|
| 125 | (funcall (ring-lcm ring) f-cont g-cont)
|
---|
| 126 | (poly-primitive-part ring (car (ideal-intersection ring (list f) (list g) nil)))))))))
|
---|
| 127 |
|
---|
| 128 | ;; Do two Grobner bases yield the same ideal?
|
---|
| 129 | (defun grobner-equal (ring g1 g2)
|
---|
| 130 | "Returns T if two lists of polynomials G1 and G2, assumed to be Grobner bases,
|
---|
| 131 | generate the same ideal, and NIL otherwise."
|
---|
| 132 | (and (grobner-subsetp ring g1 g2) (grobner-subsetp ring g2 g1)))
|
---|
| 133 |
|
---|
| 134 | (defun grobner-subsetp (ring g1 g2)
|
---|
| 135 | "Returns T if a list of polynomials G1 generates
|
---|
| 136 | an ideal contained in the ideal generated by a polynomial list G2,
|
---|
| 137 | both G1 and G2 assumed to be Grobner bases. Returns NIL otherwise."
|
---|
| 138 | (every #'(lambda (p) (grobner-member ring p g2)) g1))
|
---|
| 139 |
|
---|
| 140 | (defun grobner-member (ring p g)
|
---|
| 141 | "Returns T if a polynomial P belongs to the ideal generated by the
|
---|
| 142 | polynomial list G, which is assumed to be a Grobner basis. Returns NIL otherwise."
|
---|
| 143 | (poly-zerop (normal-form ring p g nil)))
|
---|
| 144 |
|
---|
| 145 | ;; Calculate F : p^inf
|
---|
| 146 | (defun ideal-saturation-1 (ring f p start &optional (top-reduction-only $poly_top_reduction_only)
|
---|
| 147 | &aux (*monomial-order* (or *elimination-order*
|
---|
| 148 | #'elimination-order-1)))
|
---|
| 149 | "Returns the reduced Grobner basis of the saturation of the ideal
|
---|
| 150 | generated by a polynomial list F in the ideal generated by a single
|
---|
| 151 | polynomial P. The saturation ideal is defined as the set of
|
---|
| 152 | polynomials H such for some natural number n (* (EXPT P N) H) is in the ideal
|
---|
| 153 | F. Geometrically, over an algebraically closed field, this is the set
|
---|
| 154 | of polynomials in the ideal generated by F which do not identically
|
---|
| 155 | vanish on the variety of P."
|
---|
| 156 | (mapcar
|
---|
| 157 | #'poly-contract
|
---|
| 158 | (ring-intersection
|
---|
| 159 | (reduced-grobner
|
---|
| 160 | ring
|
---|
| 161 | (saturation-extension-1 ring f p)
|
---|
| 162 | start top-reduction-only)
|
---|
| 163 | 1)))
|
---|
| 164 |
|
---|
| 165 |
|
---|
| 166 |
|
---|
| 167 | ;; Calculate F : p1^inf : p2^inf : ... : ps^inf
|
---|
| 168 | (defun ideal-polysaturation-1 (ring f plist start &optional (top-reduction-only $poly_top_reduction_only))
|
---|
| 169 | "Returns the reduced Grobner basis of the ideal obtained by a
|
---|
| 170 | sequence of successive saturations in the polynomials
|
---|
| 171 | of the polynomial list PLIST of the ideal generated by the
|
---|
| 172 | polynomial list F."
|
---|
| 173 | (cond
|
---|
| 174 | ((endp plist) (reduced-grobner ring f start top-reduction-only))
|
---|
| 175 | (t (let ((g (ideal-saturation-1 ring f (car plist) start top-reduction-only)))
|
---|
| 176 | (ideal-polysaturation-1 ring g (rest plist) (length g) top-reduction-only)))))
|
---|
| 177 |
|
---|
| 178 | (defun ideal-saturation (ring f g start &optional (top-reduction-only $poly_top_reduction_only)
|
---|
| 179 | &aux
|
---|
| 180 | (k (length g))
|
---|
| 181 | (*monomial-order* (or *elimination-order*
|
---|
| 182 | (elimination-order k))))
|
---|
| 183 | "Returns the reduced Grobner basis of the saturation of the ideal
|
---|
| 184 | generated by a polynomial list F in the ideal generated a polynomial
|
---|
| 185 | list G. The saturation ideal is defined as the set of polynomials H
|
---|
| 186 | such for some natural number n and some P in the ideal generated by G
|
---|
| 187 | the polynomial P**N * H is in the ideal spanned by F. Geometrically,
|
---|
| 188 | over an algebraically closed field, this is the set of polynomials in
|
---|
| 189 | the ideal generated by F which do not identically vanish on the
|
---|
| 190 | variety of G."
|
---|
| 191 | (mapcar
|
---|
| 192 | #'(lambda (q) (poly-contract q k))
|
---|
| 193 | (ring-intersection
|
---|
| 194 | (reduced-grobner ring
|
---|
| 195 | (polysaturation-extension ring f g)
|
---|
| 196 | start
|
---|
| 197 | top-reduction-only)
|
---|
| 198 | k)))
|
---|
| 199 |
|
---|
| 200 | (defun ideal-polysaturation (ring f ideal-list start &optional (top-reduction-only $poly_top_reduction_only))
|
---|
| 201 | "Returns the reduced Grobner basis of the ideal obtained by a
|
---|
| 202 | successive applications of IDEAL-SATURATION to F and lists of
|
---|
| 203 | polynomials in the list IDEAL-LIST."
|
---|
| 204 | (cond
|
---|
| 205 | ((endp ideal-list) f)
|
---|
| 206 | (t (let ((h (ideal-saturation ring f (car ideal-list) start top-reduction-only)))
|
---|
| 207 | (ideal-polysaturation ring h (rest ideal-list) (length h) top-reduction-only)))))
|
---|