Changeset 53 for branches

Timestamp:

2015-06-05T11:16:26-07:00 (9 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/polynomial.lisp (modified) (6 diffs)

branches/f4grobner/polynomial.lisp

@@ -12 +12 @@
              ;; Constructor of polynomials representing a variable
              (:constructor make-variable (ring nvars pos &optional (power 1)
-                                              &aux
-                                              (termlist (list
-                                                         (make-term-variable ring nvars pos power)))
-                                              (sugar power)))
-            (:constructor poly-unit (ring dimension
-                                     &aux
-                                     (termlist (termlist-unit ring dimension))
-                                     (sugar 0))))
+                                               &aux
+                                               (termlist (list
+                                                          (make-term-variable ring nvars pos power)))
+                                               (sugar power)))
+             (:constructor poly-unit (ring dimension
+                                           &aux
+                                           (termlist (termlist-unit ring dimension))
+                                           (sugar 0))))
   (termlist nil :type list)
   (sugar -1 :type fixnum))
@@ -53 +53 @@
 (defun scalar-times-poly-1 (ring c p)
   (make-poly-from-termlist (scalar-times-termlist ring c (cdr (poly-termlist p))) (poly-sugar p)))
-    
+
 (defun monom-times-poly (m p)
   (make-poly-from-termlist (monom-times-termlist m (poly-termlist p)) (+ (poly-sugar p) (monom-sugar m))))
@@ -77 +77 @@
 (defun poly-append (&rest plist)
   (make-poly-from-termlist (apply #'append (mapcar #'poly-termlist plist))
-             (apply #'max (mapcar #'poly-sugar plist))))
+                           (apply #'max (mapcar #'poly-sugar plist))))
 
 (defun poly-nreverse (p)
@@ -85 +85 @@
 (defun poly-contract (p &optional (k 1))
   (make-poly-from-termlist (termlist-contract (poly-termlist p) k)
-             (poly-sugar p)))
+                           (poly-sugar p)))
 
 (defun poly-extend (p &optional (m (make-monom 1 :initial-element 0)))
@@ -123 +123 @@
 
 (defun polysaturation-extension (ring f plist &aux (k (length plist))
-                                                   (d (+ k (length (poly-lm (car plist))))))
+                                                (d (+ k (length (poly-lm (car plist))))))
   "Calculate [F, U1*P1+U2*P2+...+UK*PK-1], where PLIST=[P1,P2,...,PK]."
   (setf f (poly-list-add-variables f k)
@@ -132 +132 @@
 
 (defun saturation-extension-1 (ring f p) (polysaturation-extension ring f (list p)))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Evaluation of polynomial (prefix) expressions
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun coerce-coeff (ring expr vars)
+  "Coerce an element of the coefficient ring to a constant polynomial."
+  ;; Modular arithmetic handler by rat
+  (make-poly-from-termlist (list (make-term (make-monom (length vars) :initial-element 0)
+                                            (funcall (ring-parse ring) expr)))
+                           0))
+
+(defun poly-eval (ring expr vars &optional (list-marker '[))
+  (labels ((p-eval (arg) (poly-eval ring arg vars))
+           (p-eval-list (args) (mapcar #'p-eval args))
+           (p-add (x y) (poly-add ring x y)))
+    (cond
+      ((eql expr 0) (make-poly-zero))
+      ((member expr vars :test #'equalp)
+       (let ((pos (position expr vars :test #'equalp)))
+         (make-variable ring (length vars) pos)))
+      ((atom expr)
+       (coerce-coeff ring expr vars))
+      ((eq (car expr) list-marker)
+       (cons list-marker (p-eval-list (cdr expr))))
+      (t
+       (case (car expr)
+         (+ (reduce #'p-add (p-eval-list (cdr expr))))
+         (- (case (length expr)
+              (1 (make-poly-zero))
+              (2 (poly-uminus ring (p-eval (cadr expr))))
+              (3 (poly-sub ring (p-eval (cadr expr)) (p-eval (caddr expr))))
+              (otherwise (poly-sub ring (p-eval (cadr expr))
+                                   (reduce #'p-add (p-eval-list (cddr expr)))))))
+         (*
+          (if (endp (cddr expr))                ;unary
+              (p-eval (cdr expr))
+              (reduce #'(lambda (p q) (poly-mul ring p q)) (p-eval-list (cdr expr)))))
+         (expt
+          (cond
+            ((member (cadr expr) vars :test #'equalp)
+             ;;Special handling of (expt var pow)
+             (let ((pos (position (cadr expr) vars :test #'equalp)))
+               (make-variable ring (length vars) pos (caddr expr))))
+            ((not (and (integerp (caddr expr)) (plusp (caddr expr))))
+             ;; Negative power means division in coefficient ring
+             ;; Non-integer power means non-polynomial coefficient
+             (coerce-coeff ring expr vars))
+            (t (poly-expt ring (p-eval (cadr expr)) (caddr expr)))))
+         (otherwise
+          (coerce-coeff ring expr vars)))))))
+
+
+