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

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

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