[1] | 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 | @
|
---|