Changeset 114 for branches/f4grobner

Timestamp:

2015-06-05T12:13:37-07:00 (10 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/mx-grobner.lisp (modified) (1 diff)

branches/f4grobner/mx-grobner.lisp

@@ -71 +71 @@
 are assumed to be defined.")
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Maxima expression parsing
+;;
+;; NOTE: This code depends on several Maxima lisp functions:
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun equal-test-p (expr1 expr2)
+  (alike1 expr1 expr2))
+
+(defun coerce-maxima-list (expr)
+  "convert a maxima list to lisp list."
+  (cond
+   ((and (consp (car expr)) (eql (caar expr) 'mlist)) (cdr expr))
+   (t expr)))
+
+(defun free-of-vars (expr vars) (apply #'$freeof `(,@vars ,expr)))
+
+(defun parse-poly (expr vars &aux (vars (coerce-maxima-list vars)))
+  "Convert a maxima polynomial expression EXPR in variables VARS to internal form."
+  (labels ((parse (arg) (parse-poly arg vars))
+           (parse-list (args) (mapcar #'parse args)))
+    (cond
+     ((eql expr 0) (make-poly-zero))
+     ((member expr vars :test #'equal-test-p)
+      (let ((pos (position expr vars :test #'equal-test-p)))
+        (make-variable *maxima-ring* (length vars) pos)))
+     ((free-of-vars expr vars)
+      ;;This means that variable-free CRE and Poisson forms will be converted
+      ;;to coefficients intact
+      (coerce-coeff *maxima-ring* expr vars))
+     (t
+      (case (caar expr)
+        (mplus (reduce #'(lambda (x y) (poly-add *maxima-ring* x y)) (parse-list (cdr expr))))
+        (mminus (poly-uminus *maxima-ring* (parse (cadr expr))))
+        (mtimes
+         (if (endp (cddr expr))         ;unary
+             (parse (cdr expr))
+           (reduce #'(lambda (p q) (poly-mul *maxima-ring* p q)) (parse-list (cdr expr)))))
+        (mexpt
+         (cond
+          ((member (cadr expr) vars :test #'equal-test-p)
+           ;;Special handling of (expt var pow)
+           (let ((pos (position (cadr expr) vars :test #'equal-test-p)))
+             (make-variable *maxima-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
+           (mtell "~%Warning: Expression ~%~M~%contains power which is not a positive integer. Parsing as coefficient.~%"
+                  expr)
+           (coerce-coeff *maxima-ring* expr vars))
+          (t (poly-expt *maxima-ring* (parse (cadr expr)) (caddr expr)))))
+        (mrat (parse ($ratdisrep expr)))
+        (mpois (parse ($outofpois expr)))
+        (otherwise
+         (coerce-coeff *maxima-ring* expr vars)))))))
+
+(defun parse-poly-list (expr vars)
+  (case (caar expr)
+    (mlist (mapcar #'(lambda (p) (parse-poly p vars)) (cdr expr)))
+    (t (merror "Expression ~M is not a list of polynomials in variables ~M."
+               expr vars))))
+(defun parse-poly-list-list (poly-list-list vars)
+  (mapcar #'(lambda (g) (parse-poly-list g vars)) (coerce-maxima-list poly-list-list)))
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;