1 | head 1.11;
|
---|
2 | access;
|
---|
3 | symbols;
|
---|
4 | locks; strict;
|
---|
5 | comment @;;; @;
|
---|
6 |
|
---|
7 |
|
---|
8 | 1.11
|
---|
9 | date 2009.01.22.04.05.13; author marek; state Exp;
|
---|
10 | branches;
|
---|
11 | next 1.10;
|
---|
12 |
|
---|
13 | 1.10
|
---|
14 | date 2009.01.21.23.37.07; author marek; state Exp;
|
---|
15 | branches;
|
---|
16 | next 1.9;
|
---|
17 |
|
---|
18 | 1.9
|
---|
19 | date 2009.01.21.23.36.04; author marek; state Exp;
|
---|
20 | branches;
|
---|
21 | next 1.8;
|
---|
22 |
|
---|
23 | 1.8
|
---|
24 | date 2009.01.21.23.24.21; author marek; state Exp;
|
---|
25 | branches;
|
---|
26 | next 1.7;
|
---|
27 |
|
---|
28 | 1.7
|
---|
29 | date 2009.01.21.19.40.18; author marek; state Exp;
|
---|
30 | branches;
|
---|
31 | next 1.6;
|
---|
32 |
|
---|
33 | 1.6
|
---|
34 | date 2009.01.21.19.38.54; author marek; state Exp;
|
---|
35 | branches;
|
---|
36 | next 1.5;
|
---|
37 |
|
---|
38 | 1.5
|
---|
39 | date 2009.01.21.19.36.16; author marek; state Exp;
|
---|
40 | branches;
|
---|
41 | next 1.4;
|
---|
42 |
|
---|
43 | 1.4
|
---|
44 | date 2009.01.21.07.20.43; author marek; state Exp;
|
---|
45 | branches;
|
---|
46 | next 1.3;
|
---|
47 |
|
---|
48 | 1.3
|
---|
49 | date 2009.01.19.09.28.06; author marek; state Exp;
|
---|
50 | branches;
|
---|
51 | next 1.2;
|
---|
52 |
|
---|
53 | 1.2
|
---|
54 | date 2009.01.19.07.42.23; author marek; state Exp;
|
---|
55 | branches;
|
---|
56 | next 1.1;
|
---|
57 |
|
---|
58 | 1.1
|
---|
59 | date 2009.01.19.07.36.08; author marek; state Exp;
|
---|
60 | branches;
|
---|
61 | next ;
|
---|
62 |
|
---|
63 |
|
---|
64 | desc
|
---|
65 | @@
|
---|
66 |
|
---|
67 |
|
---|
68 | 1.11
|
---|
69 | log
|
---|
70 | @*** empty log message ***
|
---|
71 | @
|
---|
72 | text
|
---|
73 | @;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
|
---|
74 | #|
|
---|
75 | $Id$
|
---|
76 | *--------------------------------------------------------------------------*
|
---|
77 | | Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@@math.arizona.edu) |
|
---|
78 | | Department of Mathematics, University of Arizona, Tucson, AZ 85721 |
|
---|
79 | | |
|
---|
80 | | Everyone is permitted to copy, distribute and modify the code in this |
|
---|
81 | | directory, as long as this copyright note is preserved verbatim. |
|
---|
82 | *--------------------------------------------------------------------------*
|
---|
83 | |#
|
---|
84 | (defpackage "PARSE"
|
---|
85 | (:export parse parse-to-alist parse-string-to-alist
|
---|
86 | parse-to-sorted-alist parse-string-to-sorted-alist ^ [
|
---|
87 | poly-eval)
|
---|
88 | (:use "ORDER" "POLY" "COEFFICIENT-RING" "COMMON-LISP")
|
---|
89 | (:shadow sort-poly))
|
---|
90 |
|
---|
91 | (in-package "PARSE")
|
---|
92 |
|
---|
93 | #+debug(proclaim '(optimize (speed 0) (debug 3)))
|
---|
94 | #-debug(proclaim '(optimize (speed 3) (debug 0)))
|
---|
95 |
|
---|
96 | ;; The function PARSE yields the representations as above. The two functions
|
---|
97 | ;; PARSE-TO-ALIST and PARSE-STRING-TO-ALIST parse polynomials to the alist
|
---|
98 | ;; representations. For example
|
---|
99 | ;;
|
---|
100 | ;; >(parse)x^2-y^2+(-4/3)*u^2*w^3-5 --->
|
---|
101 | ;; (+ (* 1 (^ X 2)) (* -1 (^ Y 2)) (* -4/3 (^ U 2) (^ W 3)) (* -5))
|
---|
102 | ;;
|
---|
103 | ;; >(parse-to-alist '(x y u w))x^2-y^2+(-4/3)*u^2*w^3-5 --->
|
---|
104 | ;; (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1) ((0 0 0 0) . -5))
|
---|
105 | ;;
|
---|
106 | ;; >(parse-string-to-alist "x^2-y^2+(-4/3)*u^2*w^3-5" '(x y u w)) --->
|
---|
107 | ;; (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1) ((0 0 0 0) . -5))
|
---|
108 | ;;
|
---|
109 | ;; >(parse-string-to-alist "[x^2-y^2+(-4/3)*u^2*w^3-5,y]" '(x y u w))
|
---|
110 | ;; ([ (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1)
|
---|
111 | ;; ((0 0 0 0) . -5))
|
---|
112 | ;; (((0 1 0 0) . 1)))
|
---|
113 | ;; The functions PARSE-TO-SORTED-ALIST and PARSE-STRING-TO-SORTED-ALIST
|
---|
114 | ;; in addition sort terms by the predicate defined in the ORDER package
|
---|
115 | ;; For instance:
|
---|
116 | ;; >(parse-to-sorted-alist '(x y u w))x^2-y^2+(-4/3)*u^2*w^3-5
|
---|
117 | ;; (((2 0 0 0) . 1) ((0 2 0 0) . -1) ((0 0 2 3) . -4/3) ((0 0 0 0) . -5))
|
---|
118 | ;; >(parse-to-sorted-alist '(x y u w) t #'grlex>)x^2-y^2+(-4/3)*u^2*w^3-5
|
---|
119 | ;; (((0 0 2 3) . -4/3) ((2 0 0 0) . 1) ((0 2 0 0) . -1) ((0 0 0 0) . -5))
|
---|
120 |
|
---|
121 | ;;(eval-when (compile)
|
---|
122 | ;; (proclaim '(optimize safety)))
|
---|
123 |
|
---|
124 | (defun convert-number (number-or-poly n)
|
---|
125 | "Returns NUMBER-OR-POLY, if it is a polynomial. If it is a number,
|
---|
126 | it converts it to the constant monomial in N variables. If the result
|
---|
127 | is a number then convert it to a polynomial in N variables."
|
---|
128 | (if (numberp number-or-poly)
|
---|
129 | (list (cons (make-list n :initial-element 0) number-or-poly))
|
---|
130 | number-or-poly))
|
---|
131 |
|
---|
132 | (defun $poly+ (p q n order ring)
|
---|
133 | "Add two polynomials P and Q, where each polynomial is either a
|
---|
134 | numeric constant or a polynomial in internal representation. If the
|
---|
135 | result is a number then convert it to a polynomial in N variables."
|
---|
136 | (poly+ (convert-number p n) (convert-number q n) order ring))
|
---|
137 |
|
---|
138 | (defun $poly- (p q n order ring)
|
---|
139 | "Subtract two polynomials P and Q, where each polynomial is either a
|
---|
140 | numeric constant or a polynomial in internal representation. If the
|
---|
141 | result is a number then convert it to a polynomial in N variables."
|
---|
142 | (poly- (convert-number p n) (convert-number q n) order ring))
|
---|
143 |
|
---|
144 | (defun $minus-poly (p n ring)
|
---|
145 | "Negation of P is a polynomial is either a numeric constant or a
|
---|
146 | polynomial in internal representation. If the result is a number then
|
---|
147 | convert it to a polynomial in N variables."
|
---|
148 | (minus-poly (convert-number p n) ring))
|
---|
149 |
|
---|
150 | (defun $poly* (p q n order ring)
|
---|
151 | "Multiply two polynomials P and Q, where each polynomial is either a
|
---|
152 | numeric constant or a polynomial in internal representation. If the
|
---|
153 | result is a number then convert it to a polynomial in N variables."
|
---|
154 | (poly* (convert-number p n) (convert-number q n) order ring))
|
---|
155 |
|
---|
156 | (defun $poly/ (p q ring)
|
---|
157 | "Divide a polynomials P which is either a numeric constant or a
|
---|
158 | polynomial in internal representation, by a number Q."
|
---|
159 | (if (numberp p)
|
---|
160 | (common-lisp:/ p q)
|
---|
161 | (scalar-times-poly (common-lisp:/ q) p ring)))
|
---|
162 |
|
---|
163 | (defun $poly-expt (p l n order ring)
|
---|
164 | "Raise polynomial P, which is a polynomial in internal
|
---|
165 | representation or a numeric constant, to power L. If P is a number,
|
---|
166 | convert the result to a polynomial in N variables."
|
---|
167 | (poly-expt (convert-number p n) l order ring))
|
---|
168 |
|
---|
169 | (defun parse (&optional stream)
|
---|
170 | "Parser of infis expressions with integer/rational coefficients
|
---|
171 | The parser will recognize two kinds of polynomial expressions:
|
---|
172 |
|
---|
173 | - polynomials in fully expanded forms with coefficients
|
---|
174 | written in front of symbolic expressions; constants can be optionally
|
---|
175 | enclosed in (); for example, the infix form
|
---|
176 | X^2-Y^2+(-4/3)*U^2*W^3-5
|
---|
177 | parses to
|
---|
178 | (+ (- (EXPT X 2) (EXPT Y 2)) (* (- (/ 4 3)) (EXPT U 2) (EXPT W 3)) (- 5))
|
---|
179 |
|
---|
180 | - lists of polynomials; for example
|
---|
181 | [X-Y, X^2+3*Z]
|
---|
182 | parses to
|
---|
183 | (:[ (- X Y) (+ (EXPT X 2) (* 3 Z)))
|
---|
184 | where the first symbol [ marks a list of polynomials.
|
---|
185 |
|
---|
186 | -other infix expressions, for example
|
---|
187 | [(X-Y)*(X+Y)/Z,(X+1)^2]
|
---|
188 | parses to:
|
---|
189 | (:[ (/ (* (- X Y) (+ X Y)) Z) (EXPT (+ X 1) 2))
|
---|
190 | Currently this function is implemented using M. Kantrowitz's INFIX package."
|
---|
191 | (read-from-string
|
---|
192 | (concatenate 'string
|
---|
193 | "#I("
|
---|
194 | (with-output-to-string (s)
|
---|
195 | (loop
|
---|
196 | (multiple-value-bind (line eof)
|
---|
197 | (read-line stream t)
|
---|
198 | (format s "~A" line)
|
---|
199 | (when eof (return)))))
|
---|
200 | ")")))
|
---|
201 |
|
---|
202 | ;; Translate output from parse to a pure list form
|
---|
203 | ;; assuming variables are VARS
|
---|
204 |
|
---|
205 | (defun alist-form (plist vars)
|
---|
206 | "Translates an expression PLIST, which should be a list of polynomials
|
---|
207 | in variables VARS, to an alist representation of a polynomial.
|
---|
208 | It returns the alist. See also PARSE-TO-ALIST."
|
---|
209 | (cond
|
---|
210 | ((endp plist) nil)
|
---|
211 | ((eql (first plist) '[)
|
---|
212 | (cons '[ (mapcar #'(lambda (x) (alist-form x vars)) (rest plist))))
|
---|
213 | (t
|
---|
214 | (assert (eql (car plist) '+))
|
---|
215 | (alist-form-1 (rest plist) vars))))
|
---|
216 |
|
---|
217 | (defun alist-form-1 (p vars
|
---|
218 | &aux (ht (make-hash-table
|
---|
219 | :test #'equal :size 16))
|
---|
220 | stack)
|
---|
221 | (dolist (term p)
|
---|
222 | (assert (eql (car term) '*))
|
---|
223 | (incf (gethash (powers (cddr term) vars) ht 0) (second term)))
|
---|
224 | (maphash #'(lambda (key value) (unless (zerop value)
|
---|
225 | (push (cons key value) stack))) ht)
|
---|
226 | stack)
|
---|
227 |
|
---|
228 | (defun powers (monom vars
|
---|
229 | &aux (tab (pairlis vars (make-list (length vars)
|
---|
230 | :initial-element 0))))
|
---|
231 | (dolist (e monom (mapcar #'(lambda (v) (cdr (assoc v tab))) vars))
|
---|
232 | (assert (equal (first e) '^))
|
---|
233 | (assert (integerp (third e)))
|
---|
234 | (assert (= (length e) 3))
|
---|
235 | (let ((x (assoc (second e) tab)))
|
---|
236 | (if (null x) (error "Variable ~a not in the list of variables."
|
---|
237 | (second e))
|
---|
238 | (incf (cdr x) (third e))))))
|
---|
239 |
|
---|
240 |
|
---|
241 | ;; New implementation based on the INFIX package of Mark Kantorowitz
|
---|
242 | (defun parse-to-alist (vars &optional stream)
|
---|
243 | "Parse an expression already in prefix form to an association list form
|
---|
244 | according to the internal CGBlisp polynomial syntax: a polynomial is an
|
---|
245 | alist of pairs (MONOM . COEFFICIENT). For example:
|
---|
246 | (WITH-INPUT-FROM-STRING (S \"X^2-Y^2+(-4/3)*U^2*W^3-5\")
|
---|
247 | (PARSE-TO-ALIST '(X Y U W) S))
|
---|
248 | evaluates to
|
---|
249 | (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1) ((0 0 0 0) . -5))"
|
---|
250 | (poly-eval (parse stream) vars))
|
---|
251 |
|
---|
252 |
|
---|
253 | (defun parse-string-to-alist (str vars)
|
---|
254 | "Parse string STR and return a polynomial as a sorted association
|
---|
255 | list of pairs (MONOM . COEFFICIENT). For example:
|
---|
256 | (parse-string-to-alist \"[x^2-y^2+(-4/3)*u^2*w^3-5,y]\" '(x y u w))
|
---|
257 | ([ (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1)
|
---|
258 | ((0 0 0 0) . -5))
|
---|
259 | (((0 1 0 0) . 1)))
|
---|
260 | The functions PARSE-TO-SORTED-ALIST and PARSE-STRING-TO-SORTED-ALIST
|
---|
261 | sort terms by the predicate defined in the ORDER package."
|
---|
262 | (with-input-from-string (stream str)
|
---|
263 | (parse-to-alist vars stream)))
|
---|
264 |
|
---|
265 |
|
---|
266 | (defun parse-to-sorted-alist (vars &optional (order #'lex>) (stream t))
|
---|
267 | "Parses streasm STREAM and returns a polynomial represented as
|
---|
268 | a sorted alist. For example:
|
---|
269 | (WITH-INPUT-FROM-STRING (S \"X^2-Y^2+(-4/3)*U^2*W^3-5\")
|
---|
270 | (PARSE-TO-SORTED-ALIST '(X Y U W) S))
|
---|
271 | returns
|
---|
272 | (((2 0 0 0) . 1) ((0 2 0 0) . -1) ((0 0 2 3) . -4/3) ((0 0 0 0) . -5))
|
---|
273 | and
|
---|
274 | (WITH-INPUT-FROM-STRING (S \"X^2-Y^2+(-4/3)*U^2*W^3-5\")
|
---|
275 | (PARSE-TO-SORTED-ALIST '(X Y U W) T #'GRLEX>) S)
|
---|
276 | returns
|
---|
277 | (((0 0 2 3) . -4/3) ((2 0 0 0) . 1) ((0 2 0 0) . -1) ((0 0 0 0) . -5))"
|
---|
278 | (sort-poly (parse-to-alist vars stream) order))
|
---|
279 |
|
---|
280 | (defun parse-string-to-sorted-alist (str vars &optional (order #'lex>))
|
---|
281 | "Parse a string to a sorted alist form, the internal representation
|
---|
282 | of polynomials used by our system."
|
---|
283 | (with-input-from-string (stream str)
|
---|
284 | (parse-to-sorted-alist vars order stream)))
|
---|
285 |
|
---|
286 | (defun sort-poly-1 (p order)
|
---|
287 | "Sort the terms of a single polynomial P using an admissible monomial order ORDER.
|
---|
288 | Returns the sorted polynomial. Destructively modifies P."
|
---|
289 | (sort p order :key #'first))
|
---|
290 |
|
---|
291 | ;; Sort a polynomial or polynomial list
|
---|
292 | (defun sort-poly (poly-or-poly-list &optional (order #'lex>))
|
---|
293 | "Sort POLY-OR-POLY-LIST, which could be either a single polynomial
|
---|
294 | or a list of polynomials in internal alist representation, using
|
---|
295 | admissible monomial order ORDER. Each polynomial is sorted using
|
---|
296 | SORT-POLY-1."
|
---|
297 | (cond
|
---|
298 | ((eql poly-or-poly-list :syntax-error) nil)
|
---|
299 | ((null poly-or-poly-list) nil)
|
---|
300 | ((eql (car poly-or-poly-list) '[)
|
---|
301 | (cons '[ (mapcar #'(lambda (p) (sort-poly-1 p order))
|
---|
302 | (rest poly-or-poly-list))))
|
---|
303 | (t (sort-poly-1 poly-or-poly-list order))))
|
---|
304 |
|
---|
305 | (defun poly-eval-1 (expr vars order ring &aux (n (length vars)))
|
---|
306 | "Evaluate an expression EXPR as polynomial
|
---|
307 | by substituting operators + - * expt with
|
---|
308 | corresponding polynomial operators
|
---|
309 | and variables VARS with monomials (1 0 ... 0), (0 1 ... 0) etc.
|
---|
310 | We use special versions of binary
|
---|
311 | operators $poly+, $poly-, $minus-poly, $poly* and $poly-expt
|
---|
312 | which work like the corresponding functions in the
|
---|
313 | POLY package, but accept scalars as arguments as well."
|
---|
314 | (eval
|
---|
315 | (sublis
|
---|
316 | (pairlis '(+ - * / expt)
|
---|
317 | `((lambda (&rest r) (reduce #'(lambda (p q) ($poly+ p q ,n ,order ,ring)) r))
|
---|
318 | (lambda (p &rest r)
|
---|
319 | (if (endp r) ($minus-poly p ,n ,ring)
|
---|
320 | ($poly- p (reduce #'(lambda (p q) ($poly+ p q ,n ,order ,ring)) r) ,n
|
---|
321 | ,order ,ring)))
|
---|
322 | (lambda (&rest r) (reduce #'(lambda (p q) ($poly* p q ,n ,order ,ring)) r))
|
---|
323 | (lambda (p q) ($poly/ p q ,ring))
|
---|
324 | (lambda (p l) ($poly-expt p l ,n ,order ,ring))))
|
---|
325 | (sublis
|
---|
326 | (pairlis vars (monom-basis (length vars)))
|
---|
327 | expr))))
|
---|
328 |
|
---|
329 | (defun poly-eval (expr vars &optional (order #'lex>) (ring *coefficient-ring*))
|
---|
330 | "Evaluate an expression EXPR, which should be a polynomial
|
---|
331 | expression or a list of polynomial expressions (a list of expressions
|
---|
332 | marked by prepending keyword :[ to it) given in lisp prefix notation,
|
---|
333 | in variables VARS, which should be a list of symbols. The result of
|
---|
334 | the evaluation is a polynomial or a list of polynomials (marked by
|
---|
335 | prepending symbol '[) in the internal alist form. This evaluator is
|
---|
336 | used by the PARSE package to convert input from strings directly to
|
---|
337 | internal form."
|
---|
338 | (cond
|
---|
339 | ((numberp expr) (list (cons (make-list (length vars) :initial-element 0) expr)))
|
---|
340 | ((or (symbolp expr) (not (eq (car expr) :[)))
|
---|
341 | (poly-eval-1 expr vars order ring))
|
---|
342 | (t (cons '[ (mapcar #'(lambda (p) (poly-eval-1 p vars order ring)) (rest expr))))))
|
---|
343 |
|
---|
344 |
|
---|
345 | ;; Return the standard basis of the monomials in n variables
|
---|
346 | (defun monom-basis (n &aux
|
---|
347 | (basis
|
---|
348 | (copy-tree
|
---|
349 | (make-list n :initial-element
|
---|
350 | (list 'quote (list (cons
|
---|
351 | (make-list
|
---|
352 | n
|
---|
353 | :initial-element 0)
|
---|
354 | 1)))))))
|
---|
355 | "Generate a list of monomials ((1 0 ... 0) (0 1 0 ... 0) ... (0 0 ... 1)
|
---|
356 | which correspond to linear monomials X1, X2, ... XN."
|
---|
357 | (dotimes (i n basis)
|
---|
358 | (setf (elt (caaadr (elt basis i)) i) 1)))
|
---|
359 | @
|
---|
360 |
|
---|
361 |
|
---|
362 | 1.10
|
---|
363 | log
|
---|
364 | @*** empty log message ***
|
---|
365 | @
|
---|
366 | text
|
---|
367 | @d21 2
|
---|
368 | a22 2
|
---|
369 | ;;(proclaim '(optimize (speed 0) (debug 3)))
|
---|
370 | (proclaim '(optimize (speed 3) (debug 0)))
|
---|
371 | @
|
---|
372 |
|
---|
373 |
|
---|
374 | 1.9
|
---|
375 | log
|
---|
376 | @*** empty log message ***
|
---|
377 | @
|
---|
378 | text
|
---|
379 | @d3 1
|
---|
380 | a3 1
|
---|
381 | $Id: parse.lisp,v 1.8 2009/01/21 23:24:21 marek Exp marek $
|
---|
382 | d248 1
|
---|
383 | a248 1
|
---|
384 | ($poly- p (reduce #'(lambda (p q) ($poly+ p q n ,order ,ring)) r) ,n
|
---|
385 | d252 1
|
---|
386 | a252 1
|
---|
387 | (lambda (p l) ($poly-expt p l n ,order ,ring))))
|
---|
388 | @
|
---|
389 |
|
---|
390 |
|
---|
391 | 1.8
|
---|
392 | log
|
---|
393 | @*** empty log message ***
|
---|
394 | @
|
---|
395 | text
|
---|
396 | @d3 1
|
---|
397 | a3 1
|
---|
398 | $Id$
|
---|
399 | d245 8
|
---|
400 | a252 8
|
---|
401 | (list #'(lambda (&rest r) (reduce #'(lambda (p q) ($poly+ p q n order ring)) r))
|
---|
402 | #'(lambda (p &rest r)
|
---|
403 | (if (endp r) ($minus-poly p n ring)
|
---|
404 | ($poly- p (reduce #'(lambda (p q) ($poly+ p q n order ring)) r) n
|
---|
405 | order ring)))
|
---|
406 | #'(lambda (&rest r) (reduce #'(lambda (p q) ($poly* p q n order ring)) r))
|
---|
407 | #'(lambda (p q) ($poly/ p q ring))
|
---|
408 | #'(lambda (p l) ($poly-expt p l n order ring))))
|
---|
409 | @
|
---|
410 |
|
---|
411 |
|
---|
412 | 1.7
|
---|
413 | log
|
---|
414 | @*** empty log message ***
|
---|
415 | @
|
---|
416 | text
|
---|
417 | @d17 1
|
---|
418 | a17 1
|
---|
419 | (:shadow sort-poly + - * / expt))
|
---|
420 | @
|
---|
421 |
|
---|
422 |
|
---|
423 | 1.6
|
---|
424 | log
|
---|
425 | @*** empty log message ***
|
---|
426 | @
|
---|
427 | text
|
---|
428 | @d242 14
|
---|
429 | a255 13
|
---|
430 | (sublis
|
---|
431 | (pairlis vars (monom-basis (length vars)))
|
---|
432 | (labels
|
---|
433 | ((+ (&rest r)
|
---|
434 | (reduce #'(lambda (p q) ($poly+ p q n order ring)) r))
|
---|
435 | (- (p &rest r)
|
---|
436 | (if (endp r) ($minus-poly p n ring)
|
---|
437 | ($poly- p (reduce #'(lambda (p q) ($poly+ p q n order ring)) r) n
|
---|
438 | order ring)))
|
---|
439 | (* (&rest r) (reduce #'(lambda (p q) ($poly* p q n order ring)) r))
|
---|
440 | (/ (p q) ($poly/ p q ring))
|
---|
441 | (expt (p l) ($poly-expt p l n order ring)))
|
---|
442 | expr)))
|
---|
443 | @
|
---|
444 |
|
---|
445 |
|
---|
446 | 1.5
|
---|
447 | log
|
---|
448 | @*** empty log message ***
|
---|
449 | @
|
---|
450 | text
|
---|
451 | @d233 1
|
---|
452 | a233 4
|
---|
453 | (defmacro poly-eval-1 (expr vars order ring
|
---|
454 | &aux
|
---|
455 | (n (gensym))
|
---|
456 | (form (gensym)))
|
---|
457 | d242 13
|
---|
458 | a254 17
|
---|
459 | `(let* ((,n (length ,vars))
|
---|
460 | (,form (sublis (pairlis ,vars (monom-basis ,n)) ,expr)))
|
---|
461 | (labels
|
---|
462 | ((+ (&rest r)
|
---|
463 | (reduce #'(lambda (p q) ($poly+ p q ,n ,order ,ring)) r))
|
---|
464 | (- (p &rest r)
|
---|
465 | (if (endp r) ($minus-poly p ,n ,ring)
|
---|
466 | ($poly- p
|
---|
467 | (reduce #'(lambda (p q) ($poly+ p q ,n ,order ,ring)) r)
|
---|
468 | ,n
|
---|
469 | ,order
|
---|
470 | ,ring)))
|
---|
471 | (* (&rest r)
|
---|
472 | (reduce #'(lambda (p q) ($poly* p q ,n ,order ,ring)) r))
|
---|
473 | (/ (p q) ($poly/ p q ,ring))
|
---|
474 | (expt (p l) ($poly-expt p l ,n ,order ,ring)))
|
---|
475 | ,form)))
|
---|
476 | @
|
---|
477 |
|
---|
478 |
|
---|
479 | 1.4
|
---|
480 | log
|
---|
481 | @*** empty log message ***
|
---|
482 | @
|
---|
483 | text
|
---|
484 | @d233 4
|
---|
485 | a236 1
|
---|
486 | (defun poly-eval-1 (expr vars order ring &aux (n (length vars)))
|
---|
487 | d245 17
|
---|
488 | a261 13
|
---|
489 | (sublis
|
---|
490 | (pairlis vars (monom-basis (length vars)))
|
---|
491 | (labels
|
---|
492 | ((+ (&rest r)
|
---|
493 | (reduce #'(lambda (p q) ($poly+ p q n order ring)) r))
|
---|
494 | (- (p &rest r)
|
---|
495 | (if (endp r) ($minus-poly p n ring)
|
---|
496 | ($poly- p (reduce #'(lambda (p q) ($poly+ p q n order ring)) r) n
|
---|
497 | order ring)))
|
---|
498 | (* (&rest r) (reduce #'(lambda (p q) ($poly* p q n order ring)) r))
|
---|
499 | (/ (p q) ($poly/ p q ring))
|
---|
500 | (expt (p l) ($poly-expt p l n order ring)))
|
---|
501 | expr)))
|
---|
502 | @
|
---|
503 |
|
---|
504 |
|
---|
505 | 1.3
|
---|
506 | log
|
---|
507 | @*** empty log message ***
|
---|
508 | @
|
---|
509 | text
|
---|
510 | @d17 1
|
---|
511 | a17 1
|
---|
512 | (:shadow sort-poly))
|
---|
513 | d88 2
|
---|
514 | a89 2
|
---|
515 | (/ p q)
|
---|
516 | (scalar-times-poly (/ q) p ring)))
|
---|
517 | d242 13
|
---|
518 | a254 14
|
---|
519 | (eval
|
---|
520 | (sublis
|
---|
521 | (pairlis '(+ - * / expt)
|
---|
522 | `((lambda (&rest r) (reduce #'(lambda (p q) ($poly+ p q ,n ,order ,ring)) r))
|
---|
523 | (lambda (p &rest r)
|
---|
524 | (if (endp r) ($minus-poly p ,n ,ring)
|
---|
525 | ($poly- p (reduce #'(lambda (p q) ($poly+ p q ,n ,order ,ring)) r) ,n
|
---|
526 | ,order ,ring)))
|
---|
527 | (lambda (&rest r) (reduce #'(lambda (p q) ($poly* p q ,n ,order ,ring)) r))
|
---|
528 | (lambda (p q) ($poly/ p q ,ring))
|
---|
529 | (lambda (p l) ($poly-expt p l ,n ,order ,ring))))
|
---|
530 | (sublis
|
---|
531 | (pairlis vars (monom-basis (length vars)))
|
---|
532 | expr))))
|
---|
533 | @
|
---|
534 |
|
---|
535 |
|
---|
536 | 1.2
|
---|
537 | log
|
---|
538 | @*** empty log message ***
|
---|
539 | @
|
---|
540 | text
|
---|
541 | @d21 2
|
---|
542 | a22 1
|
---|
543 | (proclaim '(optimize (speed 0) (debug 3)))
|
---|
544 | d49 2
|
---|
545 | a50 2
|
---|
546 | (eval-when (compile)
|
---|
547 | (proclaim '(optimize safety)))
|
---|
548 | d245 8
|
---|
549 | a252 8
|
---|
550 | (list #'(lambda (&rest r) (reduce #'(lambda (p q) ($poly+ p q n order ring)) r))
|
---|
551 | #'(lambda (p &rest r)
|
---|
552 | (if (endp r) ($minus-poly p n ring)
|
---|
553 | ($poly- p (reduce #'(lambda (p q) ($poly+ p q n order ring)) r) n
|
---|
554 | order ring)))
|
---|
555 | #'(lambda (&rest r) (reduce #'(lambda (p q) ($poly* p q n order ring)) r))
|
---|
556 | #'(lambda (p q) ($poly/ p q ring))
|
---|
557 | #'(lambda (p l) ($poly-expt p l n order ring))))
|
---|
558 | @
|
---|
559 |
|
---|
560 |
|
---|
561 | 1.1
|
---|
562 | log
|
---|
563 | @Initial revision
|
---|
564 | @
|
---|
565 | text
|
---|
566 | @d3 1
|
---|
567 | a3 1
|
---|
568 | $Id: parse.lisp,v 1.48 1997/12/25 02:18:21 marek Exp $
|
---|
569 | d21 1
|
---|
570 | @
|
---|