source: CGBLisp/src/RCS/string-grobner.lisp,v@ 1

Last change on this file since 1 was 1, checked in by Marek Rychlik, 15 years ago

First import of a version circa 1997.
File size: 9.0 KB
Line 
1head 1.3;
2access;
3symbols;
4locks; strict;
5comment @;;; @;
6
7
81.3
9date 2009.01.22.04.07.58; author marek; state Exp;
10branches;
11next 1.2;
12
131.2
14date 2009.01.19.09.31.18; author marek; state Exp;
15branches;
16next 1.1;
17
181.1
19date 2009.01.19.07.52.58; author marek; state Exp;
20branches;
21next ;
22
23
24desc
25@@
26
27
281.3
29log
30@*** empty log message ***
31@
32text
33@;;; -*- Mode: Common-Lisp; Package: String-Grobner; Base: 10 -*-
34#|
35 $Id$
36 *--------------------------------------------------------------------------*
37 | Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@@math.arizona.edu) |
38 | Department of Mathematics, University of Arizona, Tucson, AZ 85721 |
39 | |
40 | Everyone is permitted to copy, distribute and modify the code in this |
41 | directory, as long as this copyright note is preserved verbatim. |
42 *--------------------------------------------------------------------------*
43|#
44
45
46(defpackage "STRING-GROBNER"
47 (:export
48 string-normal-form
49 string-grobner
50 string-colon-ideal
51 string-ideal-polysaturation-1
52 string-ideal-saturation-1
53 string-ideal-polysaturation
54 string-ideal-saturation
55 string-poly-lcm
56 string-ideal-intersection
57 string-elimination-ideal
58 string-read-poly)
59 (:use "ORDER" "MONOM" "PARSE" "PRINTER" "GROBNER" "TERM" "POLY"
60 "COEFFICIENT-RING" "COMMON-LISP"))
61
62(in-package "STRING-GROBNER")
63
64#+debug(proclaim '(optimize (speed 0) (debug 3)))
65#-debug(proclaim '(optimize (speed 3) (debug 0)))
66
67(defun string-normal-form (f fl vars
68 &key
69 (stream t)
70 (print t)
71 (order #'lex>)
72 (top-reduction-only nil)
73 (ring *coefficient-ring*)
74 (suppress-value t)
75 &aux (vars (read-vars vars)))
76 (let ((f (parse-string-to-sorted-alist f vars order))
77 (fl (parse-string-to-sorted-alist fl vars order)))
78 (format stream "~&Args:")
79 (poly-print fl vars stream)
80 (let ((nf (normal-form (copy-tree f) (rest fl) order top-reduction-only ring)))
81 (terpri stream)
82 (when print
83 (poly-print
84 nf
85 vars
86 stream))
87 (if suppress-value (values) nf))))
88
89(defun string-grobner (plist vars
90 &key (order #'lex>)
91 (start 0)
92 (stream t)
93 (reduce t)
94 (reduce-before t)
95 (suppress-value t)
96 (top-reduction-only nil)
97 (ring *coefficient-ring*)
98 (print t)
99 &aux (vars (read-vars vars)))
100 ;; Turn on some phancy tracing to see the action better
101 (let ((grobner-fun
102 (if reduce #'reduced-grobner #'grobner))
103 (plist (parse-string-to-sorted-alist plist vars order)))
104 (format stream "~&Args:")
105 (poly-print plist vars stream)
106 (setf plist (rest plist))
107 (when reduce-before (setf plist (reduction plist order ring)))
108 (let ((gb (funcall grobner-fun plist order start top-reduction-only ring)))
109 (terpri stream)
110 (when print
111 (poly-print
112 (cons '[ gb)
113 vars
114 stream))
115 (if suppress-value (values) gb))))
116
117(defun string-elimination-ideal (flist vars k
118 &key (stream t)
119 (key #'identity)
120 (primary-order #'grevlex>)
121 (secondary-order #'grevlex>)
122 (suppress-value t)
123 (order (elimination-order
124 k
125 :primary-order primary-order
126 :secondary-order secondary-order
127 ))
128 &aux (vars (read-vars vars)))
129 (let ((id (ring-intersection
130 (string-grobner flist vars
131 :order order
132 :suppress-value nil
133 :stream stream
134 :print nil)
135 k :key key)))
136 (poly-print (cons '[ id) vars stream)
137 (if suppress-value (values) id)))
138
139
140(defun string-ideal-intersection (f g vars
141 &key (order #'lex>)
142 (top-reduction-only nil)
143 (ring *coefficient-ring*)
144 (stream t)
145 (suppress-value t)
146 &aux (vars (read-vars vars))
147 (f (parse-string-to-sorted-alist
148 f vars order))
149 (g (parse-string-to-sorted-alist
150 g vars order)))
151 (let ((id (ideal-intersection (rest f) (rest g) order top-reduction-only ring)))
152 (poly-print (cons '[ id) vars stream)
153 (if suppress-value (values) id)))
154
155(defun string-poly-lcm (f g vars
156 &key (order #'lex>)
157 (ring *coefficient-ring*)
158 (stream t)
159 (suppress-value t)
160 &aux (vars (read-vars vars))
161 (f (parse-string-to-sorted-alist
162 f vars order))
163 (g (parse-string-to-sorted-alist
164 g vars order)))
165 (let ((lcm (poly-lcm f g order ring)))
166 (poly-print lcm vars stream)
167 (if suppress-value (values) lcm)))
168
169(defun string-ideal-saturation-1 (F p vars
170 &key (order #'lex>) (start 0)
171 (top-reduction-only nil)
172 (ring *coefficient-ring*)
173 (stream t)
174 (suppress-value t)
175 &aux (vars (read-vars vars))
176 (F (parse-string-to-sorted-alist
177 F vars order))
178 (p (parse-string-to-sorted-alist
179 p vars order)))
180 (let ((id (ideal-saturation-1 (rest F) p order start top-reduction-only ring)))
181 (poly-print (cons '[ id) vars stream)
182 (if suppress-value (values) id)))
183
184(defun string-ideal-polysaturation-1 (F plist vars
185 &key (order #'lex>) (start 0)
186 (top-reduction-only nil)
187 (ring *coefficient-ring*)
188 (stream t)
189 (suppress-value t)
190 &aux (vars (read-vars vars))
191 (F (parse-string-to-sorted-alist
192 F vars order))
193 (plist (parse-string-to-sorted-alist
194 plist vars order)))
195 (format stream "~&Args1:")
196 (poly-print F vars stream)
197 (format stream "~&Args2:")
198 (poly-print plist vars stream)
199 (terpri stream)
200 (let ((id (ideal-polysaturation-1 (rest F) (rest plist) order start top-reduction-only ring)))
201 (poly-print (cons '[ id) vars stream)
202 (if suppress-value (values) id)))
203
204(defun string-ideal-saturation (F G vars
205 &key (order #'lex>) (start 0)
206 (top-reduction-only nil)
207 (ring *coefficient-ring*)
208 (stream t)
209 (suppress-value t)
210 &aux (vars (read-vars vars))
211 (F (parse-string-to-sorted-alist
212 F vars order))
213 (G (parse-string-to-sorted-alist
214 G vars order)))
215 (let ((id (ideal-saturation (rest F) (rest G) order start top-reduction-only ring)))
216 (poly-print (cons '[ id) vars stream)
217 (if suppress-value (values) id)))
218
219(defun string-ideal-polysaturation (F ideal-list vars
220 &key (order #'lex>) (start 0)
221 (top-reduction-only nil)
222 (ring *coefficient-ring*)
223 (stream t)
224 (suppress-value t)
225 &aux (vars (read-vars vars))
226 (F (parse-string-to-sorted-alist
227 F vars order))
228 (ideal-list
229 (mapcar #'(lambda (G) (parse-string-to-sorted-alist
230 G vars order))
231 ideal-list)))
232 (format stream "~&Args1:")
233 (poly-print F vars stream)
234 (format stream "~&Args2:")
235 (dolist (G ideal-list)
236 (poly-print G vars stream))
237 (terpri stream)
238 (let ((id (ideal-polysaturation (rest F) (mapcar #'rest ideal-list) order start top-reduction-only ring)))
239 (poly-print (cons '[ id) vars stream)
240 (if suppress-value (values) id)))
241
242
243
244(defun string-colon-ideal (F G vars
245 &key (top-reduction-only nil)
246 (ring *coefficient-ring*)
247 (stream t)
248 (order #'lex>)
249 (suppress-value t)
250 &aux (vars (read-vars vars))
251 (F (parse-string-to-sorted-alist
252 F vars order))
253 (G (parse-string-to-sorted-alist
254 G vars order)))
255 (format stream "~&Args1:")
256 (poly-print F vars stream)
257 (format stream "~&Args2:")
258 (poly-print G vars stream)
259 (let ((id (colon-ideal (rest F) (rest G) order top-reduction-only ring)))
260 (poly-print (cons '[ id) vars stream)
261 (if suppress-value (values) id)))
262
263;;----------------------------------------------------------------
264;; An enhanced polynomial reader
265;;----------------------------------------------------------------
266(defun string-read-poly (F vars
267 &key (order #'lex>)
268 (suppress-value nil)
269 (stream t)
270 (convert-rational-to-integer t)
271 &aux (vars (read-vars vars))
272 (F (parse-string-to-sorted-alist F vars order)))
273 (when convert-rational-to-integer
274 (if (eq (car F) '[)
275 (setf F (cons (car F) (mapcar #'poly-rational-to-integer (rest F))))
276 (setf F (poly-rational-to-integer F))))
277 (format stream "~&Args:")
278 (poly-print F vars stream)
279 (terpri stream)
280 (if suppress-value (values) F))
281
282
283;; Multiply by lcm of denominators of coefficients
284(defun poly-rational-to-integer (p &optional (ring *coefficient-ring*))
285 (let ((c (apply (ring-lcm ring) (mapcar (ring-denominator ring) (mapcar #'cdr p)))))
286 (scalar-times-poly c p ring)))
287
288(defun read-vars (string-or-list)
289 "Read a list of variables, specified either as a list of symbols or a string
290listing variables in the form of a comma-separated list, delimited by [,]"
291 (typecase string-or-list
292 (list string-or-list)
293 (string (with-input-from-string (s string-or-list) (rest (parse s))))))@
294
295
2961.2
297log
298@*** empty log message ***
299@
300text
301@d32 2
302a33 2
303;;(proclaim '(optimize (speed 0) (debug 3)))
304(proclaim '(optimize (speed 3) (debug 0)))
305@
306
307
3081.1
309log
310@Initial revision
311@
312text
313@d3 1
314a3 1
315 $Id: string-grobner.lisp,v 1.34 1997/12/13 16:05:50 marek Exp $
316d32 2
317a33 1
318(proclaim '(optimize (speed 0) (debug 3)))
319@
Note: See TracBrowser for help on using the repository browser.