Index: branches/f4grobner/grobner.lisp
===================================================================
--- branches/f4grobner/grobner.lisp	(revision 47)
+++ branches/f4grobner/grobner.lisp	(revision 54)
@@ -33,401 +33,6 @@
 ($load "functs")
 
-;; Macros for making lists with iterators - an exammple of GENSYM
-;; MAKELIST-1 makes a list with one iterator, while MAKELIST accepts an
-;; arbitrary number of iterators
-
-;; Sample usage:
-;; Without a step:
-;; >(makelist-1 (* 2 i) i 0 10)
-;; (0 2 4 6 8 10 12 14 16 18 20)
-;; With a step of 3:
-;; >(makelist-1 (* 2 i) i 0 10 3)
-;; (0 6 12 18)
-
-;; Generate sums of squares of numbers between 1 and 4:
-;; >(makelist (+ (* i i) (* j j)) (i 1 4) (j 1 i))
-;; (2 5 8 10 13 18 17 20 25 32)
-;; >(makelist (list i j '---> (+ (* i i) (* j j))) (i 1 4) (j 1 i))
-;; ((1 1 ---> 2) (2 1 ---> 5) (2 2 ---> 8) (3 1 ---> 10) (3 2 ---> 13)
-;; (3 3 ---> 18) (4 1 ---> 17) (4 2 ---> 20) (4 3 ---> 25) (4 4 ---> 32))
-
-;; Evaluate expression expr with variable set to lo, lo+1,... ,hi
-;; and put the results in a list.
-(defmacro makelist-1 (expr var lo hi &optional (step 1))
-  (let ((l (gensym)))
-    `(do ((,var ,lo (+ ,var ,step))
-	  (,l nil (cons ,expr ,l)))
-	 ((> ,var ,hi) (reverse ,l))
-       (declare (fixnum ,var)))))
-
-(defmacro makelist (expr (var lo hi &optional (step 1)) &rest more)
-  (if (endp more)
-      `(makelist-1 ,expr ,var ,lo ,hi ,step)
-    (let* ((l (gensym)))
-      `(do ((,var ,lo (+ ,var ,step))
-	    (,l nil (nconc ,l `,(makelist ,expr ,@more))))
-	   ((> ,var ,hi) ,l)
-	 (declare (fixnum ,var))))))
-
-;;----------------------------------------------------------------
-;; This package implements BASIC OPERATIONS ON MONOMIALS
-;;----------------------------------------------------------------
-;; DATA STRUCTURES: Monomials are represented as lists:
-;;
-;; 	monom:	(n1 n2 ... nk) where ni are non-negative integers
-;;
-;; However, lists may be implemented as other sequence types,
-;; so the flexibility to change the representation should be
-;; maintained in the code to use general operations on sequences
-;; whenever possible. The optimization for the actual representation
-;; should be left to declarations and the compiler.
-;;----------------------------------------------------------------
-;; EXAMPLES: Suppose that variables are x and y. Then
-;;
-;; 	Monom x*y^2 ---> (1 2)
-;;
-;;----------------------------------------------------------------
-
-(deftype exponent ()
-  "Type of exponent in a monomial."
-  'fixnum)
-
-(deftype monom (&optional dim)
-  "Type of monomial."
-  `(simple-array exponent (,dim)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Construction of monomials
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmacro make-monom (dim &key (initial-contents nil initial-contents-supplied-p)
-			       (initial-element 0 initial-element-supplied-p))
-  "Make a monomial with DIM variables. Additional argument
-INITIAL-CONTENTS specifies the list of powers of the consecutive
-variables. The alternative additional argument INITIAL-ELEMENT
-specifies the common power for all variables."
-  ;;(declare (fixnum dim))
-  `(make-array ,dim
-	       :element-type 'exponent
-	       ,@(when initial-contents-supplied-p `(:initial-contents ,initial-contents))
-	       ,@(when initial-element-supplied-p `(:initial-element ,initial-element))))
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Operations on monomials
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmacro monom-elt (m index)
-  "Return the power in the monomial M of variable number INDEX."
-  `(elt ,m ,index))
-
-(defun monom-dimension (m)
-  "Return the number of variables in the monomial M."
-  (length m))
-
-(defun monom-total-degree (m &optional (start 0) (end (length m)))
-  "Return the todal degree of a monomoal M. Optinally, a range
-of variables may be specified with arguments START and END."
-  (declare (type monom m) (fixnum start end))
-  (reduce #'+ m :start start :end end))
-
-(defun monom-sugar (m &aux (start 0) (end (length m)))
-  "Return the sugar of a monomial M. Optinally, a range
-of variables may be specified with arguments START and END."
-  (declare (type monom m) (fixnum start end))
-  (monom-total-degree m start end))
-
-(defun monom-div (m1 m2 &aux (result (copy-seq m1)))
-  "Divide monomial M1 by monomial M2."
-  (declare (type monom m1 m2 result))
-  (map-into result #'- m1 m2))
-
-(defun monom-mul (m1 m2  &aux (result (copy-seq m1)))
-  "Multiply monomial M1 by monomial M2."
-  (declare (type monom m1 m2 result))
-  (map-into result #'+ m1 m2))
-
-(defun monom-divides-p (m1 m2)
-  "Returns T if monomial M1 divides monomial M2, NIL otherwise."
-  (declare (type monom m1 m2))
-  (every #'<= m1 m2))
-
-(defun monom-divides-monom-lcm-p (m1 m2 m3)
-  "Returns T if monomial M1 divides MONOM-LCM(M2,M3), NIL otherwise."
-  (declare (type monom m1 m2 m3))
-  (every #'(lambda (x y z) (declare (type exponent x y z)) (<= x (max y z))) m1 m2 m3))
-
-(defun monom-lcm-divides-monom-lcm-p (m1 m2 m3 m4)
-  "Returns T if monomial MONOM-LCM(M1,M2) divides MONOM-LCM(M3,M4), NIL otherwise."
-  (declare (type monom m1 m2 m3 m4))
-  (every #'(lambda (x y z w) (declare (type exponent x y z w)) (<= (max x y) (max z w))) m1 m2 m3 m4))
-
-(defun monom-lcm-equal-monom-lcm-p (m1 m2 m3 m4)
-  "Returns T if monomial MONOM-LCM(M1,M2) equals MONOM-LCM(M3,M4), NIL otherwise."
-  (declare (type monom m1 m2 m3 m4))
-  (every #'(lambda (x y z w) (declare (type exponent x y z w)) (= (max x y) (max z w))) m1 m2 m3 m4))
-
-(defun monom-divisible-by-p (m1 m2)
-  "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise."
-  (declare (type monom m1 m2))
-   (every #'>= m1 m2))
-
-(defun monom-rel-prime-p (m1 m2)
-  "Returns T if two monomials M1 and M2 are relatively prime (disjoint)."
-  (declare (type monom m1 m2))
-  (every #'(lambda (x y) (declare (type exponent x y)) (zerop (min x y))) m1 m2))
-
-(defun monom-equal-p (m1 m2)
-  "Returns T if two monomials M1 and M2 are equal."
-  (declare (type monom m1 m2))
-  (every #'= m1 m2))
-
-(defun monom-lcm (m1 m2 &aux (result (copy-seq m1)))
-  "Returns least common multiple of monomials M1 and M2."
-  (declare (type monom m1 m2))
-  (map-into result #'max m1 m2))
-
-(defun monom-gcd (m1 m2 &aux (result (copy-seq m1)))
-  "Returns greatest common divisor of monomials M1 and M2."
-  (declare (type monom m1 m2))
-  (map-into result #'min m1 m2))
-
-(defun monom-depends-p (m k)
-  "Return T if the monomial M depends on variable number K."
-  (declare (type monom m) (fixnum k))
-  (plusp (elt m k)))
-
-(defmacro monom-map (fun m &rest ml &aux (result `(copy-seq ,m)))
-  `(map-into ,result ,fun ,m ,@ml))
-
-(defmacro monom-append (m1 m2)
-  `(concatenate 'monom ,m1 ,m2))
-
-(defmacro monom-contract (k m)
-  `(subseq ,m ,k))
-
-(defun monom-exponents (m)
-  (declare (type monom m))
-  (coerce m 'list))
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Implementations of various admissible monomial orders
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; pure lexicographic
-(defun lex> (p q &optional (start 0) (end (monom-dimension  p)))
-  "Return T if P>Q with respect to lexicographic order, otherwise NIL.
-The second returned value is T if P=Q, otherwise it is NIL."
-  (declare (type monom p q) (type fixnum start end))
-  (do ((i start (1+ i)))
-      ((>= i end) (values nil t))
-    (declare (type fixnum i))
-    (cond
-     ((> (monom-elt p i) (monom-elt q i))
-      (return-from lex> (values t nil)))
-     ((< (monom-elt p i) (monom-elt q i))
-      (return-from lex> (values nil nil))))))
-
-;; total degree order , ties broken by lexicographic
-(defun grlex> (p q &optional (start 0) (end (monom-dimension  p)))
-  "Return T if P>Q with respect to graded lexicographic order, otherwise NIL.
-The second returned value is T if P=Q, otherwise it is NIL."
-  (declare (type monom p q) (type fixnum start end))
-  (let ((d1 (monom-total-degree p start end))
-	(d2 (monom-total-degree q start end)))
-    (cond
-      ((> d1 d2) (values t nil))
-      ((< d1 d2) (values nil nil))
-      (t
-	(lex> p q start end)))))
-
-
-;; total degree, ties broken by reverse lexicographic
-(defun grevlex> (p q &optional (start 0) (end (monom-dimension  p)))
-  "Return T if P>Q with respect to graded reverse lexicographic order,
-NIL otherwise. The second returned value is T if P=Q, otherwise it is NIL."
-  (declare (type monom p q) (type fixnum start end))
-  (let ((d1 (monom-total-degree p start end))
-	(d2 (monom-total-degree q start end)))
-    (cond
-     ((> d1 d2) (values t nil))
-     ((< d1 d2) (values nil nil))
-     (t
-      (revlex> p q start end)))))
-
-
-;; reverse lexicographic
-(defun revlex> (p q &optional (start 0) (end (monom-dimension  p)))
-  "Return T if P>Q with respect to reverse lexicographic order, NIL
-otherwise.  The second returned value is T if P=Q, otherwise it is
-NIL. This is not and admissible monomial order because some sets do
-not have a minimal element. This order is useful in constructing other
-orders."
-  (declare (type monom p q) (type fixnum start end))
-  (do ((i (1- end) (1- i)))
-      ((< i start) (values nil t))
-    (declare (type fixnum i))
-    (cond
-     ((< (monom-elt p i) (monom-elt q i))
-      (return-from revlex> (values t nil)))
-     ((> (monom-elt p i) (monom-elt q i))
-      (return-from revlex> (values nil nil))))))
-
-
-(defun invlex> (p q &optional (start 0) (end (monom-dimension  p)))
-  "Return T if P>Q with respect to inverse lexicographic order, NIL otherwise
-The second returned value is T if P=Q, otherwise it is NIL."
-  (declare (type monom p q) (type fixnum start end))
-  (do ((i (1- end) (1- i)))
-      ((< i start) (values nil t))
-    (declare (type fixnum i))
-      (cond
-	 ((> (monom-elt p i) (monom-elt q i))
-	  (return-from invlex> (values t nil)))
-	 ((< (monom-elt p i) (monom-elt q i))
-	  (return-from invlex> (values nil nil))))))
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Order making functions
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar *monomial-order* #'lex>
-  "Default order for monomial comparisons")
-
-(defmacro monomial-order (x y)
-  `(funcall *monomial-order* ,x ,y))
-
-(defun reverse-monomial-order (x y)
-  (monomial-order y x))
-
-(defvar *primary-elimination-order* #'lex>)
-
-(defvar *secondary-elimination-order* #'lex>)
-
-(defvar *elimination-order* nil
-  "Default elimination order used in elimination-based functions.
-If not NIL, it is assumed to be a proper elimination order. If NIL,
-we will construct an elimination order using the values of
-*PRIMARY-ELIMINATION-ORDER* and *SECONDARY-ELIMINATION-ORDER*.")
-
-(defun elimination-order (k)
-  "Return a predicate which compares monomials according to the
-K-th elimination order. Two variables *PRIMARY-ELIMINATION-ORDER*
-and *SECONDARY-ELIMINATION-ORDER* control the behavior on the first K
-and the remaining variables, respectively."
-  (declare (type fixnum k))
-  #'(lambda (p q &optional (start 0) (end (monom-dimension  p)))
-      (declare (type monom p q) (type fixnum start end))
-      (multiple-value-bind (primary equal)
-	   (funcall *primary-elimination-order* p q start k)
-	 (if equal
-	     (funcall *secondary-elimination-order* p q k end)
-	   (values primary nil)))))
-
-(defun elimination-order-1 (p q &optional (start 0) (end (monom-dimension  p)))
-  "Equivalent to the function returned by the call to (ELIMINATION-ORDER 1)."
-  (declare (type monom p q) (type fixnum start end))
-  (cond
-   ((> (monom-elt p start) (monom-elt q start)) (values t nil))
-   ((< (monom-elt p start) (monom-elt q start)) (values nil nil))
-   (t (funcall *secondary-elimination-order* p q (1+ start) end))))
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Priority queue stuff
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defparameter *priority-queue-allocation-size* 16)
-
-(defun priority-queue-make-heap (&key (element-type 'fixnum))
-  (make-array *priority-queue-allocation-size* :element-type element-type :fill-pointer 1
-	      :adjustable t))
-
-(defstruct (priority-queue (:constructor priority-queue-construct))
-  (heap (priority-queue-make-heap))
-  test)
-
-(defun make-priority-queue (&key (element-type 'fixnum)
-			    (test #'<=)
-			    (element-key #'identity))
-  (priority-queue-construct
-   :heap (priority-queue-make-heap :element-type element-type)
-   :test #'(lambda (x y) (funcall test (funcall element-key y) (funcall element-key x)))))
-  
-(defun priority-queue-insert (pq item)
-  (priority-queue-heap-insert (priority-queue-heap pq) item (priority-queue-test pq)))
-
-(defun priority-queue-remove (pq)
-  (priority-queue-heap-remove (priority-queue-heap pq) (priority-queue-test pq)))
-
-(defun priority-queue-empty-p (pq)
-  (priority-queue-heap-empty-p (priority-queue-heap pq)))
-
-(defun priority-queue-size (pq)
-  (fill-pointer (priority-queue-heap pq)))
-
-(defun priority-queue-upheap (a k
-	       &optional
-	       (test #'<=)
-	       &aux  (v (aref a k)))
-  (declare (fixnum k))
-  (assert (< 0 k (fill-pointer a)))
-  (loop
-   (let ((parent (ash k -1)))
-     (when (zerop parent) (return))
-     (unless (funcall test (aref a parent) v)
-       (return))
-     (setf (aref a k) (aref a parent)
-	   k parent)))
-  (setf (aref a k) v)
-  a)
-
-    
-(defun priority-queue-heap-insert (a item &optional (test #'<=))
-  (vector-push-extend item a)
-  (priority-queue-upheap a (1- (fill-pointer a)) test))
-
-(defun priority-queue-downheap (a k
-		 &optional
-		 (test #'<=)
-		 &aux  (v (aref a k)) (j 0) (n (fill-pointer a)))
-  (declare (fixnum k n j))
-  (loop
-   (unless (<= k (ash n -1))
-     (return))
-   (setf j (ash k 1))
-   (if (and (< j n) (not (funcall test (aref a (1+ j)) (aref a j))))
-       (incf j))
-   (when (funcall test (aref a j) v)
-     (return))
-   (setf (aref a k) (aref a j)
-	 k j))
-  (setf (aref a k) v)
-  a)
-
-(defun priority-queue-heap-remove (a &optional (test #'<=) &aux (v (aref a 1)))
-  (when (<= (fill-pointer a) 1) (error "Empty queue."))
-  (setf (aref a 1) (vector-pop a))
-  (priority-queue-downheap a 1 test)
-  (values v a))
-
-(defun priority-queue-heap-empty-p (a)
-  (<= (fill-pointer a) 1))
+
+
 
 
@@ -530,30 +135,4 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun make-term-variable (ring nvars pos
-				&optional
-				(power 1)
-				(coeff (funcall (ring-unit ring)))
-				&aux
-				(monom (make-monom nvars :initial-element 0)))
-  (declare (fixnum nvars pos power))
-  (incf (monom-elt monom pos) power)
-  (make-term monom coeff))
-
-(defstruct (term
-	    (:constructor make-term (monom coeff))
-	    ;;(:constructor make-term-variable)
-	    ;;(:type list)
-	    )
-  (monom (make-monom 0) :type monom)
-  (coeff nil))
-
-(defun term-sugar (term)
-  (monom-sugar (term-monom term)))
-
-(defun termlist-sugar (p &aux (sugar -1))
-  (declare (fixnum sugar))
-  (dolist (term p sugar)
-    (setf sugar (max sugar (term-sugar term)))))
 
 
@@ -703,224 +282,4 @@
 
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Additional structure operations on a list of terms
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun termlist-contract (p &optional (k 1))
-  "Eliminate first K variables from a polynomial P."
-  (mapcar #'(lambda (term) (make-term (monom-contract k (term-monom term))
-				      (term-coeff term)))
-	  p))
-
-(defun termlist-extend (p &optional (m (make-monom 1 :initial-element 0)))
-  "Extend every monomial in a polynomial P by inserting at the
-beginning of every monomial the list of powers M."
-  (mapcar #'(lambda (term) (make-term (monom-append m (term-monom term))
-				      (term-coeff term)))
-	  p))
-
-(defun termlist-add-variables (p n)
-  "Add N variables to a polynomial P by inserting zero powers
-at the beginning of each monomial."
-  (declare (fixnum n))
-  (mapcar #'(lambda (term)
-	      (make-term (monom-append (make-monom n :initial-element 0)
-				       (term-monom term))
-			 (term-coeff term)))
-	  p))
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Arithmetic on polynomials
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defstruct (poly
-	    ;;BOA constructor, by default constructs zero polynomial
-	    (:constructor make-poly-from-termlist (termlist &optional (sugar (termlist-sugar termlist))))
-	    (:constructor make-poly-zero (&aux (termlist nil) (sugar -1)))
-	    ;;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))))
-  (termlist nil :type list)
-  (sugar -1 :type fixnum))
-
-;; Leading term
-(defmacro poly-lt (p) `(car (poly-termlist ,p)))
-
-;; Second term
-(defmacro poly-second-lt (p) `(cadar (poly-termlist ,p)))
-
-;; Leading monomial
-(defun poly-lm (p) (term-monom (poly-lt p)))
-
-;; Second monomial
-(defun poly-second-lm (p) (term-monom (poly-second-lt p)))
-
-;; Leading coefficient
-(defun poly-lc (p) (term-coeff (poly-lt p)))
-
-;; Second coefficient
-(defun poly-second-lc (p) (term-coeff (poly-second-lt p)))
-
-;; Testing for a zero polynomial
-(defun poly-zerop (p) (null (poly-termlist p)))
-
-;; The number of terms
-(defun poly-length (p) (length (poly-termlist p)))
-
-(defun scalar-times-poly (ring c p)
-  (make-poly-from-termlist (scalar-times-termlist ring c (poly-termlist p)) (poly-sugar p)))
-
-;; The scalar product omitting the head term
-(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))))
-
-(defun term-times-poly (ring term p)
-  (make-poly-from-termlist (term-times-termlist ring term (poly-termlist p)) (+ (poly-sugar p) (term-sugar term))))
-
-(defun poly-add (ring p q)
-  (make-poly-from-termlist (termlist-add ring (poly-termlist p) (poly-termlist q)) (max (poly-sugar p) (poly-sugar q))))
-
-(defun poly-sub (ring p q)
-  (make-poly-from-termlist (termlist-sub ring (poly-termlist p) (poly-termlist q)) (max (poly-sugar p) (poly-sugar q))))
-
-(defun poly-uminus (ring p)
-  (make-poly-from-termlist (termlist-uminus ring (poly-termlist p)) (poly-sugar p)))
-
-(defun poly-mul (ring p q)
-  (make-poly-from-termlist (termlist-mul ring (poly-termlist p) (poly-termlist q)) (+ (poly-sugar p) (poly-sugar q))))
-
-(defun poly-expt (ring p n)
-  (make-poly-from-termlist (termlist-expt ring (poly-termlist p) n) (* n (poly-sugar p))))
-
-(defun poly-append (&rest plist)
-  (make-poly-from-termlist (apply #'append (mapcar #'poly-termlist plist))
-	     (apply #'max (mapcar #'poly-sugar plist))))
-
-(defun poly-nreverse (p)
-  (setf (poly-termlist p) (nreverse (poly-termlist p)))
-  p)
-
-(defun poly-contract (p &optional (k 1))
-  (make-poly-from-termlist (termlist-contract (poly-termlist p) k)
-	     (poly-sugar p)))
-
-(defun poly-extend (p &optional (m (make-monom 1 :initial-element 0)))
-  (make-poly-from-termlist
-   (termlist-extend (poly-termlist p) m)
-   (+ (poly-sugar p) (monom-sugar m))))
-
-(defun poly-add-variables (p k)
-  (setf (poly-termlist p) (termlist-add-variables (poly-termlist p) k))
-  p)
-
-(defun poly-list-add-variables (plist k)
-  (mapcar #'(lambda (p) (poly-add-variables p k)) plist))
-
-(defun poly-standard-extension (plist &aux (k (length plist)))
-  "Calculate [U1*P1,U2*P2,...,UK*PK], where PLIST=[P1,P2,...,PK]."
-  (declare (list plist) (fixnum k))
-  (labels ((incf-power (g i)
-	     (dolist (x (poly-termlist g))
-	       (incf (monom-elt (term-monom x) i)))
-	     (incf (poly-sugar g))))
-    (setf plist (poly-list-add-variables plist k))
-    (dotimes (i k plist)
-      (incf-power (nth i plist) i))))
-
-(defun saturation-extension (ring f plist &aux (k (length plist)) (d (monom-dimension (poly-lm (car plist)))))
-  "Calculate [F, U1*P1-1,U2*P2-1,...,UK*PK-1], where PLIST=[P1,P2,...,PK]."
-  (setf f (poly-list-add-variables f k)
-	plist (mapcar #'(lambda (x)
-			  (setf (poly-termlist x) (nconc (poly-termlist x)
-							 (list (make-term (make-monom d :initial-element 0)
-									  (funcall (ring-uminus ring) (funcall (ring-unit ring)))))))
-			  x)
-		      (poly-standard-extension plist)))
-  (append f plist))
-
-
-(defun polysaturation-extension (ring f plist &aux (k (length 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)
-	plist (apply #'poly-append (poly-standard-extension plist))
-	(cdr (last (poly-termlist plist))) (list (make-term (make-monom d :initial-element 0)
-							    (funcall (ring-uminus ring) (funcall (ring-unit ring))))))
-  (append f (list plist)))
-
-(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)))))))
-
 
 
@@ -931,7 +290,4 @@
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
 (defmacro debug-cgb (&rest args)
   `(when $poly_grobner_debug (format *terminal-io* ,@args)))
