Changeset 15 in CGBLisp
- Timestamp:
- Jan 27, 2009, 12:39:28 AM (15 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/src/parse.lisp
r14 r15 230 230 (t (sort-poly-1 poly-or-poly-list order)))) 231 231 232 (defun poly-eval-1 (expr vars order ring &aux (n (length vars))) 233 "Evaluate an expression EXPR as polynomial 234 by substituting operators + - * expt with 235 corresponding polynomial operators 236 and variables VARS with monomials (1 0 ... 0), (0 1 ... 0) etc. 237 We use special versions of binary 238 operators $poly+, $poly-, $minus-poly, $poly* and $poly-expt 239 which work like the corresponding functions in the 240 POLY package, but accept scalars as arguments as well." 241 (eval 242 (sublis 243 (pairlis '(+ - * / expt) 244 `((lambda (&rest r) (reduce #'(lambda (p q) ($poly+ p q ,n ,order ,ring)) r)) 245 (lambda (p &rest r) 246 (if (endp r) ($minus-poly p ,n ,ring) 247 ($poly- p (reduce #'(lambda (p q) ($poly+ p q ,n ,order ,ring)) r) ,n 248 ,order ,ring))) 249 (lambda (&rest r) (reduce #'(lambda (p q) ($poly* p q ,n ,order ,ring)) r)) 250 (lambda (p q) ($poly/ p q ,ring)) 251 (lambda (p l) ($poly-expt p l ,n ,order ,ring)))) 252 (sublis 253 (pairlis vars (monom-basis (length vars))) 254 expr)))) 232 (defun poly-eval-1 (expr vars order ring 233 &aux 234 (n (length vars)) 235 (basis (monom-basis (length vars)))) 236 "Evaluate an expression EXPR as polynomial by substituting operators 237 + - * expt with corresponding polynomial operators and variables VARS 238 with monomials (1 0 ... 0), (0 1 ... 0) etc. We use special versions 239 of binary operators $poly+, $poly-, $minus-poly, $poly* and $poly-expt 240 which work like the corresponding functions in the POLY package, but 241 accept scalars as arguments as well." 242 (cond 243 ((numberp expr) 244 (cons (make-list n :initial-element 0) expr)) 245 ((symbolp expr) 246 (nth (position expr vars) basis)) 247 (t 248 (let ((r (mapcar 249 #'(lambda (e) (poly-eval-1 e vars order ring)) 250 (cdr expr)))) 251 (ecase (car expr) 252 (+ (reduce #'(lambda (p q) ($poly+ p q n order ring)) r)) 253 (- 254 (if (endp (cdr r)) 255 ($minus-poly (car r) n ring) 256 ($poly- (car r) 257 (reduce #'(lambda (p q) ($poly+ p q n order ring)) (cdr r)) 258 n 259 order ring))) 260 (* 261 (reduce #'(lambda (p q) ($poly* p q n order ring)) r)) 262 (/ ($poly/ (car r) (cadr r) ring)) 263 (expt ($poly-expt (car r) (cadr r) n order ring))))))) 264 255 265 256 266 (defun poly-eval (expr vars &optional (order #'lex>) (ring *coefficient-ring*))
Note:
See TracChangeset
for help on using the changeset viewer.