[1] | 1 | #|
|
---|
| 2 | $Id: colored-poly.lisp,v 1.12 2009/01/24 11:07:32 marek Exp $
|
---|
| 3 | *--------------------------------------------------------------------------*
|
---|
| 4 | | Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu) |
|
---|
| 5 | | Department of Mathematics, University of Arizona, Tucson, AZ 85721 |
|
---|
| 6 | | |
|
---|
| 7 | | Everyone is permitted to copy, distribute and modify the code in this |
|
---|
| 8 | | directory, as long as this copyright note is preserved verbatim. |
|
---|
| 9 | *--------------------------------------------------------------------------*
|
---|
| 10 | |#
|
---|
| 11 | (defpackage "COLORED-POLY"
|
---|
| 12 | (:use "MONOM" "ORDER" "PARSE" "PRINTER" "MAKELIST"
|
---|
| 13 | "GROBNER" "DIVISION" "POLY" "COEFFICIENT-RING" "COMMON-LISP")
|
---|
| 14 | (:export make-colored-poly colored-poly-print colored-poly-print-list
|
---|
| 15 | colored-poly-to-poly
|
---|
| 16 | cond-print cond-system-print determine string-determine
|
---|
| 17 | color-poly color-poly-list
|
---|
| 18 | grobner-system totally-green-p cond-hm cond-normal-form
|
---|
| 19 | cond-spoly make-colored-poly-list
|
---|
| 20 | string-grobner-system string-cond string-cover
|
---|
| 21 | *colored-poly-debug*
|
---|
| 22 | parse-to-colored-poly-list
|
---|
| 23 | ))
|
---|
| 24 | (in-package "COLORED-POLY")
|
---|
| 25 |
|
---|
[8] | 26 | (proclaim '(optimize (speed 0) (debug 3)))
|
---|
[1] | 27 |
|
---|
| 28 | #+debug(defvar *colored-poly-debug* nil "If true debugging output is on.")
|
---|
| 29 | #+debug
|
---|
| 30 | (defmacro debug-cgb (&rest args)
|
---|
| 31 | `(when *colored-poly-debug* (format *trace-output* ,@args)))
|
---|
| 32 |
|
---|
| 33 | (defun make-colored-poly (poly k &key (key #'identity)
|
---|
| 34 | (main-order #'lex>)
|
---|
| 35 | (parameter-order #'lex>)
|
---|
| 36 | &aux l)
|
---|
| 37 | "Colored poly is represented as a list
|
---|
| 38 | (TERM1 TERM2 ... TERMS)
|
---|
| 39 | where each term is a triple
|
---|
| 40 | (MONOM . (POLY . COLOR))
|
---|
| 41 | where monoms and polys have common number of variables while color is
|
---|
| 42 | one of the three: :RED, :GREEN or :WHITE. This function translates an
|
---|
| 43 | ordinary polynomial into a colored one by dividing variables into K
|
---|
| 44 | and N-K, where N is the total number of variables in the polynomial
|
---|
| 45 | poly; the function KEY can be called to select variables in arbitrary
|
---|
| 46 | order."
|
---|
| 47 | (when (endp poly) (return-from make-colored-poly))
|
---|
| 48 | (setf l (length (caar poly)))
|
---|
| 49 | (labels
|
---|
| 50 | ((monom-split-variables (monom)
|
---|
| 51 | (values
|
---|
| 52 | (makelist (elt monom (funcall key i)) (i 0 (1- k)))
|
---|
| 53 | (makelist (elt monom (funcall key i)) (i k (1- l)))))
|
---|
| 54 | (term-split-variables (term)
|
---|
| 55 | (multiple-value-bind (main par)
|
---|
| 56 | (monom-split-variables (car term))
|
---|
| 57 | (cons main (cons par (cdr term)))))
|
---|
| 58 | (collect-terms (p)
|
---|
| 59 | (do ((p p (rest p))
|
---|
| 60 | (q (mapcar #'(lambda (x) (cons x nil))
|
---|
| 61 | (remove-duplicates (mapcar #'car p)
|
---|
| 62 | :test #'equal))))
|
---|
| 63 | ((endp p) q)
|
---|
| 64 | (push (cdar p) (cdr (assoc (caar p) q :test #'equal)))
|
---|
| 65 | )))
|
---|
| 66 | (mapcar #'(lambda (term)
|
---|
| 67 | (cons (car term)
|
---|
| 68 | (cons (sort (cdr term) parameter-order :key #'car)
|
---|
| 69 | :white)))
|
---|
| 70 | (collect-terms
|
---|
| 71 | (sort (mapcar #'term-split-variables poly)
|
---|
| 72 | main-order :key #'car)))))
|
---|
| 73 |
|
---|
| 74 | (defun make-colored-poly-list (plist &rest rest)
|
---|
| 75 | "Translate a list of polynomials PLIST into a list of colored polynomials
|
---|
| 76 | by calling MAKE-COLORED-POLY. Returns the resulting list."
|
---|
| 77 | (mapcar #'(lambda (p) (apply #'make-colored-poly (cons p rest)))
|
---|
| 78 | plist))
|
---|
| 79 |
|
---|
| 80 | (defun color-poly-list (flist &optional (cond (list nil nil)))
|
---|
| 81 | "Add colors to an ordinary list of polynomials FLIST, according to a
|
---|
| 82 | condition COND. A condition is a pair of polynomial lists. Each
|
---|
| 83 | polynomial in COND is a polynomial in parameters only. The list
|
---|
| 84 | (FIRST COND) is called the ``green list'' and it consists of
|
---|
| 85 | polynomials which vanish for the parameters associated with the
|
---|
| 86 | condition. The list (SECOND COND) is called the ``red list'' and it
|
---|
| 87 | consists of the polynomials which do not vanish for the parameters
|
---|
| 88 | associated with the condition."
|
---|
| 89 | (mapcar #'(lambda (f) (color-poly f cond)) flist))
|
---|
| 90 |
|
---|
| 91 | (defun color-poly (f &optional (cond (list nil nil)))
|
---|
| 92 | "Add color to a single polynomial F, according to condition COND.
|
---|
| 93 | See the documentation of COLOR-POLY-LIST."
|
---|
| 94 | (mapcar
|
---|
| 95 | #'(lambda (term)
|
---|
| 96 | (cons (car term)
|
---|
| 97 | (cons (cadr term)
|
---|
| 98 | (cond
|
---|
| 99 | ((member (cadr term) (car cond)
|
---|
| 100 | :test #'tree-equal) :green)
|
---|
| 101 | ((member (cadr term) (cadr cond)
|
---|
| 102 | :test #'tree-equal) :red)
|
---|
| 103 | (t :white)))))
|
---|
| 104 | (cdr f)))
|
---|
| 105 |
|
---|
| 106 | ;;Conversion to ordinary polynomial
|
---|
| 107 | (defun colored-poly-to-poly (cpoly)
|
---|
| 108 | "For a given colored polynomial CPOLY, removes the colors and
|
---|
| 109 | it returns the polynomial as an ordinary polynomial with
|
---|
| 110 | coefficients which are polynomials in parameters."
|
---|
| 111 | (mapcan #'(lambda (term)
|
---|
| 112 | (mapcar #'(lambda (x) (cons (append (car term) (car x)) (cdr x)))
|
---|
| 113 | (cadr term)))
|
---|
| 114 | (cdr cpoly)))
|
---|
| 115 |
|
---|
| 116 | (defun colored-poly-print (poly vars
|
---|
| 117 | &key (stream t) (beg t)
|
---|
| 118 | (print-green-part nil)
|
---|
| 119 | (mark-coefficients nil))
|
---|
| 120 | "Print a colored polynomial POLY. Use variables VARS to represent
|
---|
| 121 | the variables. Some of the variables are going to be used as
|
---|
| 122 | parameters, according to the length of the monomials in the main
|
---|
| 123 | monomial and coefficient part of each term in POLY. The key variable
|
---|
| 124 | STREAM may be used to redirect the output. If parameter
|
---|
| 125 | PRINT-GREEN-PART is set then the coefficients which have color :GREEN
|
---|
| 126 | will be printed, otherwise they are discarded silently. If
|
---|
| 127 | MARK-COEFFICIENTS is not NIL then every coefficient will be marked
|
---|
| 128 | according to its color, for instance G(U-1) would mean that U-1 is
|
---|
| 129 | in the green list. Returns P."
|
---|
| 130 | (when (null poly)
|
---|
| 131 | (when beg (format stream "0") )
|
---|
| 132 | (return-from colored-poly-print))
|
---|
| 133 | (let* ((term (car poly))
|
---|
| 134 | (color (cddr term))
|
---|
| 135 | (n (length (car term))))
|
---|
| 136 | (unless (and (not print-green-part) (eq color :green))
|
---|
| 137 | (unless beg (format stream " + "))
|
---|
| 138 | (if mark-coefficients
|
---|
| 139 | (format stream "~c("
|
---|
| 140 | (case color (:red #\R) (:green #\G) (:white #\W)))
|
---|
| 141 | (format stream "("))
|
---|
| 142 | (poly-print (cadr term) (subseq vars n))
|
---|
| 143 | (format stream ")")
|
---|
| 144 | (print-monom (car term) (subseq vars 0 n) stream)
|
---|
| 145 | (setf beg nil)))
|
---|
| 146 | (colored-poly-print (rest poly) vars :stream stream :beg beg
|
---|
| 147 | :print-green-part print-green-part
|
---|
| 148 | :mark-coefficients mark-coefficients))
|
---|
| 149 |
|
---|
| 150 | (defun colored-poly-print-list (poly-list vars
|
---|
| 151 | &key (stream t)
|
---|
| 152 | (beg t)
|
---|
| 153 | (print-green-part nil)
|
---|
| 154 | (mark-coefficients nil))
|
---|
| 155 | "Pring a list of colored polynomials via a call to
|
---|
| 156 | COLORED-POLY-PRINT."
|
---|
| 157 | (when (endp poly-list)
|
---|
| 158 | (when beg (format stream "["))
|
---|
| 159 | (format stream " ]")
|
---|
| 160 | (return-from colored-poly-print-list))
|
---|
| 161 | (unless (or (endp (car poly-list))
|
---|
| 162 | (and (not print-green-part) (endp (cond-part (car poly-list)))))
|
---|
| 163 | (when beg (format stream "[ "))
|
---|
| 164 | (unless beg (format stream ", "))
|
---|
| 165 | (colored-poly-print (car poly-list) vars
|
---|
| 166 | :stream stream
|
---|
| 167 | :print-green-part print-green-part
|
---|
| 168 | :mark-coefficients mark-coefficients)
|
---|
| 169 | (setf beg nil))
|
---|
| 170 | (colored-poly-print-list (rest poly-list) vars
|
---|
| 171 | :stream stream :beg beg
|
---|
| 172 | :print-green-part print-green-part
|
---|
| 173 | :mark-coefficients mark-coefficients))
|
---|
| 174 |
|
---|
| 175 | (defun determine (F &optional (cond (list nil nil)) (order #'lex>) (ring *coefficient-ring*))
|
---|
| 176 | "This function takes a list of colored polynomials F and a condition
|
---|
| 177 | COND, and it returns a list of pairs (COND' F') such that COND' cover
|
---|
| 178 | COND and F' is a ``determined'' version of the colored polynomial list
|
---|
| 179 | F, i.e. every polynomial has its leading coefficient determined. This
|
---|
| 180 | means that some of the initial coefficients in each polynomial in F'
|
---|
| 181 | are in the green list of COND, and the first non-green coefficient is
|
---|
| 182 | in the red list of COND. We note that F' differs from F only by
|
---|
| 183 | different colors: some of the terms marked :WHITE are now marked
|
---|
| 184 | either :GREEN or :RED. Coloring is done either by explicitly checking
|
---|
| 185 | membership in red or green list of COND, or implicitly by performing
|
---|
| 186 | Grobner basis calculations in the polynomial ring over the
|
---|
| 187 | parameters. The admissible monomial order ORDER is used only in the
|
---|
| 188 | parameter space. Also, the ring structure RING is used only for
|
---|
| 189 | calculations on polynomials of the parameters only."
|
---|
| 190 | (cond
|
---|
| 191 | ((endp F) (list (list cond nil)))
|
---|
| 192 | (t
|
---|
| 193 | (let ((gs (mapcan #'(lambda (p &aux (cond1 (car p)) (F1 (cadr p)))
|
---|
| 194 | (determine-1 cond1 (car F) F1 nil order ring))
|
---|
| 195 | (determine (rest F) cond order ring))))
|
---|
| 196 | #+debug(let ((l (length gs)))
|
---|
| 197 | (when (> l 1)
|
---|
| 198 | (debug-cgb "~&Determined ~d new case~:p." (1- l))))
|
---|
| 199 | gs))))
|
---|
| 200 |
|
---|
| 201 | (defun determine-1 (cond P end GP order ring)
|
---|
| 202 | "Determine a single colored polynomial P according to condition COND.
|
---|
| 203 | Prepend green part GP to P. Cons the result with END, which should be
|
---|
| 204 | a list of colored polynomials, and return the resulting list of polynomials.
|
---|
| 205 | This is an auxillary function of DETERMINE."
|
---|
| 206 | (cond
|
---|
| 207 | ((endp P) (list (list cond (append (list GP) end))))
|
---|
| 208 | ((eq (cddar P) :green)
|
---|
| 209 | (determine-1 cond (rest P) end (append GP (list (car P))) order ring))
|
---|
| 210 | ((eq (cddar P) :red)
|
---|
| 211 | (list (list cond (append (list (append GP P)) end))))
|
---|
| 212 | ;; white cases
|
---|
| 213 | (t (determine-white-term cond (car P) (rest P) end GP order ring))))
|
---|
| 214 |
|
---|
| 215 | #-use-saturation
|
---|
| 216 | (defun determine-white-term (cond term restP end GP order ring)
|
---|
| 217 | "This is an auxillary function of DETERMINE.
|
---|
| 218 | In this function the parameter COND is a condition.
|
---|
| 219 | The parameters TERM, RESTP and GP are three parts of a polynomial being
|
---|
| 220 | processed, where TERM is colored :WHITE. By testing membership
|
---|
| 221 | in the red and green list of COND we try to determine whether the term
|
---|
| 222 | is :RED or :GREEN. If we are successful, we simply change the color
|
---|
| 223 | of the term and return the list ((COND P)) where P is obtained by
|
---|
| 224 | appending GP, (LIST TERM) and RESTP. If we cannot determine whether
|
---|
| 225 | TERM is :RED or :GREEN, we return the list ((COND' P') (COND'' P ''))
|
---|
| 226 | where COND' is obtained by adding the coefficient of TERM to
|
---|
| 227 | the red list of COND and P' is obtained by appending
|
---|
| 228 | GP, (LIST TERM) and RESTP. COND'' is obtained by putting
|
---|
| 229 | the coefficient of TERM into the green list of COND and
|
---|
| 230 | P'' is obtaind by a recursive call to DETERMINE-1 on
|
---|
| 231 | RESTP, together with GP and TERM which was marked :GREEN."
|
---|
| 232 | (cond
|
---|
| 233 | ((member (cadr term) (car cond) :test #'tree-equal) ;green
|
---|
| 234 | (determine-1 cond restP end
|
---|
| 235 | (append GP (list (list* (car term) (cadr term) :green)))
|
---|
| 236 | order ring))
|
---|
| 237 | ((or (member (cadr term) (cadr cond) :test #'tree-equal) ;red
|
---|
| 238 | (poly-constant-p (cadr term)))
|
---|
| 239 | (list
|
---|
| 240 | (list cond
|
---|
| 241 | (append (list
|
---|
| 242 | (append GP ;green part
|
---|
| 243 | (list (list* (car term) (cadr term) :red));red term
|
---|
| 244 | restP)) ;other terms
|
---|
| 245 | end))))
|
---|
| 246 | (t ;white
|
---|
| 247 | (cons
|
---|
| 248 | (list (list (car cond) (cons (cadr term) (cadr cond)))
|
---|
| 249 | (append
|
---|
| 250 | (list
|
---|
| 251 | (append
|
---|
| 252 | GP
|
---|
| 253 | (list (cons (car term) (cons (cadr term) :red)))
|
---|
| 254 | restP))
|
---|
| 255 | end))
|
---|
| 256 | (determine-1
|
---|
| 257 | (list (cons (cadr term) (car cond)) (cadr cond))
|
---|
| 258 | restP
|
---|
| 259 | end
|
---|
| 260 | (append GP (list (cons (car term) (cons (cadr term) :green))))
|
---|
| 261 | order ring)))))
|
---|
| 262 |
|
---|
| 263 | ;; In this version, push on red list literally and test membership
|
---|
| 264 | ;; But keep green list to be a Grobner basis
|
---|
| 265 | #+use-saturation
|
---|
| 266 | (defun determine-white-term (cond term restP end GP order ring)
|
---|
| 267 | "This is an auxillary function of DETERMINE. In this function the
|
---|
| 268 | parameter COND is a condition. The parameters TERM, RESTP and GP are
|
---|
| 269 | three parts of a polynomial being processed, where TERM is colored
|
---|
| 270 | :WHITE. We test the membership in the red and green list of COND we
|
---|
| 271 | try to determine whether the term is :RED or :GREEN. This is done by
|
---|
| 272 | performing ideal membership tests in the polynomial ring. Let C be the
|
---|
| 273 | coefficient of TERM. Thus, C is a polynomial in parameters. We find
|
---|
| 274 | whether C is in the green list by performing a plain ideal membership
|
---|
| 275 | test. However, to test properly whether C is in the red list, one
|
---|
| 276 | needs a different strategy. In fact, we test whether adding C to the
|
---|
| 277 | red list would produce a non-empty set of parameters in some algebraic
|
---|
| 278 | extension. The test is whether 1 belongs to the saturation ideal of
|
---|
| 279 | (FIRST COND) in (CONS C (SECOND COND)). Thus, we use POLY-SATURATION.
|
---|
| 280 | If we are successful in determining the color of TERM, we simply
|
---|
| 281 | change the color of the term and return the list ((COND P)) where P is
|
---|
| 282 | obtained by appending GP, (LIST TERM) and RESTP. If we cannot
|
---|
| 283 | determine whether TERM is :RED or :GREEN, we return the list ((COND'
|
---|
| 284 | P') (COND'' P'')) where COND' is obtained by adding the coefficient of
|
---|
| 285 | TERM to the red list of COND and P' is obtained by appending GP, (LIST
|
---|
| 286 | TERM) and RESTP. COND'' is obtained by putting the coefficient of TERM
|
---|
| 287 | into the green list of COND and P'' is obtaind by a recursive call to
|
---|
| 288 | DETERMINE-1 on RESTP, together with GP and TERM which was marked
|
---|
| 289 | :GREEN."
|
---|
| 290 | (if (member (cadr term) (cadr cond) :test #'tree-equal)
|
---|
| 291 | ;;Paint red and return
|
---|
| 292 | (list
|
---|
| 293 | (list
|
---|
| 294 | cond
|
---|
| 295 | (append
|
---|
| 296 | (list (append GP (list (list* (car term) (cadr term) :red)) restP))
|
---|
| 297 | end)))
|
---|
| 298 | (let ((green-sat (ideal-saturation-1
|
---|
| 299 | (car cond)
|
---|
| 300 | (cadr term) order (length (car cond))
|
---|
| 301 | nil ring)))
|
---|
| 302 | (if (some #'poly-constant-p green-sat) ; in the radical of green
|
---|
| 303 | ;; paint the term green and determine the rest
|
---|
| 304 | (determine-1
|
---|
| 305 | cond restP end
|
---|
| 306 | (append GP (list (list* (car term) (cadr term) :green))) ;green term
|
---|
| 307 | order ring)
|
---|
| 308 | ;; else it does not contradict green and thus may be added to red list
|
---|
| 309 | ;; so it should be added to either red or green list
|
---|
| 310 | (cons
|
---|
| 311 | ;; Add to red
|
---|
| 312 | (list
|
---|
| 313 | (list green-sat (append (cadr cond) (list (cadr term))))
|
---|
| 314 | (append
|
---|
| 315 | (list (append
|
---|
| 316 | GP
|
---|
| 317 | (list (list* (car term) (cadr term) :red))
|
---|
| 318 | restP))
|
---|
| 319 | end))
|
---|
| 320 | ;; Add to green
|
---|
| 321 | (let ((sat (ideal-polysaturation-1
|
---|
| 322 | (append (car cond) (list (cadr term)))
|
---|
| 323 | (cadr cond)
|
---|
| 324 | order (length (car cond))
|
---|
| 325 | nil ring)))
|
---|
| 326 | (unless (some #'poly-constant-p sat) ;contradiction after all
|
---|
| 327 | (determine-1
|
---|
| 328 | (list sat (cadr cond))
|
---|
| 329 | restP end
|
---|
| 330 | (append GP (list (list* (car term) (cadr term) :green)))
|
---|
| 331 | order ring))))))))
|
---|
| 332 |
|
---|
| 333 |
|
---|
| 334 |
|
---|
| 335 | ;; Print a conditional system, i.e. a list of pairs (gamma colored-poly-list)
|
---|
| 336 | (defun cond-system-print (system vars params
|
---|
| 337 | &key (suppress-value t)
|
---|
| 338 | (print-green-part nil)
|
---|
| 339 | (mark-coefficients nil)
|
---|
| 340 | &aux (label 0))
|
---|
| 341 | "A conditional system SYSTEM is a list of pairs (COND PLIST), where COND
|
---|
| 342 | is a condition (a pair (GREEN-LIST RED-LIST)) and PLIST is a list
|
---|
| 343 | of colored polynomials. This function pretty-prints this list of
|
---|
| 344 | pairs. A conditional system is the data structure returned by
|
---|
| 345 | GROBNER-SYSTEM. This function returns SYSTEM, if SUPPRESS-VALUE is non-NIL and
|
---|
| 346 | no value otherwise. If MARK-COEFFICIENTS is non-NIL coefficients will be marked
|
---|
| 347 | as in G(u-1)*x+R(2)*y, which means that u-1 is :GREEN and 2 is :RED."
|
---|
| 348 | (dolist (pair system (if suppress-value (values) system))
|
---|
| 349 | (let ((cond (car pair))
|
---|
| 350 | (basis (cadr pair)))
|
---|
| 351 | (format t "~&------------------- CASE ~d -------------------"
|
---|
| 352 | (incf label))
|
---|
| 353 | (cond-print cond params)
|
---|
| 354 | (format t "~&~1TBasis: ")
|
---|
| 355 | (colored-poly-print-list basis (append vars params)
|
---|
| 356 | :print-green-part print-green-part
|
---|
| 357 | :mark-coefficients mark-coefficients))))
|
---|
| 358 |
|
---|
| 359 | ;; Print a condition
|
---|
| 360 | (defun cond-print (cond params)
|
---|
| 361 | "Pretty-print a condition COND, using symbol list PARAMS as parameter names."
|
---|
| 362 | (format t "~&Condition:")
|
---|
| 363 | (format t "~&~2TGreen list: ")
|
---|
| 364 | (poly-print (cons '[ (first cond)) params)
|
---|
| 365 | (format t "~&~2TRed list: ")
|
---|
| 366 | (poly-print (cons '[ (second cond)) params))
|
---|
| 367 |
|
---|
| 368 |
|
---|
| 369 | (defun add-pairs (gs pred)
|
---|
| 370 | "The parameter GS shoud be a Grobner system, i.e. a set of pairs
|
---|
| 371 | (CONDITION POLY-LIST) This functions adds the third component: the
|
---|
| 372 | list of initial critical pairs (I J), as in the ordinary Grobner basis
|
---|
| 373 | algorithm. In addition, it adds the length of of the POLY-LIST, less
|
---|
| 374 | 1, as the fourth component. The resulting list of quadruples is
|
---|
| 375 | returned."
|
---|
| 376 | #-reorder-pairs(declare (ignore pred))
|
---|
| 377 | (mapcar
|
---|
| 378 | #'(lambda (gb &aux (n (length (cadr gb))))
|
---|
| 379 | (let ((B (makelist (list i j) (i 0 (- n 2)) (j (1+ i) (1- n)))))
|
---|
| 380 | #+reorder-pairs
|
---|
| 381 | (setf B (reorder-pairs B nil (cadr gb) pred t))
|
---|
| 382 | (append gb (list B (1- n)))))
|
---|
| 383 | gs))
|
---|
| 384 |
|
---|
| 385 | (defun cond-part (p)
|
---|
| 386 | "Find the part of a colored polynomial P starting with the first
|
---|
| 387 | non-green term."
|
---|
| 388 | (member :green p :test-not #'eq :key #'cddr))
|
---|
| 389 |
|
---|
| 390 | (defun cond-hm (p)
|
---|
| 391 | "Return the conditional head monomial of a colored polynomial P."
|
---|
| 392 | (let ((cp (cond-part p)))
|
---|
| 393 | (cond
|
---|
| 394 | ((endp cp) (error "Zero conditional part."))
|
---|
| 395 | ((eq (cddar cp) :red) (car cp))
|
---|
| 396 | (t (error "Head not determined.")))))
|
---|
| 397 |
|
---|
| 398 | (defun delete-green-polys (gamma)
|
---|
| 399 | "Delete totally green polynomials from in a grobner system GAMMA."
|
---|
| 400 | (dolist (gb gamma gamma)
|
---|
| 401 | (setf (cadr gb) (delete-if-not #'cond-part (cadr gb)))))
|
---|
| 402 |
|
---|
| 403 | ;; B is a cover (i.e. a list of conditions)
|
---|
| 404 | ;; flist is a list of colored polynomials
|
---|
| 405 | (defun grobner-system (F &key
|
---|
| 406 | (cover (list '(nil nil)))
|
---|
| 407 | (main-order #'lex>)
|
---|
| 408 | (parameter-order #'lex>)
|
---|
| 409 | (reduce t)
|
---|
| 410 | (green-reduce t)
|
---|
| 411 | (top-reduction-only nil)
|
---|
| 412 | (ring *coefficient-ring*)
|
---|
| 413 | &aux
|
---|
| 414 | (cover #-use-saturation cover
|
---|
| 415 | #+use-saturation
|
---|
| 416 | (saturate-cover cover parameter-order ring))
|
---|
| 417 | (gamma (delete-green-polys
|
---|
| 418 | (mapcan #'(lambda (cond)
|
---|
| 419 | (determine F cond
|
---|
| 420 | parameter-order ring))
|
---|
| 421 | cover))))
|
---|
| 422 | "This function returns a grobner system, given a list of colored polynomials F,
|
---|
| 423 | Other parameters are:
|
---|
| 424 | A cover COVER, i.e. a list of conditions, i.e. pairs of the form (GREEN-LIST RED-LIST), where
|
---|
| 425 | GREEN-LIST and RED-LIST are to lists of ordinary polynomials in parameters.
|
---|
| 426 | A monomial order MAIN-ORDER used on main variables (not parameters).
|
---|
| 427 | A monomial order PARAMETER-ORDER used in calculations with parameters only.
|
---|
| 428 | REDUCE, a flag deciding whether COLORED-REDUCTION will be performed on the resulting
|
---|
| 429 | grobner system.
|
---|
| 430 | GREEN-REDUCE, a flag deciding whether the green list of each condition will be reduced in
|
---|
| 431 | a form of a reduced Grobner basis.
|
---|
| 432 | TOP-REDUCTION-ONLY, a flag deciding whether in the internal calculations in the space of parameters
|
---|
| 433 | top reduction only will be used.
|
---|
| 434 | RING, a structure as in the package COEFFICIENT-RING, used in operations on the coefficients
|
---|
| 435 | of the polynomials in parameters."
|
---|
| 436 | #+debug(debug-cgb "~&Initially ~d open case~:p." (length gamma))
|
---|
| 437 | (do ((open (add-pairs gamma main-order))
|
---|
| 438 | closed)
|
---|
| 439 | ((endp open)
|
---|
| 440 | ;; Post-process Grobner system
|
---|
| 441 | (tidy-grobner-system
|
---|
| 442 | (mapcar #'(lambda (gp) (butlast gp 2)) closed)
|
---|
| 443 | main-order parameter-order reduce green-reduce ring))
|
---|
| 444 | #+debug(debug-cgb "~&Currently ~d open case~:p." (length open))
|
---|
| 445 | (let* ((gb (pop open)) (cond (car gb)) (G (cadr gb)) (B (caddr gb))
|
---|
| 446 | (s (cadddr gb)))
|
---|
| 447 | (declare (fixnum s))
|
---|
| 448 | (assert (= (length G) (1+ s)))
|
---|
| 449 | #+debug(debug-cgb "~&Colored case of ~d polynomials and ~d pairs."
|
---|
| 450 | (1+ s) (length B))
|
---|
| 451 | (cond
|
---|
| 452 | ((endp B) ;no more pairs in this tuple
|
---|
| 453 | (push gb closed))
|
---|
| 454 | ((let* ((pair (car B))
|
---|
| 455 | (i (car pair))
|
---|
| 456 | (j (cadr pair)))
|
---|
| 457 | (declare (fixnum i j))
|
---|
| 458 | (or
|
---|
| 459 | ;;Buchberger criterion 1 or 2 succeeds
|
---|
| 460 | (colored-Criterion-1 i j G)
|
---|
| 461 | (colored-Criterion-2 i j G (rest B) s)))
|
---|
| 462 | (push (list cond G (rest B) s) open))
|
---|
| 463 | (t ;Grobner step - S-polynomial
|
---|
| 464 | (do* ((pair (car B))
|
---|
| 465 | (i (car pair))
|
---|
| 466 | (j (cadr pair))
|
---|
| 467 | (h (cond-spoly (elt G i) (elt G j)
|
---|
| 468 | main-order parameter-order ring))
|
---|
| 469 | (SP (cond-normal-form h G main-order parameter-order top-reduction-only ring))
|
---|
| 470 | (delta (determine (list SP) cond parameter-order ring)
|
---|
| 471 | (rest delta)))
|
---|
| 472 | ((endp delta))
|
---|
| 473 | (declare (fixnum i j))
|
---|
| 474 | (let ((cond1 (caar delta))
|
---|
| 475 | (SP1 (caadar delta)))
|
---|
| 476 | (cond
|
---|
| 477 | ((cond-part SP1) ;SP1 is not green
|
---|
| 478 | (let* ((G1 (append G (list SP1)))
|
---|
| 479 | (s1 (1+ s))
|
---|
| 480 | (Bnew (makelist (list k s1) (k 0 (1- s1))))
|
---|
| 481 | B1)
|
---|
| 482 | (assert (= (length G1) (1+ s1)))
|
---|
| 483 | #+reorder-pairs
|
---|
| 484 | (setf B1 (reorder-pairs (rest B) Bnew G1 main-order nil))
|
---|
| 485 | #-reorder-pairs
|
---|
| 486 | (setf B1 (append (rest B) Bnew))
|
---|
| 487 | (push (list cond1 G1 B1 s1) open)))
|
---|
| 488 | (t ;SP1 is totally green
|
---|
| 489 | (assert (= (length G) (1+ s)))
|
---|
| 490 | (push (list cond1 G (rest B) s) open))))))))))
|
---|
| 491 |
|
---|
| 492 | ;; This is destructive to B and Bnew
|
---|
| 493 | #+reorder-pairs
|
---|
| 494 | (defun reorder-pairs (B Bnew G pred &optional (sort-first nil))
|
---|
| 495 | "Reorder pairs according to some heuristic. The heuristic at this time is ad hoc,
|
---|
| 496 | in the future it should be replaced with sugar strategy and a mechanism for implementing
|
---|
| 497 | new heuristic strategies, as in the GROBNER package."
|
---|
| 498 | (let ((order
|
---|
| 499 | #'(lambda (p1 p2)
|
---|
| 500 | (let* ((m1 (monom-lcm (cond-lm (elt G (car p1)))
|
---|
| 501 | (cond-lm (elt G (cadr p1)))))
|
---|
| 502 | (m2 (monom-lcm (cond-lm (elt G (car p2)))
|
---|
| 503 | (cond-lm (elt G (cadr p2)))))
|
---|
| 504 | (d1 (total-degree m1))
|
---|
| 505 | (d2 (total-degree m2)))
|
---|
| 506 | (cond ((< d1 d2) t)
|
---|
| 507 | ((= d1 d2) (funcall pred m2 m1))
|
---|
| 508 | (t nil))))))
|
---|
| 509 | (when sort-first (setf B (sort (copy-list B) order)))
|
---|
| 510 | (if Bnew
|
---|
| 511 | (setf B (merge 'list (sort Bnew order) (copy-list B) order))
|
---|
| 512 | B)))
|
---|
| 513 |
|
---|
| 514 | (defun colored-Criterion-1 (i j F)
|
---|
| 515 | "Buchberger criterion 1 for colored polynomials."
|
---|
| 516 | (declare (fixnum i j))
|
---|
| 517 | (let ((v (monom-rel-prime (cond-lm (elt F i))
|
---|
| 518 | (cond-lm (elt F j)))))
|
---|
| 519 | #+debug(when v (debug-cgb "~&~2TColored Buchberger1 succeded."))
|
---|
| 520 | v))
|
---|
| 521 |
|
---|
| 522 | (defun colored-Criterion-2 (i j F B s)
|
---|
| 523 | "Buchberger criterion 2 for colored polynomials."
|
---|
| 524 | (declare (fixnum i j s))
|
---|
| 525 | (labels ((pair (i j)
|
---|
| 526 | (declare (fixnum i j))
|
---|
| 527 | (if (< i j) (list i j) (list j i))))
|
---|
| 528 | (do ((k 1 (1+ k)))
|
---|
| 529 | ((>= k s))
|
---|
| 530 | (when (and (/= k i)
|
---|
| 531 | (/= k j)
|
---|
| 532 | (not (member (pair i k) B :test #'equal))
|
---|
| 533 | (not (member (pair j k) B :test #'equal))
|
---|
| 534 | (monom-divides-p (cond-lm (elt F k))
|
---|
| 535 | (monom-lcm (cond-lm (elt F i))
|
---|
| 536 | (cond-lm (elt F j)))))
|
---|
| 537 | #+debug(debug-cgb "~&~2TColored Buchberger2 succeded.")
|
---|
| 538 | (return-from colored-Criterion-2 t)))))
|
---|
| 539 |
|
---|
| 540 |
|
---|
| 541 | (defun cond-normal-form (f fl main-order parameter-order top-reduction-only ring)
|
---|
| 542 | "Returns the conditional normal form of a colored polynomial F with respect to
|
---|
| 543 | the list of colored polynomials FL. The list FL is assumed to consist of determined
|
---|
| 544 | polynomials, i.e. such that the first term which is not marked :GREEN is
|
---|
| 545 | :RED."
|
---|
| 546 | ;; Remove all zero (i.e totally green) polys from plist
|
---|
| 547 | ;; (setf fl (remove nil fl :key #'cond-part))
|
---|
| 548 | (do (r (division-count 0)
|
---|
| 549 | (p f))
|
---|
| 550 | ((or (endp p) (and top-reduction-only r))
|
---|
| 551 | #+debug(debug-cgb "~&~3T~d conditional reductions" division-count)
|
---|
| 552 | #+debug(when (endp r) (debug-cgb " ---> 0"))
|
---|
| 553 | (values (reverse r) division-count))
|
---|
| 554 | (cond
|
---|
| 555 | ((eq (cddar p) :green)
|
---|
| 556 | (setf r (cons (car p) r)
|
---|
| 557 | p (rest p)))
|
---|
| 558 | (t
|
---|
| 559 | ;; Find a divisor
|
---|
| 560 | (do ((fl fl (rest fl))) ;scan list of divisors
|
---|
| 561 | ((cond
|
---|
| 562 | ((endp fl)
|
---|
| 563 | ;; no division occurred
|
---|
| 564 | (setf r (cons (car p) r) ;move term to remainder
|
---|
| 565 | p (rest p)) ;remove car from p
|
---|
| 566 | t)
|
---|
| 567 | ((monom-divides-p (cond-lm (car fl))
|
---|
| 568 | (caar p))
|
---|
| 569 | (incf division-count)
|
---|
| 570 | (let* (#-colored-poly-use-grobner
|
---|
[20] | 571 | (c1 (cons (make-list (length (caaar fl))
|
---|
[1] | 572 | :initial-element 0)
|
---|
| 573 | (cond-lc (car fl))))
|
---|
| 574 | #+colored-poly-use-grobner
|
---|
| 575 | (lcm (poly-lcm (car (cond-lc (car fl))) (cadar p)
|
---|
| 576 | parameter-order ring))
|
---|
| 577 | #+colored-poly-use-grobner
|
---|
| 578 | (c1 (cons (make-list (length (cond-lm (car fl)))
|
---|
| 579 | :initial-element 0)
|
---|
| 580 | (cons (poly-exact-divide lcm (cadar p) parameter-order ring) :red)))
|
---|
| 581 | #+colored-poly-use-grobner
|
---|
| 582 | (c2 (poly-exact-divide
|
---|
| 583 | lcm
|
---|
| 584 | (car (cond-lc (car fl)))
|
---|
| 585 | parameter-order ring))
|
---|
| 586 | #-colored-poly-use-grobner
|
---|
| 587 | (c2 (cadar p))
|
---|
| 588 | ;; This works for both
|
---|
| 589 | (quot (cons (monom/ (caar p) (cond-lm (car fl)))
|
---|
| 590 | (cons c2 (cddr p)))))
|
---|
| 591 | ;; Multiply the equation c*f=sum ai*fi+r+p by c1.
|
---|
| 592 | (setf r (colored-term-times-poly c1 r parameter-order ring)
|
---|
| 593 | p (colored-poly-
|
---|
| 594 | (colored-term-times-poly c1 p parameter-order ring)
|
---|
| 595 | (colored-term-times-poly quot (car fl) parameter-order ring)
|
---|
| 596 | main-order parameter-order ring)))
|
---|
| 597 | t))))))))
|
---|
| 598 |
|
---|
| 599 |
|
---|
| 600 |
|
---|
| 601 | (defun cond-spoly (f g main-order parameter-order ring)
|
---|
| 602 | "Returns the conditional S-polynomial of two colored polynomials F and G.
|
---|
| 603 | Both polynomials are assumed to be determined."
|
---|
| 604 | (let* ((lcm (monom-lcm (cond-lm f) (cond-lm g)))
|
---|
| 605 | (m1 (monom/ lcm (cond-lm f)))
|
---|
| 606 | (m2 (monom/ lcm (cond-lm g))))
|
---|
| 607 | #-colored-poly-use-grobner
|
---|
| 608 | (colored-poly-
|
---|
| 609 | (colored-term-times-poly (cons m1 (cond-lc g)) (rest f)
|
---|
| 610 | parameter-order ring)
|
---|
| 611 | (colored-term-times-poly (cons m2 (cond-lc f)) (rest g)
|
---|
| 612 | parameter-order ring)
|
---|
| 613 | main-order parameter-order ring)
|
---|
| 614 |
|
---|
| 615 | #+colored-poly-use-grobner
|
---|
| 616 | (let* ((lcm-2 (poly-lcm (car (cond-lc f)) (car (cond-lc g))
|
---|
| 617 | parameter-order ring))
|
---|
| 618 | (lcf (cond-lc f))
|
---|
| 619 | (lcg (cond-lc g))
|
---|
| 620 | (cf (cons (poly-exact-divide lcm-2 (car lcf) parameter-order ring)
|
---|
| 621 | :red))
|
---|
| 622 | (cg (cons (poly-exact-divide lcm-2 (car lcg) parameter-order ring)
|
---|
| 623 | :red)))
|
---|
| 624 | (colored-poly-
|
---|
| 625 | (colored-term-times-poly (cons m1 cf) f parameter-order ring)
|
---|
| 626 | (colored-term-times-poly (cons m2 cg) g parameter-order ring)
|
---|
| 627 | main-order parameter-order ring))
|
---|
| 628 | ))
|
---|
| 629 |
|
---|
| 630 | (defun cond-lm (f)
|
---|
| 631 | "Returns the conditional leading monomial of a colored polynomial F,
|
---|
| 632 | which is assumed to be determined."
|
---|
| 633 | (car (cond-hm f)))
|
---|
| 634 |
|
---|
| 635 | ;; Conditional leading coefficient; (poly . color)
|
---|
| 636 | (defun cond-lc (f)
|
---|
| 637 | "Returns the conditional leading coefficient of a colored polynomial F,
|
---|
| 638 | which is assumed to be determined."
|
---|
| 639 | (cdr (cond-hm f)))
|
---|
| 640 |
|
---|
| 641 |
|
---|
| 642 | (defun colored-term-times-poly (term f order ring)
|
---|
| 643 | "Returns the product of a colored term TERM and a colored polynomial F."
|
---|
| 644 | (mapcar #'(lambda (x) (colored-term* term x order ring)) f))
|
---|
| 645 |
|
---|
| 646 |
|
---|
| 647 | (defun colored-scalar-times-poly (c f ring)
|
---|
| 648 | "Returns the product of an element of the coefficient ring C a colored polynomial F."
|
---|
| 649 | (mapcar #'(lambda (x)
|
---|
| 650 | (cons (car x)
|
---|
| 651 | (cons (scalar-times-poly c (cadr x) ring)
|
---|
| 652 | (cddr x))))
|
---|
| 653 | f))
|
---|
| 654 |
|
---|
| 655 | (defun colored-term* (term1 term2 order ring)
|
---|
| 656 | "Returns the product of two colored terms TERM1 and TERM2."
|
---|
| 657 | (cons
|
---|
| 658 | (monom* (car term1) (car term2))
|
---|
| 659 | (cons (poly* (cadr term1) (cadr term2) order ring)
|
---|
| 660 | (color* (cddr term1) (cddr term2)))))
|
---|
| 661 |
|
---|
| 662 | (defun color* (c1 c2)
|
---|
| 663 | "Returns a product of two colores. Rules:
|
---|
| 664 | :red * :red yields :red
|
---|
| 665 | any * :green yields :green
|
---|
| 666 | otherwise the result is :white."
|
---|
| 667 | (cond
|
---|
| 668 | ((and (eq c1 :red) (eq c2 :red)) :red)
|
---|
| 669 | ((or (eq c1 :green) (eq c2 :green)) :green)
|
---|
| 670 | (t :white)))
|
---|
| 671 |
|
---|
| 672 | (defun color+ (c1 c2)
|
---|
| 673 | "Returns a sum of colors. Rules:
|
---|
| 674 | :green + :green yields :green,
|
---|
| 675 | :red + :green yields :red
|
---|
| 676 | any other result is :white."
|
---|
| 677 | (cond
|
---|
| 678 | ((and (eq c1 :green) (eq c2 :green)) :green)
|
---|
| 679 | ((and (eq c1 :red) (eq c2 :green)) :red)
|
---|
| 680 | ((and (eq c2 :red) (eq c1 :green)) :red)
|
---|
| 681 | (t :white)))
|
---|
| 682 |
|
---|
| 683 | (defun color- (c1 c2)
|
---|
| 684 | "Identical to COLOR+."
|
---|
| 685 | (color+ c1 c2))
|
---|
| 686 |
|
---|
| 687 | (defun colored-poly+ (p q main-order parameter-order ring)
|
---|
| 688 | "Returns the sum of colored polynomials P and Q."
|
---|
| 689 | (cond
|
---|
| 690 | ((endp p) q)
|
---|
| 691 | ((endp q) p)
|
---|
| 692 | (t
|
---|
| 693 | (multiple-value-bind
|
---|
| 694 | (mgreater mequal)
|
---|
| 695 | (funcall main-order (caar p) (caar q))
|
---|
| 696 | (cond
|
---|
| 697 | (mequal
|
---|
| 698 | (let ((s (poly+ (cadar p) (cadar q) parameter-order ring)))
|
---|
| 699 | (if (endp s) ;check for cancellation
|
---|
| 700 | (colored-poly+ (cdr p) (cdr q) main-order parameter-order ring)
|
---|
| 701 | (cons (cons (caar p) (cons s (color+ (cddar p) (cddar q))))
|
---|
| 702 | (colored-poly+ (cdr p) (cdr q) main-order
|
---|
| 703 | parameter-order ring)))))
|
---|
| 704 | (mgreater
|
---|
| 705 | (cons (car p)
|
---|
| 706 | (colored-poly+ (cdr p) q main-order parameter-order ring)))
|
---|
| 707 | (t (cons (cons (caar q) (cons (cadar q) (cddar q)))
|
---|
| 708 | (colored-poly+ p (cdr q) main-order parameter-order ring))))))))
|
---|
| 709 |
|
---|
| 710 | (defun colored-poly- (p q main-order parameter-order ring)
|
---|
| 711 | "Returns the difference of colored polynomials P and Q."
|
---|
| 712 | (do (r)
|
---|
| 713 | (nil)
|
---|
| 714 | (cond
|
---|
| 715 | ((endp p) (return (nreconc r (colored-minus-poly q ring))))
|
---|
| 716 | ((endp q) (return (nreconc r p)))
|
---|
| 717 | (t
|
---|
| 718 | (multiple-value-bind
|
---|
| 719 | (mgreater mequal)
|
---|
| 720 | (funcall main-order (caar p) (caar q))
|
---|
| 721 | (cond
|
---|
| 722 | (mequal
|
---|
| 723 | (let ((s (poly- (cadar p) (cadar q) parameter-order ring)))
|
---|
| 724 | (unless (endp s) ;check for cancellation
|
---|
| 725 | (setf r (cons (cons (caar p) (cons s (color- (cddar p) (cddar q)))) r)))
|
---|
| 726 | (setf p (cdr p) q (cdr q))))
|
---|
| 727 | (mgreater
|
---|
| 728 | (setf r (cons (car p) r)
|
---|
| 729 | p (cdr p)))
|
---|
| 730 | (t (setf r (cons (cons (caar q) (cons (minus-poly (cadar q) ring) (cddar q))) r)
|
---|
| 731 | q (cdr q)))))))))
|
---|
| 732 |
|
---|
| 733 | (defun colored-term-uminus (term ring)
|
---|
| 734 | "Returns the negation of a colored term TERM."
|
---|
| 735 | (cons (car term) (cons (minus-poly (cadr term) ring) (cddr term))))
|
---|
| 736 |
|
---|
| 737 | (defun colored-minus-poly (p ring)
|
---|
| 738 | "Returns the negation of a colored polynomial P."
|
---|
| 739 | (mapcar #'(lambda (x) (colored-term-uminus x ring)) p))
|
---|
| 740 |
|
---|
| 741 | (defun string-grobner-system (F vars params
|
---|
| 742 | &key (cover (list (list "[]" "[]")))
|
---|
| 743 | (main-order #'lex>)
|
---|
| 744 | (parameter-order #'lex>)
|
---|
| 745 | (ring *coefficient-ring*)
|
---|
| 746 | (suppress-value t)
|
---|
| 747 | (suppress-printing nil)
|
---|
| 748 | (mark-coefficients nil)
|
---|
| 749 | (reduce t)
|
---|
| 750 | (green-reduce t)
|
---|
| 751 | &aux
|
---|
| 752 | (F (parse-to-colored-poly-list
|
---|
| 753 | F vars params main-order parameter-order))
|
---|
| 754 | (cover (string-cover cover params parameter-order)))
|
---|
| 755 | "An interface to GROBNER-SYSTEM in which polynomials can be specified in infix notations
|
---|
| 756 | as strings. Lists of polynomials are comma-separated list marked by a matchfix operators []"
|
---|
| 757 | (let ((gs (grobner-system F :cover cover :main-order main-order
|
---|
| 758 | :parameter-order parameter-order
|
---|
| 759 | :ring ring
|
---|
| 760 | :green-reduce green-reduce
|
---|
| 761 | :reduce reduce)))
|
---|
| 762 | (unless suppress-printing
|
---|
| 763 | (cond-system-print gs vars params :mark-coefficients mark-coefficients))
|
---|
| 764 | (if suppress-value (values) gs)))
|
---|
| 765 |
|
---|
| 766 |
|
---|
| 767 | (defun string-cond (cond params &optional (order #'lex>))
|
---|
| 768 | "Return the internal representation of a condition COND, specified
|
---|
| 769 | as pairs of strings (GREEN-LIST RED-LIST). GREEN-LIST and RED-LIST in
|
---|
| 770 | the input are assumed to be strings which parse to two lists of
|
---|
| 771 | polynomials with respect to variables whose names are in the list of
|
---|
| 772 | symbols PARAMS. ORDER is the predicate used to sort the terms of
|
---|
| 773 | the polynomials."
|
---|
| 774 | (list
|
---|
| 775 | (rest (parse-string-to-sorted-alist (car cond) params order))
|
---|
| 776 | (rest (parse-string-to-sorted-alist (cadr cond) params order))))
|
---|
| 777 |
|
---|
| 778 | (defun string-cover (cover params &optional (order #'lex>))
|
---|
| 779 | "Returns the internal representation of COVER, given in the form of
|
---|
| 780 | a list of conditions. See STRING-COND for description of a condition."
|
---|
| 781 | (cond
|
---|
| 782 | ((endp cover) nil)
|
---|
| 783 | (t (cons (string-cond (car cover) params order)
|
---|
| 784 | (string-cover (cdr cover) params order)))))
|
---|
| 785 |
|
---|
| 786 | (defun saturate-cover (cover order ring)
|
---|
| 787 | "Brings every condition of a list of conditions COVER to the form (G R)
|
---|
| 788 | where G is saturated with respect to R and G is a Grobner basis
|
---|
| 789 | We could reduce R so that the elements of R are relatively prime,
|
---|
| 790 | but this is not currently done."
|
---|
| 791 | (remove nil (mapcar #'(lambda (cond) (saturate-cond cond order ring)) cover)))
|
---|
| 792 |
|
---|
| 793 | (defun saturate-cond (cond order ring)
|
---|
| 794 | "Saturate a single condition COND. An auxillary function of SATURATE-COVER."
|
---|
| 795 | (let* ((green-sat (ideal-polysaturation-1 (car cond) (cadr cond) order 0 nil ring)))
|
---|
| 796 | (if (some #'poly-constant-p green-sat)
|
---|
| 797 | nil
|
---|
| 798 | (list green-sat (cadr cond)))))
|
---|
| 799 |
|
---|
| 800 | (defun string-determine (F vars params
|
---|
| 801 | &key (cond '("[]" "[]"))
|
---|
| 802 | (main-order #'lex>)
|
---|
| 803 | (parameter-order #'lex>)
|
---|
| 804 | (suppress-value t)
|
---|
| 805 | (suppress-printing nil)
|
---|
| 806 | (mark-coefficients nil)
|
---|
| 807 | (ring *coefficient-ring*)
|
---|
| 808 | &aux
|
---|
| 809 | (F (parse-to-colored-poly-list
|
---|
| 810 | F vars params main-order parameter-order))
|
---|
| 811 | (cond (string-cond cond params parameter-order)))
|
---|
| 812 | "A string interface to DETERMINE. See the documentation of STRING-GROBNER-SYSTEM."
|
---|
| 813 | (let ((gs (determine F cond parameter-order ring)))
|
---|
| 814 | (unless suppress-printing
|
---|
| 815 | (cond-system-print gs vars params :mark-coefficients mark-coefficients))
|
---|
| 816 | (if suppress-value (values) gs)))
|
---|
| 817 |
|
---|
| 818 | (defun tidy-grobner-system (gs main-order parameter-order
|
---|
| 819 | reduce green-reduce ring)
|
---|
| 820 | "Apply TIDY-PAIR to every pair of a Grobner system."
|
---|
| 821 | (mapcan #'(lambda (p) (tidy-pair p main-order parameter-order reduce green-reduce
|
---|
| 822 | ring))
|
---|
| 823 | gs))
|
---|
| 824 |
|
---|
| 825 |
|
---|
| 826 | (defun tidy-pair (pair main-order parameter-order
|
---|
| 827 | reduce green-reduce ring
|
---|
| 828 | &aux gs)
|
---|
| 829 | "Make the output of Grobner system more readable by performing
|
---|
| 830 | certain simplifications on an element of a Grobner system.
|
---|
| 831 | If REDUCE is non-NIL then COLORED-reduction will be performed.
|
---|
| 832 | In addition TIDY-COND is called on the condition part of the pair PAIR."
|
---|
| 833 | (if reduce
|
---|
| 834 | (setf gs (colored-reduction (car pair) (cadr pair)
|
---|
| 835 | main-order parameter-order ring))
|
---|
| 836 | (setf gs (list pair)))
|
---|
| 837 | (setf gs
|
---|
| 838 | (mapcar #'(lambda (pair)
|
---|
| 839 | (list (tidy-cond (car pair) parameter-order
|
---|
| 840 | ring)
|
---|
| 841 | (cadr pair)))
|
---|
| 842 | gs))
|
---|
| 843 | (when green-reduce
|
---|
| 844 | (setf gs (cond-system-green-reduce gs parameter-order ring)))
|
---|
| 845 | gs)
|
---|
| 846 |
|
---|
| 847 | (defun tidy-cond (cond order ring)
|
---|
| 848 | "Currently saturates condition COND and does RED-REDUCTION on the red list."
|
---|
| 849 | (let ((cond1 (saturate-cond cond order ring)))
|
---|
| 850 | (list (reduction (car cond1) order ring)
|
---|
| 851 | (red-reduction (cadr cond1) order ring))))
|
---|
| 852 |
|
---|
| 853 | (defun colored-reduction (cond P main-order parameter-order ring
|
---|
| 854 | &aux (open (list (list cond nil P))) closed)
|
---|
| 855 | "Reduce a list of colored polynomials P. The difficulty as compared
|
---|
| 856 | to the usual Buchberger algorithm is that the polys may have the same
|
---|
| 857 | leading monomial which may result in cancellations and polynomials
|
---|
| 858 | which may not be determined. Thus, when we find those, we will have to
|
---|
| 859 | split the condition by calling determine. Returns a list of pairs
|
---|
| 860 | (COND' P') where P' is a reduced grobner basis with respect to any
|
---|
| 861 | parameter choice compatible with condition COND'. Moreover, COND' form
|
---|
| 862 | a cover of COND."
|
---|
| 863 | ;;We form a list of tripples (CONDITION G U) where G is reduced and U
|
---|
| 864 | ;;is the unreduced part of the basis and operate on these
|
---|
| 865 | (do ()
|
---|
| 866 | ((endp open) closed)
|
---|
| 867 | (let* ((tuple (pop open))
|
---|
| 868 | (cond1 (car tuple))
|
---|
| 869 | (G (cadr tuple))
|
---|
| 870 | (U (caddr tuple)))
|
---|
| 871 | (cond
|
---|
| 872 | ((endp U) ;no-more undetermined
|
---|
| 873 | (push (list cond1 G)
|
---|
| 874 | closed))
|
---|
| 875 | (t
|
---|
| 876 | (let ((f (car U)))
|
---|
| 877 | (multiple-value-bind (k div-count)
|
---|
| 878 | (cond-normal-form f (append G (cdr U))
|
---|
| 879 | main-order parameter-order nil ring)
|
---|
| 880 | (cond
|
---|
| 881 | ((zerop div-count)
|
---|
| 882 | (push (list cond1 (append G (list f)) (cdr U)) open))
|
---|
| 883 | (t
|
---|
| 884 | (do ((delta (determine (list k) cond1 parameter-order ring)
|
---|
| 885 | (rest delta)))
|
---|
| 886 | ((endp delta))
|
---|
| 887 | (let* ((eps (caar delta))
|
---|
| 888 | (k1 (caadar delta)))
|
---|
| 889 | (cond
|
---|
| 890 | ((cond-part k1) ;does not reduce to 0
|
---|
| 891 | ;; Replace f with k1 and start all over
|
---|
| 892 | (push (list eps nil (append G (list k1) (cdr U)))
|
---|
| 893 | open))
|
---|
| 894 | (t
|
---|
| 895 | ;; f reduces to 0 so just drop f
|
---|
| 896 | (push (list eps G (cdr U))
|
---|
| 897 | open))))))))))))))
|
---|
| 898 |
|
---|
| 899 |
|
---|
| 900 | (defun green-reduce-colored-poly (cond f parameter-order ring)
|
---|
| 901 | "It takes a colored polynomial F and it returns a modified
|
---|
| 902 | polynomial obtained by reducing coefficient of F modulo green list of
|
---|
| 903 | the condition COND."
|
---|
| 904 | (dotimes (i (length f) f)
|
---|
| 905 | (multiple-value-bind (nf division-count c)
|
---|
| 906 | (normal-form (cadr (nth i f)) (car cond) parameter-order nil ring)
|
---|
| 907 | (declare (ignore division-count))
|
---|
| 908 | (unless (endp nf)
|
---|
| 909 | (setf f (colored-scalar-times-poly c f ring)))
|
---|
| 910 | (setf (cadr (nth i f)) nf))))
|
---|
| 911 |
|
---|
| 912 |
|
---|
| 913 | (defun green-reduce-colored-list (cond fl parameter-order ring)
|
---|
| 914 | "Apply GREEN-REDUCE-COLORED-POLY to a list of polynomials FL."
|
---|
| 915 | (remove-if
|
---|
| 916 | #'endp
|
---|
| 917 | (cond
|
---|
| 918 | ((endp fl) nil)
|
---|
| 919 | (t
|
---|
| 920 | (cons
|
---|
| 921 | (green-reduce-colored-poly cond (car fl) parameter-order ring)
|
---|
| 922 | (green-reduce-colored-list cond (rest fl) parameter-order ring))))))
|
---|
| 923 |
|
---|
| 924 | (defun cond-system-green-reduce (gs parameter-order ring)
|
---|
| 925 | "Apply GREEN-REDUCE-COLORED-LIST to every pair of
|
---|
| 926 | a grobner system GS."
|
---|
| 927 | (cond
|
---|
| 928 | ((endp gs) nil)
|
---|
| 929 | (t (cons
|
---|
| 930 | (list (caar gs) (green-reduce-colored-list
|
---|
| 931 | (caar gs) (cadar gs) parameter-order ring))
|
---|
| 932 | (cond-system-green-reduce (rest gs) parameter-order ring)))))
|
---|
| 933 |
|
---|
| 934 |
|
---|
| 935 | (defun parse-to-colored-poly-list (F vars params main-order parameter-order
|
---|
| 936 | &aux (k (length vars))
|
---|
| 937 | (vars-params (append vars params)))
|
---|
| 938 | "Parse a list of polynomials F, given as a string, with respect to
|
---|
| 939 | a list of variables VARS, given as a list of symbols, to the internal
|
---|
| 940 | representation of a colored polynomial. The polynomials will be properly
|
---|
| 941 | sorted by MAIN-ORDER, with the coefficients, which are polynomials in
|
---|
| 942 | parameters, sorted by PARAMETER-ORDER. Both orders must be admissible
|
---|
| 943 | monomial orders. This form is suitable for parsing polynomials with integer
|
---|
| 944 | coefficients."
|
---|
| 945 | (make-colored-poly-list
|
---|
| 946 | (rest (parse-string-to-alist F vars-params))
|
---|
| 947 | k :main-order main-order :parameter-order parameter-order))
|
---|
| 948 | (defun red-reduction (P pred ring
|
---|
| 949 | &aux
|
---|
| 950 | (P (remove-if #'poly-constant-p P)))
|
---|
| 951 | "Takes a family of polynomials and produce a list whose prime factors
|
---|
| 952 | are the same but they are relatively prime
|
---|
| 953 | Repetitively used the following procedure: it finds two elements f, g of
|
---|
| 954 | P which are not relatively prime; it replaces f and g with f/GCD(f,g),
|
---|
| 955 | g/ GCD(f,f) and GCD(f,g)."
|
---|
| 956 | (when (endp P) (return-from red-reduction))
|
---|
| 957 | (do ((found t))
|
---|
| 958 | ((or (endp (cdr P)) (not found))
|
---|
| 959 | (mapcar #'(lambda (x) (grobner-primitive-part x ring)) P))
|
---|
| 960 | (setf found nil)
|
---|
| 961 | (tagbody
|
---|
| 962 | (do ((Q1 P (rest Q1)))
|
---|
| 963 | ((endp Q1))
|
---|
| 964 | (do ((Q2 (rest Q1) (rest Q2)))
|
---|
| 965 | ((endp Q2))
|
---|
| 966 | (let* ((f (car Q1))
|
---|
| 967 | (g (car Q2))
|
---|
| 968 | (h (grobner-gcd f g pred ring)))
|
---|
| 969 | (unless (poly-constant-p h)
|
---|
| 970 | (setf found t
|
---|
| 971 | P (remove f P)
|
---|
| 972 | P (remove G P)
|
---|
| 973 | P (cons h P))
|
---|
| 974 | (let ((f1 (poly-exact-divide f h pred ring))
|
---|
| 975 | (g1 (poly-exact-divide g h pred ring)))
|
---|
| 976 | (unless (poly-constant-p f1) (push f1 P))
|
---|
| 977 | (unless (poly-constant-p g1) (push g1 P)))
|
---|
| 978 | (go found)))))
|
---|
| 979 | found)))
|
---|