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