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 2002


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

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/pol.lisp

    r2001 r2002  
    136136(defmethod poly-uminus ((self poly)))
    137137
    138 (defmethod poly-mul ((p poly) (poly q)))
     138(defmethod poly-mul ((p poly) (q poly)))
    139139
    140140(defmethod poly-expt ((self poly) n))
     
    148148of polynomials in internal form. A similar operation in another computer
    149149algebra system could be called 'expand' or so."
    150     (cond
    151       ((null expr) (error "Empty expression"))
    152       ((eql expr 0) (make-poly-zero))
    153       ((member expr vars :test #'equalp)
    154        (let ((pos (position expr vars :test #'equalp)))
    155         (make-poly-variable ring (length vars) pos)))
    156       ((atom expr)
    157        (scalar->poly ring expr vars))
    158       ((eq (car expr) list-marker)
    159        (cons list-marker (p-eval-list (cdr expr))))
    160       (t
    161        (case (car expr)
    162         (+ (reduce #'p-add (p-eval-list (cdr expr))))
    163         (- (case (length expr)
    164               (1 (make-poly-zero))
    165               (2 (poly-uminus ring (p-eval (cadr expr))))
    166               (3 (poly-sub ring-and-order (p-eval (cadr expr)) (p-eval (caddr expr))))
    167               (otherwise (poly-sub ring-and-order (p-eval (cadr expr))
    168                                    (reduce #'p-add (p-eval-list (cddr expr)))))))
    169         (*
    170           (if (endp (cddr expr))                ;unary
    171               (p-eval (cdr expr))
    172               (reduce #'(lambda (p q) (poly-mul ring-and-order p q)) (p-eval-list (cdr expr)))))
    173         (/
    174           ;; A polynomial can be divided by a scalar
    175           (cond
    176             ((endp (cddr expr))
    177              ;; A special case (/ ?), the inverse
    178              (scalar->poly ring (apply (ring-div ring) (cdr expr)) vars))
    179             (t
    180              (let ((num (p-eval (cadr expr)))
    181                    (denom-inverse (apply (ring-div ring)
    182                                         (cons (funcall (ring-unit ring))
    183                                                (mapcar #'p-eval-scalar (cddr expr))))))
    184                (scalar-times-poly ring denom-inverse num)))))
    185         (expt
    186           (cond
    187             ((member (cadr expr) vars :test #'equalp)
    188              ;;Special handling of (expt var pow)
    189              (let ((pos (position (cadr expr) vars :test #'equalp)))
    190                (make-poly-variable ring (length vars) pos (caddr expr))))
    191             ((not (and (integerp (caddr expr)) (plusp (caddr expr))))
    192              ;; Negative power means division in coefficient ring
    193              ;; Non-integer power means non-polynomial coefficient
    194              (scalar->poly ring expr vars))
    195             (t (poly-expt ring-and-order (p-eval (cadr expr)) (caddr expr)))))
    196         (otherwise
    197           (scalar->poly ring expr vars)))))))
     150  (cond
     151    ((null expr) (error "Empty expression"))
     152    ((eql expr 0) (make-poly-zero))
     153    ((member expr vars :test #'equalp)
     154     (let ((pos (position expr vars :test #'equalp)))
     155      (make-poly-variable ring (length vars) pos)))
     156    ((atom expr)
     157     (scalar->poly ring expr vars))
     158    ((eq (car expr) list-marker)
     159     (cons list-marker (p-eval-list (cdr expr))))
     160    (t
     161     (case (car expr)
     162      (+ (reduce #'p-add (p-eval-list (cdr expr))))
     163      (- (case (length expr)
     164            (1 (make-poly-zero))
     165            (2 (poly-uminus ring (p-eval (cadr expr))))
     166            (3 (poly-sub ring-and-order (p-eval (cadr expr)) (p-eval (caddr expr))))
     167            (otherwise (poly-sub ring-and-order (p-eval (cadr expr))
     168                                 (reduce #'p-add (p-eval-list (cddr expr)))))))
     169      (*
     170        (if (endp (cddr expr))          ;unary
     171            (p-eval (cdr expr))
     172            (reduce #'(lambda (p q) (poly-mul ring-and-order p q)) (p-eval-list (cdr expr)))))
     173      (/
     174        ;; A polynomial can be divided by a scalar
     175        (cond
     176          ((endp (cddr expr))
     177           ;; A special case (/ ?), the inverse
     178           (scalar->poly ring (apply (ring-div ring) (cdr expr)) vars))
     179          (t
     180           (let ((num (p-eval (cadr expr)))
     181                 (denom-inverse (apply (ring-div ring)
     182                                      (cons (funcall (ring-unit ring))
     183                                             (mapcar #'p-eval-scalar (cddr expr))))))
     184             (scalar-times-poly ring denom-inverse num)))))
     185      (expt
     186        (cond
     187          ((member (cadr expr) vars :test #'equalp)
     188           ;;Special handling of (expt var pow)
     189           (let ((pos (position (cadr expr) vars :test #'equalp)))
     190             (make-poly-variable ring (length vars) pos (caddr expr))))
     191          ((not (and (integerp (caddr expr)) (plusp (caddr expr))))
     192           ;; Negative power means division in coefficient ring
     193           ;; Non-integer power means non-polynomial coefficient
     194           (scalar->poly ring expr vars))
     195          (t (poly-expt ring-and-order (p-eval (cadr expr)) (caddr expr)))))
     196      (otherwise
     197        (scalar->poly ring expr vars))))))
    198198
    199199(defun poly-eval-scalar (expr
Note: See TracChangeset for help on using the changeset viewer.