close Warning: Can't synchronize with repository "(default)" (The repository directory has changed, you should resynchronize the repository with: trac-admin $ENV repository resync '(default)'). Look in the Trac log for more information.

Changeset 53 for branches


Ignore:
Timestamp:
2015-06-05T11:16:26-07:00 (9 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/polynomial.lisp

    r52 r53  
    1212             ;; Constructor of polynomials representing a variable
    1313             (:constructor make-variable (ring nvars pos &optional (power 1)
    14                                               &aux
    15                                               (termlist (list
    16                                                          (make-term-variable ring nvars pos power)))
    17                                               (sugar power)))
    18             (:constructor poly-unit (ring dimension
    19                                      &aux
    20                                      (termlist (termlist-unit ring dimension))
    21                                      (sugar 0))))
     14                                               &aux
     15                                               (termlist (list
     16                                                          (make-term-variable ring nvars pos power)))
     17                                               (sugar power)))
     18             (:constructor poly-unit (ring dimension
     19                                           &aux
     20                                           (termlist (termlist-unit ring dimension))
     21                                           (sugar 0))))
    2222  (termlist nil :type list)
    2323  (sugar -1 :type fixnum))
     
    5353(defun scalar-times-poly-1 (ring c p)
    5454  (make-poly-from-termlist (scalar-times-termlist ring c (cdr (poly-termlist p))) (poly-sugar p)))
    55    
     55
    5656(defun monom-times-poly (m p)
    5757  (make-poly-from-termlist (monom-times-termlist m (poly-termlist p)) (+ (poly-sugar p) (monom-sugar m))))
     
    7777(defun poly-append (&rest plist)
    7878  (make-poly-from-termlist (apply #'append (mapcar #'poly-termlist plist))
    79              (apply #'max (mapcar #'poly-sugar plist))))
     79                           (apply #'max (mapcar #'poly-sugar plist))))
    8080
    8181(defun poly-nreverse (p)
     
    8585(defun poly-contract (p &optional (k 1))
    8686  (make-poly-from-termlist (termlist-contract (poly-termlist p) k)
    87              (poly-sugar p)))
     87                           (poly-sugar p)))
    8888
    8989(defun poly-extend (p &optional (m (make-monom 1 :initial-element 0)))
     
    123123
    124124(defun polysaturation-extension (ring f plist &aux (k (length plist))
    125                                                    (d (+ k (length (poly-lm (car plist))))))
     125                                                (d (+ k (length (poly-lm (car plist))))))
    126126  "Calculate [F, U1*P1+U2*P2+...+UK*PK-1], where PLIST=[P1,P2,...,PK]."
    127127  (setf f (poly-list-add-variables f k)
     
    132132
    133133(defun saturation-extension-1 (ring f p) (polysaturation-extension ring f (list p)))
     134
     135
     136
     137;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     138;;
     139;; Evaluation of polynomial (prefix) expressions
     140;;
     141;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     142
     143(defun coerce-coeff (ring expr vars)
     144  "Coerce an element of the coefficient ring to a constant polynomial."
     145  ;; Modular arithmetic handler by rat
     146  (make-poly-from-termlist (list (make-term (make-monom (length vars) :initial-element 0)
     147                                            (funcall (ring-parse ring) expr)))
     148                           0))
     149
     150(defun poly-eval (ring expr vars &optional (list-marker '[))
     151  (labels ((p-eval (arg) (poly-eval ring arg vars))
     152           (p-eval-list (args) (mapcar #'p-eval args))
     153           (p-add (x y) (poly-add ring x y)))
     154    (cond
     155      ((eql expr 0) (make-poly-zero))
     156      ((member expr vars :test #'equalp)
     157       (let ((pos (position expr vars :test #'equalp)))
     158         (make-variable ring (length vars) pos)))
     159      ((atom expr)
     160       (coerce-coeff ring expr vars))
     161      ((eq (car expr) list-marker)
     162       (cons list-marker (p-eval-list (cdr expr))))
     163      (t
     164       (case (car expr)
     165         (+ (reduce #'p-add (p-eval-list (cdr expr))))
     166         (- (case (length expr)
     167              (1 (make-poly-zero))
     168              (2 (poly-uminus ring (p-eval (cadr expr))))
     169              (3 (poly-sub ring (p-eval (cadr expr)) (p-eval (caddr expr))))
     170              (otherwise (poly-sub ring (p-eval (cadr expr))
     171                                   (reduce #'p-add (p-eval-list (cddr expr)))))))
     172         (*
     173          (if (endp (cddr expr))                ;unary
     174              (p-eval (cdr expr))
     175              (reduce #'(lambda (p q) (poly-mul ring p q)) (p-eval-list (cdr expr)))))
     176         (expt
     177          (cond
     178            ((member (cadr expr) vars :test #'equalp)
     179             ;;Special handling of (expt var pow)
     180             (let ((pos (position (cadr expr) vars :test #'equalp)))
     181               (make-variable ring (length vars) pos (caddr expr))))
     182            ((not (and (integerp (caddr expr)) (plusp (caddr expr))))
     183             ;; Negative power means division in coefficient ring
     184             ;; Non-integer power means non-polynomial coefficient
     185             (coerce-coeff ring expr vars))
     186            (t (poly-expt ring (p-eval (cadr expr)) (caddr expr)))))
     187         (otherwise
     188          (coerce-coeff ring expr vars)))))))
     189
     190
     191
Note: See TracChangeset for help on using the changeset viewer.