Changeset 15 in CGBLisp

Timestamp:

Jan 27, 2009, 12:39:28 AM (15 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• trunk/src/parse.lisp (modified) (1 diff)

trunk/src/parse.lisp

@@ -230 +230 @@
    (t (sort-poly-1 poly-or-poly-list order))))
 
-(defun poly-eval-1 (expr vars order ring &aux (n (length vars)))
-  "Evaluate an expression EXPR as polynomial
-by substituting operators + - * expt with
-corresponding polynomial operators
-and variables VARS with monomials (1 0 ... 0), (0 1 ... 0) etc.
-We use special versions of binary
-operators $poly+, $poly-, $minus-poly, $poly* and $poly-expt
-which work like the corresponding functions in the
-POLY package, but accept scalars as arguments as well."
-  (eval
-   (sublis
-    (pairlis '(+ - * / expt) 
-             `((lambda (&rest r) (reduce #'(lambda (p q) ($poly+ p q ,n ,order ,ring)) r))
-               (lambda (p &rest r)
-                 (if (endp r) ($minus-poly p ,n ,ring)
-                     ($poly- p (reduce #'(lambda (p q) ($poly+ p q ,n ,order ,ring)) r) ,n
-                             ,order ,ring)))
-               (lambda (&rest r) (reduce #'(lambda (p q) ($poly* p q ,n ,order ,ring)) r))
-               (lambda (p q) ($poly/ p q ,ring))
-               (lambda (p l) ($poly-expt p l ,n ,order ,ring))))
-    (sublis
-     (pairlis vars (monom-basis (length vars)))
-     expr))))
+(defun poly-eval-1 (expr vars order ring
+                    &aux
+                    (n (length vars))
+                    (basis (monom-basis (length vars))))
+  "Evaluate an expression EXPR as polynomial by substituting operators
++ - * expt with corresponding polynomial operators and variables VARS
+with monomials (1 0 ... 0), (0 1 ... 0) etc.  We use special versions
+of binary operators $poly+, $poly-, $minus-poly, $poly* and $poly-expt
+which work like the corresponding functions in the POLY package, but
+accept scalars as arguments as well."
+  (cond
+    ((numberp expr)
+     (cons (make-list n :initial-element 0) expr))
+    ((symbolp expr)
+     (nth (position expr vars) basis)) 
+    (t
+     (let ((r (mapcar
+               #'(lambda (e) (poly-eval-1 e vars order ring))
+               (cdr expr))))
+       (ecase (car expr)
+         (+ (reduce #'(lambda (p q) ($poly+ p q n order ring)) r))
+         (-
+          (if (endp (cdr r))
+              ($minus-poly (car r) n ring)
+              ($poly- (car r)
+                      (reduce #'(lambda (p q) ($poly+ p q n order ring)) (cdr r))
+                      n
+                      order ring)))
+         (*
+          (reduce #'(lambda (p q) ($poly* p q n order ring)) r))
+         (/ ($poly/ (car r) (cadr r) ring))
+         (expt ($poly-expt (car r) (cadr r) n order ring)))))))
+
              
 (defun poly-eval (expr vars &optional (order #'lex>) (ring *coefficient-ring*))