Changeset 71 for branches

Timestamp:

2015-06-05T11:32:41-07:00 (10 years ago)

Author:

Marek Rychlik

Message:

* empty log message *

File:

• branches/f4grobner/grobner.lisp (modified) (2 diffs)

branches/f4grobner/grobner.lisp

@@ -134 +134 @@
 
 
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Low-level polynomial arithmetic done on 
-;; lists of terms
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmacro termlist-lt (p) `(car ,p))
-(defun termlist-lm (p) (term-monom (termlist-lt p)))
-(defun termlist-lc (p) (term-coeff (termlist-lt p)))
-
-(define-modify-macro scalar-mul (c) coeff-mul)
-
-(defun scalar-times-termlist (ring c p)
-  "Multiply scalar C by a polynomial P. This function works
-even if there are divisors of 0."
-  (mapcan
-   #'(lambda (term)
-       (let ((c1 (funcall (ring-mul ring) c (term-coeff term))))
-         (unless (funcall (ring-zerop ring) c1)
-           (list (make-term (term-monom term) c1)))))
-   p))
-
-
-(defun term-mul (ring term1 term2)
-  "Returns (LIST TERM) wheter TERM is the product of the terms TERM1 TERM2,
-or NIL when the product is 0. This definition takes care of divisors of 0
-in the coefficient ring."
-  (let ((c (funcall (ring-mul ring) (term-coeff term1) (term-coeff term2))))
-    (unless (funcall (ring-zerop ring) c)
-      (list (make-term (monom-mul (term-monom term1) (term-monom term2)) c)))))
-
-(defun term-times-termlist (ring term f)
-  (declare (type ring ring))
-  (mapcan #'(lambda (term-f) (term-mul ring term term-f)) f))
-
-(defun termlist-times-term (ring f term)
-  (mapcan #'(lambda (term-f) (term-mul ring term-f term)) f))
-
-(defun monom-times-term (m term)
-  (make-term (monom-mul m (term-monom term)) (term-coeff term)))
-
-(defun monom-times-termlist (m f)
-  (cond
-   ((null f) nil)
-   (t
-    (mapcar #'(lambda (x) (monom-times-term m x)) f))))
-
-(defun termlist-uminus (ring f)
-  (mapcar #'(lambda (x)
-              (make-term (term-monom x) (funcall (ring-uminus ring) (term-coeff x))))
-          f))
-
-(defun termlist-add (ring p q)
-  (declare (type list p q))
-  (do (r)
-      ((cond
-        ((endp p)
-         (setf r (revappend r q)) t)
-        ((endp q)
-         (setf r (revappend r p)) t)
-        (t
-         (multiple-value-bind
-             (lm-greater lm-equal)
-             (monomial-order (termlist-lm p) (termlist-lm q))
-           (cond
-            (lm-equal
-             (let ((s (funcall (ring-add ring) (termlist-lc p) (termlist-lc q))))
-               (unless (funcall (ring-zerop ring) s)    ;check for cancellation
-                 (setf r (cons (make-term (termlist-lm p) s) r)))
-               (setf p (cdr p) q (cdr q))))
-            (lm-greater
-             (setf r (cons (car p) r)
-                   p (cdr p)))
-            (t (setf r (cons (car q) r)
-                     q (cdr q)))))
-         nil))
-       r)))
-
-(defun termlist-sub (ring p q)
-  (declare (type list p q))
-  (do (r)
-      ((cond
-        ((endp p)
-         (setf r (revappend r (termlist-uminus ring q)))
-         t)
-        ((endp q)
-         (setf r (revappend r p))
-         t)
-        (t
-         (multiple-value-bind
-             (mgreater mequal)
-             (monomial-order (termlist-lm p) (termlist-lm q))
-           (cond
-            (mequal
-             (let ((s (funcall (ring-sub ring) (termlist-lc p) (termlist-lc q))))
-               (unless (funcall (ring-zerop ring) s)    ;check for cancellation
-                 (setf r (cons (make-term (termlist-lm p) s) r)))
-               (setf p (cdr p) q (cdr q))))
-            (mgreater
-             (setf r (cons (car p) r)
-                   p (cdr p)))
-            (t (setf r (cons (make-term (termlist-lm q) (funcall (ring-uminus ring) (termlist-lc q))) r)
-                     q (cdr q)))))
-         nil))
-       r)))
-
-;; Multiplication of polynomials
-;; Non-destructive version
-(defun termlist-mul (ring p q)
-  (cond ((or (endp p) (endp q)) nil)    ;p or q is 0 (represented by NIL)
-        ;; If p=p0+p1 and q=q0+q1 then pq=p0q0+p0q1+p1q
-        ((endp (cdr p))
-         (term-times-termlist ring (car p) q))
-        ((endp (cdr q))
-         (termlist-times-term ring p (car q)))
-        (t
-         (let ((head (term-mul ring (termlist-lt p) (termlist-lt q)))
-               (tail (termlist-add ring (term-times-termlist ring (car p) (cdr q))
-                                   (termlist-mul ring (cdr p) q))))
-           (cond ((null head) tail)
-                 ((null tail) head)
-                 (t (nconc head tail)))))))
-                    
-(defun termlist-unit (ring dimension)
-  (declare (fixnum dimension))
-  (list (make-term (make-monom dimension :initial-element 0)
-                   (funcall (ring-unit ring)))))
-
-(defun termlist-expt (ring poly n &aux (dim (monom-dimension (termlist-lm poly))))
-  (declare (type fixnum n dim))
-  (cond
-   ((minusp n) (error "termlist-expt: Negative exponent."))
-   ((endp poly) (if (zerop n) (termlist-unit ring dim) nil))
-   (t
-    (do ((k 1 (ash k 1))
-         (q poly (termlist-mul ring q q))       ;keep squaring
-         (p (termlist-unit ring dim) (if (not (zerop (logand k n))) (termlist-mul ring p q) p)))
-        ((> k n) p)
-      (declare (fixnum k))))))
-
-
-
-
-
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -289 +141 @@
 (defmacro debug-cgb (&rest args)
   `(when $poly_grobner_debug (format *terminal-io* ,@args)))
-
-