source: CGBLisp/trunk/src/string-grobner.lisp@ 98

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

Removed useless RCS version info. Added missing Emacs mode lines.
File size: 8.3 KB
Line 
1;;; -*- Mode: Common-Lisp; Package: String-Grobner; Base: 10 -*-
2#|
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
12
13(defpackage "STRING-GROBNER"
14 (:export
15 string-normal-form
16 string-grobner
17 string-colon-ideal
18 string-ideal-polysaturation-1
19 string-ideal-saturation-1
20 string-ideal-polysaturation
21 string-ideal-saturation
22 string-poly-lcm
23 string-ideal-intersection
24 string-elimination-ideal
25 string-read-poly)
26 (:use "ORDER" "MONOM" "PARSE" "PRINTER" "GROBNER" "TERM" "POLY"
27 "COEFFICIENT-RING" "COMMON-LISP"))
28
29(in-package "STRING-GROBNER")
30
31(proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 3)))
32
33(defun string-normal-form (f fl vars
34 &key
35 (stream t)
36 (print t)
37 (order #'lex>)
38 (top-reduction-only nil)
39 (ring *coefficient-ring*)
40 (suppress-value t)
41 &aux (vars (read-vars vars)))
42 (let ((f (parse-string-to-sorted-alist f vars order))
43 (fl (parse-string-to-sorted-alist fl vars order)))
44 (format stream "~&Args:")
45 (poly-print fl vars stream)
46 (let ((nf (normal-form (copy-tree f) (rest fl) order top-reduction-only ring)))
47 (terpri stream)
48 (when print
49 (poly-print
50 nf
51 vars
52 stream))
53 (if suppress-value (values) nf))))
54
55(defun string-grobner (plist vars
56 &key (order #'lex>)
57 (start 0)
58 (stream t)
59 (reduce t)
60 (reduce-before t)
61 (suppress-value t)
62 (top-reduction-only nil)
63 (ring *coefficient-ring*)
64 (print t)
65 &aux (vars (read-vars vars)))
66 ;; Turn on some phancy tracing to see the action better
67 (let ((grobner-fun
68 (if reduce #'reduced-grobner #'grobner))
69 (plist (parse-string-to-sorted-alist plist vars order)))
70 (format stream "~&Args:")
71 (poly-print plist vars stream)
72 (setf plist (rest plist))
73 (when reduce-before (setf plist (reduction plist order ring)))
74 (let ((gb (funcall grobner-fun plist order start top-reduction-only ring)))
75 (terpri stream)
76 (when print
77 (poly-print
78 (cons '[ gb)
79 vars
80 stream))
81 (if suppress-value (values) gb))))
82
83(defun string-elimination-ideal (flist vars k
84 &key (stream t)
85 (key #'identity)
86 (primary-order #'grevlex>)
87 (secondary-order #'grevlex>)
88 (suppress-value t)
89 (order (elimination-order
90 k
91 :primary-order primary-order
92 :secondary-order secondary-order
93 ))
94 &aux (vars (read-vars vars)))
95 (let ((id (ring-intersection
96 (string-grobner flist vars
97 :order order
98 :suppress-value nil
99 :stream stream
100 :print nil)
101 k :key key)))
102 (poly-print (cons '[ id) vars stream)
103 (if suppress-value (values) id)))
104
105
106(defun string-ideal-intersection (f g vars
107 &key (order #'lex>)
108 (top-reduction-only nil)
109 (ring *coefficient-ring*)
110 (stream t)
111 (suppress-value t)
112 &aux (vars (read-vars vars))
113 (f (parse-string-to-sorted-alist
114 f vars order))
115 (g (parse-string-to-sorted-alist
116 g vars order)))
117 (let ((id (ideal-intersection (rest f) (rest g) order top-reduction-only ring)))
118 (poly-print (cons '[ id) vars stream)
119 (if suppress-value (values) id)))
120
121(defun string-poly-lcm (f g vars
122 &key (order #'lex>)
123 (ring *coefficient-ring*)
124 (stream t)
125 (suppress-value t)
126 &aux (vars (read-vars vars))
127 (f (parse-string-to-sorted-alist
128 f vars order))
129 (g (parse-string-to-sorted-alist
130 g vars order)))
131 (let ((lcm (poly-lcm f g order ring)))
132 (poly-print lcm vars stream)
133 (if suppress-value (values) lcm)))
134
135(defun string-ideal-saturation-1 (F p vars
136 &key (order #'lex>) (start 0)
137 (top-reduction-only nil)
138 (ring *coefficient-ring*)
139 (stream t)
140 (suppress-value t)
141 &aux (vars (read-vars vars))
142 (F (parse-string-to-sorted-alist
143 F vars order))
144 (p (parse-string-to-sorted-alist
145 p vars order)))
146 (let ((id (ideal-saturation-1 (rest F) p order start top-reduction-only ring)))
147 (poly-print (cons '[ id) vars stream)
148 (if suppress-value (values) id)))
149
150(defun string-ideal-polysaturation-1 (F plist vars
151 &key (order #'lex>) (start 0)
152 (top-reduction-only nil)
153 (ring *coefficient-ring*)
154 (stream t)
155 (suppress-value t)
156 &aux (vars (read-vars vars))
157 (F (parse-string-to-sorted-alist
158 F vars order))
159 (plist (parse-string-to-sorted-alist
160 plist vars order)))
161 (format stream "~&Args1:")
162 (poly-print F vars stream)
163 (format stream "~&Args2:")
164 (poly-print plist vars stream)
165 (terpri stream)
166 (let ((id (ideal-polysaturation-1 (rest F) (rest plist) order start top-reduction-only ring)))
167 (poly-print (cons '[ id) vars stream)
168 (if suppress-value (values) id)))
169
170(defun string-ideal-saturation (F G vars
171 &key (order #'lex>) (start 0)
172 (top-reduction-only nil)
173 (ring *coefficient-ring*)
174 (stream t)
175 (suppress-value t)
176 &aux (vars (read-vars vars))
177 (F (parse-string-to-sorted-alist
178 F vars order))
179 (G (parse-string-to-sorted-alist
180 G vars order)))
181 (let ((id (ideal-saturation (rest F) (rest G) order start top-reduction-only ring)))
182 (poly-print (cons '[ id) vars stream)
183 (if suppress-value (values) id)))
184
185(defun string-ideal-polysaturation (F ideal-list vars
186 &key (order #'lex>) (start 0)
187 (top-reduction-only nil)
188 (ring *coefficient-ring*)
189 (stream t)
190 (suppress-value t)
191 &aux (vars (read-vars vars))
192 (F (parse-string-to-sorted-alist
193 F vars order))
194 (ideal-list
195 (mapcar #'(lambda (G) (parse-string-to-sorted-alist
196 G vars order))
197 ideal-list)))
198 (format stream "~&Args1:")
199 (poly-print F vars stream)
200 (format stream "~&Args2:")
201 (dolist (G ideal-list)
202 (poly-print G vars stream))
203 (terpri stream)
204 (let ((id (ideal-polysaturation (rest F) (mapcar #'rest ideal-list) order start top-reduction-only ring)))
205 (poly-print (cons '[ id) vars stream)
206 (if suppress-value (values) id)))
207
208
209
210(defun string-colon-ideal (F G vars
211 &key (top-reduction-only nil)
212 (ring *coefficient-ring*)
213 (stream t)
214 (order #'lex>)
215 (suppress-value t)
216 &aux (vars (read-vars vars))
217 (F (parse-string-to-sorted-alist
218 F vars order))
219 (G (parse-string-to-sorted-alist
220 G vars order)))
221 (format stream "~&Args1:")
222 (poly-print F vars stream)
223 (format stream "~&Args2:")
224 (poly-print G vars stream)
225 (let ((id (colon-ideal (rest F) (rest G) order top-reduction-only ring)))
226 (poly-print (cons '[ id) vars stream)
227 (if suppress-value (values) id)))
228
229;;----------------------------------------------------------------
230;; An enhanced polynomial reader
231;;----------------------------------------------------------------
232(defun string-read-poly (F vars
233 &key (order #'lex>)
234 (suppress-value nil)
235 (stream t)
236 (convert-rational-to-integer t)
237 &aux (vars (read-vars vars))
238 (F (parse-string-to-sorted-alist F vars order)))
239 (when convert-rational-to-integer
240 (if (eq (car F) '[)
241 (setf F (cons (car F) (mapcar #'poly-rational-to-integer (rest F))))
242 (setf F (poly-rational-to-integer F))))
243 (format stream "~&Args:")
244 (poly-print F vars stream)
245 (terpri stream)
246 (if suppress-value (values) F))
247
248
249;; Multiply by lcm of denominators of coefficients
250(defun poly-rational-to-integer (p &optional (ring *coefficient-ring*))
251 (let ((c (apply (ring-lcm ring) (mapcar (ring-denominator ring) (mapcar #'cdr p)))))
252 (scalar-times-poly c p ring)))
253
254(defun read-vars (string-or-list)
255 "Read a list of variables, specified either as a list of symbols or a string
256listing variables in the form of a comma-separated list, delimited by [,]"
257 (typecase string-or-list
258 (list string-or-list)
259 (string (with-input-from-string (s string-or-list) (rest (parse s))))))
Note: See TracBrowser for help on using the repository browser.