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