Index: kefile
===================================================================
--- /Makefile	(revision 13)
+++ 	(revision )
@@ -1,7 +1,0 @@
-# $Id: Makefile,v 1.3 2009/01/19 19:20:45 marek Exp $
-
-TARDIR="."
-DATE=`date -u +%F-%T`
-
-distrib: 
-	tar -X ./exclude-file -zcvf $(TARDIR)/cgb-$(DATE).tgz -C .. CGB
Index: ADME
===================================================================
--- /README	(revision 13)
+++ 	(revision )
@@ -1,166 +1,0 @@
-#	$Id: README,v 1.7 1997/11/30 19:33:01 marek Exp $	
-
-From: rychlik@math.arizona.edu
-----------------------------------------------------------------
-I. GENERAL REMARKS
-----------------------------------------------------------------
-Dear User:
-
-	This is an experimental Comprehensive Grobner Basis package.
-In order to use the package you must be familiar with the lisp
-syntax. The command language used is that of lisp. However,
-in order to facilitate input and output, some limited facilities
-for the customary infix notation are included. The documentation
-of the Lisp code can be found in sets of automatically
-generated manuals, in the following sub-directories:
-
-	./latex-doc	- a LaTeX documentation
-	./doc		- pure text documentation
-
-The package has been tested under the following environments:
-----------------------------------------------------------------
-1. SUN SPARC/UNIX, AKCL (Austing Kyoto Common Lisp version 615 )
-2. Linux 1.2.13 + gcl 2.0
-3. Linux 2.0 + Allegro 4.3 
-----------------------------------------------------------------
-The current development environment is
-
-	Linux 2.0 + Allegro Common Lisp v. 4.3
-
-If incompatibilities arise with other environments as a result
-of new code being added, please let me know. In general, only
-then I will try to fix the compatibility issues.
-----------------------------------------------------------------
-II. THE MATHEMATICAL BACKGROUND
-----------------------------------------------------------------
-For a definition of a Comprehensive Grobner Basis, see
-
-	Volker Weispfenning, Comprehensive Groebner Bases,
-	Journal of Symbolic Computation
-	volume 14, 1992,
-	Pages 1-29
-
-That paper defines the basic notion of a Grobner System (the object that
-is calculated by the current package). In the paper you will also find 
-a description of a software system which calculates Comprehensive Grobner
-Bases. Our package initially grew out of frustration with that package,
-however, we feel that in the process of writing thin new package we made
-a number of substantial improvements to the original mathematical idea
-of the Weispfenning's paper.
-
-William Dunn has written a dissertation which describes the ideas behind
-the current package. It also contains an elaboration of the ideas of
-Weispfenning. To obtain a copy, contact the author at
-................................................................
-	dunn@math.arizona.edu
-................................................................
-
-----------------------------------------------------------------
-II. HOW TO USE THE PACKAGE?
-----------------------------------------------------------------
-
-The basic operation of the package consists in typing commands at the
-Lisp prompt:
-Example: The basic example of the theory is the following
-----------------------------------------------------------------
->(STRING-GROBNER-SYSTEM "[x+y,x+u*y]" '(X Y) '(U))
-------------------- CASE 1 -------------------
-Condition:
-  Green list: [  ]
-  Red list: [ U - 1 ]
- Basis: [ (U - 1) * X, ( - U + 1) * Y ]
-------------------- CASE 2 -------------------
-Condition:
-  Green list: [ U - 1 ]
-  Red list: [  ]
- Basis: [ (1) * X + (1) * Y ]
-----------------------------------------------------------------
-This example calculates the Grobner System corresponding to the
-ideal [x+y,x+u*y] in k[u][x,y], where u is a parameter. The output
-consists of a number of CASES. The cases correspond to distinct elements
-of the partition of the parameter space. The "Green List" is a list of
-polynomial in parameters that are 0 on a given chunk of the parameter space,
-while "Red List" is a list of polynomials which are different from 0.
-Thus, CASE 1 corresponds to those parameters for which u is not 1,
-while CASE 2 corresponds to u=1. The "Basis" part lists a plain Grobner Basis
-of the ideal in k[x,y] obtained by specializing the parameter u in such
-a way that the restriction imposed by the corresponding Green List and Red
-List are satisfied.
-
-The ideal specification is given as string "[x+y,x+u*y]". As a rule, when
-we have a command in our package which starts with a prefix string-... then
-one or more of the arguments are going to have a form of a string. This string
-is immediately parsed from infix notation to internal form and then typically
-a corresponding command without the prefix string-... is called to perform the
-calculation on internal representation. Most of the string commands provide
-a keyword argument :suppress-value which is by default set to T, but if it
-is set to NIL, the corresponding internal form of the answer is returned.
-
-The ./tests subdirectory of the distribution directory contains
-several files which can be used as examples of problem formulation
-in the form acceptable to cgb-lisp
-
-For more examples, see the files colored-poly-tests.lisp and
-colored-poly-tests.output. These files are used by me to test the 
-operation of the primary commands of the package.
-----------------------------------------------------------------
-IV. INSTALLATION
-----------------------------------------------------------------
-First make an empty directory of your choice, say /usr/local/CGBlisp.
-The following instructions require a modification if you install
-in a different directory.
-
-	0. Copy the tared and compressed source (cgb.tar.gz) into /usr/local/CGBlisp
-	Unpack the files:
-
-		% zcat cgb.tar.gz | tar xvf -
-	1. Change working directory to /usr/local/CGBlisp/src.
-	
-	2. Start your Common Lisp in the src directory and do
-		> (load "defsystem.lisp")
-		> (in-package :make-cgb)
-	Then do
-		MAKE-CGB> (cgb-load)
-	to get an interpreted version of the package (slow!) or
-	make a compiled version with
-		MAKE-CGB> (cgb-compile-and-load)
-	If you want, you may create a custom binary by dumping
-	core and making it executable, in a fashion depending on your
-	lisp system. For instance, kcl/gcl uses
-		MAKE-CGB> (cgb-save "fileOfYourChoice")
-	and Allegro Common Lisp uses
-		MAKE-CGB> (dumplisp :name "fileofyourchoice")
-	If you do not create the custom binary, each time you start
-	your Lisp, you will need to repeat the first two steps, i.e.
-
-		> (load "defsystem.lisp")
-		> (make-cgb::cgb-load)
-		> (in-package :cgb-lisp)
-	to get either an interpreted or compiled version of the package.
-
-NOTE: Some lisps use .lisp as extension of Lisp source code and others
-.lsp, and perhaps others.  You will need to rename and edit all files
-if the extension .lisp is not accepted.
-
-Yet another compatibility issue may arise from the fact that this
-package was developed before the ANSI standard was finalized. Thus,
-compatibility issues arise, for instance with the current version of
-Allegro Common Lisp because the package uses the "Cltl1" conventions
-(the book of Guy Steele which was a de facto Common Lisp definition in
-the 80's). The incompatibilities for Allegro were resolved in
-defsystem.lisp by setting some Allegro switches which turn on "Cltl1"
-conventions for package loading and compilation.  You may need to
-adapt the same strategy with other lisps, or rewrite the top of each
-file to observe the new ANSI standard.
-
-----------------------------------------------------------------
-V. FINAL REMARKS
-----------------------------------------------------------------
-Please send your comments to me, and I will try to improve your package
-according to your suggestions.
-
-Enjoy,
-
---Marek Rychlik (rychlik@math.arizona.edu)
-
-
Index: /trunk/Makefile
===================================================================
--- /trunk/Makefile	(revision 14)
+++ /trunk/Makefile	(revision 14)
@@ -0,0 +1,7 @@
+# $Id: Makefile,v 1.3 2009/01/19 19:20:45 marek Exp $
+
+TARDIR="."
+DATE=`date -u +%F-%T`
+
+distrib: 
+	tar -X ./exclude-file -zcvf $(TARDIR)/cgb-$(DATE).tgz -C .. CGB
Index: /trunk/README
===================================================================
--- /trunk/README	(revision 14)
+++ /trunk/README	(revision 14)
@@ -0,0 +1,166 @@
+#	$Id: README,v 1.7 1997/11/30 19:33:01 marek Exp $	
+
+From: rychlik@math.arizona.edu
+----------------------------------------------------------------
+I. GENERAL REMARKS
+----------------------------------------------------------------
+Dear User:
+
+	This is an experimental Comprehensive Grobner Basis package.
+In order to use the package you must be familiar with the lisp
+syntax. The command language used is that of lisp. However,
+in order to facilitate input and output, some limited facilities
+for the customary infix notation are included. The documentation
+of the Lisp code can be found in sets of automatically
+generated manuals, in the following sub-directories:
+
+	./latex-doc	- a LaTeX documentation
+	./doc		- pure text documentation
+
+The package has been tested under the following environments:
+----------------------------------------------------------------
+1. SUN SPARC/UNIX, AKCL (Austing Kyoto Common Lisp version 615 )
+2. Linux 1.2.13 + gcl 2.0
+3. Linux 2.0 + Allegro 4.3 
+----------------------------------------------------------------
+The current development environment is
+
+	Linux 2.0 + Allegro Common Lisp v. 4.3
+
+If incompatibilities arise with other environments as a result
+of new code being added, please let me know. In general, only
+then I will try to fix the compatibility issues.
+----------------------------------------------------------------
+II. THE MATHEMATICAL BACKGROUND
+----------------------------------------------------------------
+For a definition of a Comprehensive Grobner Basis, see
+
+	Volker Weispfenning, Comprehensive Groebner Bases,
+	Journal of Symbolic Computation
+	volume 14, 1992,
+	Pages 1-29
+
+That paper defines the basic notion of a Grobner System (the object that
+is calculated by the current package). In the paper you will also find 
+a description of a software system which calculates Comprehensive Grobner
+Bases. Our package initially grew out of frustration with that package,
+however, we feel that in the process of writing thin new package we made
+a number of substantial improvements to the original mathematical idea
+of the Weispfenning's paper.
+
+William Dunn has written a dissertation which describes the ideas behind
+the current package. It also contains an elaboration of the ideas of
+Weispfenning. To obtain a copy, contact the author at
+................................................................
+	dunn@math.arizona.edu
+................................................................
+
+----------------------------------------------------------------
+II. HOW TO USE THE PACKAGE?
+----------------------------------------------------------------
+
+The basic operation of the package consists in typing commands at the
+Lisp prompt:
+Example: The basic example of the theory is the following
+----------------------------------------------------------------
+>(STRING-GROBNER-SYSTEM "[x+y,x+u*y]" '(X Y) '(U))
+------------------- CASE 1 -------------------
+Condition:
+  Green list: [  ]
+  Red list: [ U - 1 ]
+ Basis: [ (U - 1) * X, ( - U + 1) * Y ]
+------------------- CASE 2 -------------------
+Condition:
+  Green list: [ U - 1 ]
+  Red list: [  ]
+ Basis: [ (1) * X + (1) * Y ]
+----------------------------------------------------------------
+This example calculates the Grobner System corresponding to the
+ideal [x+y,x+u*y] in k[u][x,y], where u is a parameter. The output
+consists of a number of CASES. The cases correspond to distinct elements
+of the partition of the parameter space. The "Green List" is a list of
+polynomial in parameters that are 0 on a given chunk of the parameter space,
+while "Red List" is a list of polynomials which are different from 0.
+Thus, CASE 1 corresponds to those parameters for which u is not 1,
+while CASE 2 corresponds to u=1. The "Basis" part lists a plain Grobner Basis
+of the ideal in k[x,y] obtained by specializing the parameter u in such
+a way that the restriction imposed by the corresponding Green List and Red
+List are satisfied.
+
+The ideal specification is given as string "[x+y,x+u*y]". As a rule, when
+we have a command in our package which starts with a prefix string-... then
+one or more of the arguments are going to have a form of a string. This string
+is immediately parsed from infix notation to internal form and then typically
+a corresponding command without the prefix string-... is called to perform the
+calculation on internal representation. Most of the string commands provide
+a keyword argument :suppress-value which is by default set to T, but if it
+is set to NIL, the corresponding internal form of the answer is returned.
+
+The ./tests subdirectory of the distribution directory contains
+several files which can be used as examples of problem formulation
+in the form acceptable to cgb-lisp
+
+For more examples, see the files colored-poly-tests.lisp and
+colored-poly-tests.output. These files are used by me to test the 
+operation of the primary commands of the package.
+----------------------------------------------------------------
+IV. INSTALLATION
+----------------------------------------------------------------
+First make an empty directory of your choice, say /usr/local/CGBlisp.
+The following instructions require a modification if you install
+in a different directory.
+
+	0. Copy the tared and compressed source (cgb.tar.gz) into /usr/local/CGBlisp
+	Unpack the files:
+
+		% zcat cgb.tar.gz | tar xvf -
+	1. Change working directory to /usr/local/CGBlisp/src.
+	
+	2. Start your Common Lisp in the src directory and do
+		> (load "defsystem.lisp")
+		> (in-package :make-cgb)
+	Then do
+		MAKE-CGB> (cgb-load)
+	to get an interpreted version of the package (slow!) or
+	make a compiled version with
+		MAKE-CGB> (cgb-compile-and-load)
+	If you want, you may create a custom binary by dumping
+	core and making it executable, in a fashion depending on your
+	lisp system. For instance, kcl/gcl uses
+		MAKE-CGB> (cgb-save "fileOfYourChoice")
+	and Allegro Common Lisp uses
+		MAKE-CGB> (dumplisp :name "fileofyourchoice")
+	If you do not create the custom binary, each time you start
+	your Lisp, you will need to repeat the first two steps, i.e.
+
+		> (load "defsystem.lisp")
+		> (make-cgb::cgb-load)
+		> (in-package :cgb-lisp)
+	to get either an interpreted or compiled version of the package.
+
+NOTE: Some lisps use .lisp as extension of Lisp source code and others
+.lsp, and perhaps others.  You will need to rename and edit all files
+if the extension .lisp is not accepted.
+
+Yet another compatibility issue may arise from the fact that this
+package was developed before the ANSI standard was finalized. Thus,
+compatibility issues arise, for instance with the current version of
+Allegro Common Lisp because the package uses the "Cltl1" conventions
+(the book of Guy Steele which was a de facto Common Lisp definition in
+the 80's). The incompatibilities for Allegro were resolved in
+defsystem.lisp by setting some Allegro switches which turn on "Cltl1"
+conventions for package loading and compilation.  You may need to
+adapt the same strategy with other lisps, or rewrite the top of each
+file to observe the new ANSI standard.
+
+----------------------------------------------------------------
+V. FINAL REMARKS
+----------------------------------------------------------------
+Please send your comments to me, and I will try to improve your package
+according to your suggestions.
+
+Enjoy,
+
+--Marek Rychlik (rychlik@math.arizona.edu)
+
+
Index: /trunk/samples/alt.output
===================================================================
--- /trunk/samples/alt.output	(revision 14)
+++ /trunk/samples/alt.output	(revision 14)
@@ -0,0 +1,36 @@
+Condition:
+  Green list: [ X2, X3, Y3 ]
+  Red list: [  ]
+ Basis: [ ( - 1) * X * V1 + (1) * Y * U1, ( - 1) * X * V2 + (1) * Y * U2, ( - 1) * X * V3 + (1) * Y * U3, ( - 1) * Y * U1 * V2 + (1) * Y * V1 * U2, ( - 1) * Y * U1 * V3 + (1) * Y * V1 * U3, ( - 1) * Y * U2 * V3 + (1) * Y * V2 * U3 ]
+Condition:
+  Green list: [ X2, X3 ]
+  Red list: [ Y3 ]
+ Basis: [ ( - 1) * X * V3 + (Y3) * X + (1) * Y * U3 + ( - Y3) * U3, (Y3) * V1, (Y3) * V2, (2 * Y3) * Y * U1, (2 * Y3) * Y * U2 ]
+Condition:
+  Green list: [ X2 ]
+  Red list: [ X3 ]
+ Basis: [ ( - 1) * X * V3 + (Y3) * X + (1) * Y * U3 + ( - X3) * Y + ( - Y3) * U3 + (X3) * V3, (X3) * U1 + (Y3) * V1, (X3) * U2 + (Y3) * V2, ( - X3) * Y * V1 * U3 + ( - Y3) * Y * V1 * V3 + (X3^2 + Y3^2) * Y * V1 + (X3 * Y3) * V1 * U3 + ( - X3^2) * V1 * V3, (X3) * Y * V2 * U3 + (Y3) * Y * V2 * V3 + ( - X3^2 - Y3^2) * Y * V2 + ( - X3 * Y3) * V2 * U3 + (X3^2) * V2 * V3, ( - X3) * X * V1 + ( - Y3) * Y * V1, ( - X3) * X * V2 + ( - Y3) * Y * V2 ]
+Condition:
+  Green list: [ X3, Y3 ]
+  Red list: [ X2 ]
+ Basis: [ ( - X2) * U1, (X2) * U3, ( - X2) * Y * V1 * U2 + (X2^2) * Y * V1 + ( - X2^2) * V1 * V2, (X2) * Y * U2 * V3 + ( - X2^2) * Y * V3 + (X2^2) * V2 * V3, (X2) * X * V1, ( - 1) * X * V2 + (1) * Y * U2 + ( - X2) * Y + (X2) * V2, (X2) * X * V3 ]
+Condition:
+  Green list: [ X3 ]
+  Red list: [ X2, Y3 ]
+ Basis: [ ( - X2) * U1 + (Y3) * V1, (Y3) * V2, (X2) * U3, (2 * Y3) * Y * U2 + ( - 2 * X2 * Y3) * Y, ( - 2 * X2^3 * Y3) * Y * V1, (2 * X2 * Y3) * Y * V3, (4 * X2 * Y3^2) * X * Y, ( - 2 * X2^4) * X * V1, (X2) * X * V3 + ( - X2 * Y3) * X ]
+Condition:
+  Green list: [  - X2 + X3, Y3 ]
+  Red list: [  - X3, X3 ]
+ Basis: [ (X3) * U2 + (X3^2), ( - X3) * U3 + (X3^2), ( - X3) * Y * U1 * V2 + ( - X3^2) * V1 * V2, ( - X3) * Y * U1 * V3 + (X3^2) * V1 * V3, ( - 1) * X * V1 + (1) * Y * U1, ( - X3) * X * V2 + ( - X3^2) * V2, ( - X3) * X * V3 + (X3^2) * V3 ]
+Condition:
+  Green list: [  - X2 + X3 ]
+  Red list: [  - X3, X3, Y3 ]
+ Basis: [ (Y3) * V1, (X3) * U2 + (Y3) * V2 + (X3^2), ( - X3) * U3 + (X3^2), (2 * Y3) * Y * U1, (X3 * Y3) * Y * V2 * V3 + ( - X3 * Y3^2) * Y * V2, ( - X3) * X * V2 + ( - Y3) * Y * V2 + ( - X3^2) * V2, ( - X3) * X * V3 + (X3 * Y3) * X + (X3^2) * V3 + ( - X3^2 * Y3) ]
+Condition:
+  Green list: [  ]
+  Red list: [ X2, X3,  - X2 + X3, Y3 ]
+ Basis: [ ( - X2 + X3) * U1 + (Y3) * V1, (X3) * U2 + (Y3) * V2 + ( - X2 * X3), (X2) * U3 + ( - X2 * X3), ( - X2 * Y3) * Y * V1 * V2 + (X2^2 * X3 - X2 * X3^2) * V1 * V2, (X2 * Y3) * Y * V1 * V3 + ( - X2 * Y3^2) * Y * V1 + ( - X2^2 * X3 + X2 * X3^2) * V1 * V3 + (X2^2 * X3 * Y3 - X2 * X3^2 * Y3) * V1, ( - X2 * Y3) * Y * V2 * V3 + (X2 * Y3^2) * Y * V2 + (X2^2 * X3 - X2 * X3^2) * V2 * V3 + ( - X2^2 * X3 * Y3 + X2 * X3^2 * Y3) * V2, (X2 - X3) * X * V1 + ( - Y3) * Y * V1, ( - X3) * X * V2 + ( - Y3) * Y * V2 + (X2 * X3) * V2, (X2) * X * V3 + ( - X2 * Y3) * X + ( - X2 * X3) * V3 + (X2 * X3 * Y3) ]
+Condition:
+  Green list: [ Y3 ]
+  Red list: [ X2, X3,  - X2 + X3 ]
+ Basis: [ ( - X2 + X3) * U1, (X3) * U2 + ( - X2 * X3), (X2) * U3 + ( - X2 * X3), (X2^2 * X3 - X2 * X3^2) * V1 * V2, ( - X2^2 * X3 + X2 * X3^2) * V1 * V3, (X2^2 * X3 - X2 * X3^2) * V2 * V3, (X2 - X3) * X * V1, ( - X3) * X * V2 + (X2 * X3) * V2, (X2) * X * V3 + ( - X2 * X3) * V3 ]
Index: /trunk/samples/ans1.output
===================================================================
--- /trunk/samples/ans1.output	(revision 14)
+++ /trunk/samples/ans1.output	(revision 14)
@@ -0,0 +1,39 @@
+(setf fl (parse-string-to-sorted-alist 
+	  "[a^2*x^2*y+b*x^2*y+a^3*b*x*y+a^3*c*x*y,c^2*a*x^2+c^2*b*x^2+b*y+4]"
+	  '(x y a b c)))
+(setf cfl (make-colored-poly-list fl 2))
+(determine cfl)
+(cond-system-print * '(x y) '(a b c))
+
+Condition:
+  Green list: [  ]
+  Red list: [ A^2 + B, A * C^2 + B * C^2 ]
+ Basis: [ (A^2 + B) * X^2 * Y + (A^3 * B + A^3 * C) * X * Y, (A * C^2 + B * C^2) * X^2 + (B) * Y + (4) ]
+Condition:
+  Green list: [ A^2 + B ]
+  Red list: [  - A * B^2 - A * B * C, A * C^2 + B * C^2 ]
+ Basis: [ (A^3 * B + A^3 * C) * X * Y, (A * C^2 + B * C^2) * X^2 + (B) * Y + (4) ]
+Condition:
+  Green list: [ A^2 + B, B + C ]
+  Red list: [ A * C^2 + B * C^2 ]
+ Basis: [ 0, (A * C^2 + B * C^2) * X^2 + (B) * Y + (4) ]
+Condition:
+  Green list: [ A * C^2 + B * C^2 ]
+  Red list: [ A^2 + B, B ]
+ Basis: [ (A^2 + B) * X^2 * Y + (A^3 * B + A^3 * C) * X * Y, (B) * Y + (4) ]
+Condition:
+  Green list: [ A^2 + B, A * C^2 + B * C^2, B * C^2 + C^2 ]
+  Red list: [  - A * B - A * C, B ]
+ Basis: [ (A^3 * B + A^3 * C) * X * Y, (B) * Y + (4) ]
+Condition:
+  Green list: [ B + C,  - C + 1,  - A + 1 ]
+  Red list: [ B ]
+ Basis: [ 0, (B) * Y + (4) ]
+Condition:
+  Green list: [ B, C^2 ]
+  Red list: [ A^2 ]
+ Basis: [ (A^2 + B) * X^2 * Y + (A^3 * B + A^3 * C) * X * Y, (4) ]
+Condition:
+  Green list: [ A^2, B, A * C^2 + B * C^2 ]
+  Red list: [  ]
+ Basis: [ 0, (4) ]
Index: /trunk/samples/apollonius.output
===================================================================
--- /trunk/samples/apollonius.output	(revision 14)
+++ /trunk/samples/apollonius.output	(revision 14)
@@ -0,0 +1,29 @@
+>(load "apollonius")
+Loading apollonius.lisp
+Warning: Test 6 - Circle of Apollonius
+Condition:
+  Green list: [ U1, U2 ]
+  Red list: [  ]
+ Basis: [ (2) * X1, (2) * X2, (2) * X3, (2) * X4, ( - 4) * X6^2 + (8) * X6 * X8, (4) * S * X5^2 + ( - 8) * S * X5 * X7 + ( - 4) ]
+Condition:
+  Green list: [ U2 ]
+  Red list: [ U1 ]
+ Basis: [ ( - 4 * U1^3) ]
+Condition:
+  Green list: [ U1 ]
+  Red list: [ U2 ]
+ Basis: [ (4 * U2^2) ]
+Condition:
+  Green list: [  ]
+  Red list: [  - U1^2 - U2^2,  - U1^2 + U2^2, U1, U2 ]
+ Basis: [ ( - U1^2 - U2^2) * X6 + (U1^2 * U2), (4 * U1^4 * U2 - 4 * U2^5) * X8 + ( - 3 * U1^4 * U2^2 + 2 * U1^2 * U2^4 + U2^6), (2 * U1^6 * U2^2 - 2 * U1^4 * U2^4) * S + (4 * U1^6 - 4 * U1^2 * U2^4), (2) * X1 + ( - U1), (2) * X2 + ( - U2), (2) * X3 + ( - U1), (2) * X4 + ( - U2), ( - U1^2 * U2 - U2^3) * X5 + (U1 * U2^3), ( - 4 * U1^5 + 4 * U1 * U2^4) * X7 + (U1^6 + 2 * U1^4 * U2^2 - 3 * U1^2 * U2^4) ]
+Condition:
+  Green list: [  - U1^2 - U2^2 ]
+  Red list: [  - U2^2, U1, U2 ]
+ Basis: [ (U2^3) ]
+Condition:
+  Green list: [  - U1^2 + U2^2 ]
+  Red list: [ U1, U2 ]
+ Basis: [ (4 * U1) * X7 + ( - 4 * U2) * X8, ( - 4 * U2^3) * S * X8 + (U2^4) * S + (4 * U2^2), (2 * U2^2) * X6 + ( - U2^3), (2) * X1 + ( - U1), (2) * X2 + ( - U2), (2) * X3 + ( - U1), (2) * X4 + ( - U2), (2 * U2^3) * X5 + (U1 * U2^3) ]
+Finished loading apollonius.lisp
+T
Index: /trunk/samples/apollonius2.output
===================================================================
--- /trunk/samples/apollonius2.output	(revision 14)
+++ /trunk/samples/apollonius2.output	(revision 14)
@@ -0,0 +1,30 @@
+This output is correct; it says that if u1#0,u2#0,u1^2+u2^2#0 then
+there is exactly one solution. In fact, we plug the Basis of second case
+into macsyma and get the unique solution for this case:
+----------------------------------------------------------------
+(C12) solve([ ( - 4 * U1) * X7 + (U1^2), ( - 4 * U2) * X8 + (U2^2), ( - U1^2 - U2^2) * X6 + (U1^2 * U2), (2) * X1 + ( - U1), (2) * X2 + ( - U2), (2) * X3 + ( - U1), (2) * X4 + ( - U2), ( - U1^2 * U2 - U2^3) * X5 + (U1 * U2^3) ],[x1,x2,x3,x4,x5,x6,x7,x8]);
+
+						       2	    2
+	     U1	      U2       U1       U2	  U1 U2		  U1  U2
+(D12) [[X1 = --, X2 = --, X3 = --, X4 = --, X5 = ---------, X6 = ---------, 
+	     2	      2	       2        2	   2	 2	   2	 2
+						 U2  + U1	 U2  + U1
+
+								 U1	  U2
+							    X7 = --, X8 = --]]
+								 4	  4
+(C13) 
+----------------------------------------------------------------
+
+>(load "apollonius2.lisp")
+Loading apollonius2.lisp
+Condition:
+  Green list: [  ]
+  Red list: [  - U1^2 - U2^2, U1, U2 ]
+ Basis: [ ( - 4 * U1) * X7 + (U1^2), ( - 4 * U2) * X8 + (U2^2), ( - U1^2 - U2^2) * X6 + (U1^2 * U2), (2) * X1 + ( - U1), (2) * X2 + ( - U2), (2) * X3 + ( - U1), (2) * X4 + ( - U2), ( - U1^2 * U2 - U2^3) * X5 + (U1 * U2^3) ]
+Condition:
+  Green list: [  - U1^2 - U2^2 ]
+  Red list: [ U1, U2 ]
+ Basis: [ (U2^3) ]
+Finished loading apollonius2.lisp
+T
Index: /trunk/samples/colored-poly-tests.output
===================================================================
--- /trunk/samples/colored-poly-tests.output	(revision 14)
+++ /trunk/samples/colored-poly-tests.output	(revision 14)
@@ -0,0 +1,230 @@
+dribbling to file "colored-poly-tests.output"
+ 
+Warning: Test 1
+------------------- CASE 1 -------------------
+Condition:
+  Green list: [  ]
+  Red list: [  ]
+ Basis: [ (4) * X + (5) * Y, ( - 10) * Y^2 ]
+Warning: Test 2 - Enneper
+------------------- CASE 1 -------------------
+Condition:
+  Green list: [  ]
+  Red list: [  ]
+ Basis: [ ( - 3) * U^2 + (3) * V^2 + (1) * Z, (2) * V^3 + (1) * V * Z + (3) * V + ( - 1) * Y, ( - 6) * U * V^2 + (1) * U * Z + ( - 9) * U + (3) * X, (4) * U * V * Z + ( - 3) * U * Y + (3) * V * X, (9) * U * V * Y + ( - 2) * U * Z^2 + (18) * U * Z + ( - 9) * V^2 * X + ( - 6) * X * Z, ( - 27) * U * Y^2 + (8) * U * Z^3 + ( - 72) * U * Z^2 + (36) * V^2 * X * Z + (27) * V * X * Y + (24) * X * Z^2, (34992) * V^2 * X^2 + ( - 34992) * V^2 * Y^2 + ( - 186624) * V^2 * Z + ( - 15552) * V * Y * Z^2 + (46656) * V * Y * Z + (15552) * X^2 * Z + (93312) * X^2 + (19440) * Y^2 * Z + ( - 93312) * Y^2 + ( - 576) * Z^4 + (6912) * Z^3 + (15552) * Z^2 + ( - 279936) * Z, (139968) * U * X + (93312) * V^2 * Z + ( - 139968) * V * Y + (15552) * Z^2 + ( - 139968) * Z, (105815808) * V^2 * Y * Z + (52907904) * V * X^2 + ( - 52907904) * V * Y^2 + (15676416) * V * Z^3 + (141087744) * V * Z^2 + ( - 17635968) * Y * Z^2 + ( - 52907904) * Y * Z, (31104) * V^2 * Z^2 + (93312) * V^2 * Z + ( - 93312) * V * Y * Z + ( - 46656) * X^2 + (46656) * Y^2 + (1728) * Z^3 + ( - 31104) * Z^2 + (139968) * Z, (8817984) * V * X^2 * Z + (26453952) * V * X^2 + (44089920) * V * Y^2 * Z + ( - 26453952) * V * Y^2 + (2612736) * V * Z^4 + (31352832) * V * Z^3 + (70543872) * V * Z^2 + (26453952) * X^2 * Y + ( - 26453952) * Y^3 + ( - 3919104) * Y * Z^3 + ( - 105815808) * Y * Z, ( - 158723712) * V * X^2 * Y + ( - 317447424) * V * Y^3 * Z + (158723712) * V * Y^3 + ( - 23514624) * V * Y * Z^4 + ( - 188116992) * V * Y * Z^3 + ( - 634894848) * V * Y * Z^2 + (26453952) * X^4 + ( - 211631616) * X^2 * Y^2 + (6858432) * X^2 * Z^3 + (88179840) * X^2 * Z^2 + ( - 79361856) * X^2 * Z + (185177664) * Y^4 + (34292160) * Y^2 * Z^3 + ( - 35271936) * Y^2 * Z^2 + (714256704) * Y^2 * Z + ( - 290304) * Z^6 + (2612736) * Z^5 + (23514624) * Z^4 + ( - 211631616) * Z^3, ( - 317447424) * V * Y^3 * Z^2 + ( - 23514624) * V * Y * Z^5 + ( - 211631616) * V * Y * Z^4 + ( - 634894848) * V * Y * Z^3 + ( - 634894848) * V * Y * Z^2 + (26453952) * X^4 * Z + (79361856) * X^4 + ( - 211631616) * X^2 * Y^2 * Z + ( - 158723712) * X^2 * Y^2 + (6858432) * X^2 * Z^4 + (108755136) * X^2 * Z^3 + (185177664) * X^2 * Z^2 + ( - 238085568) * X^2 * Z + (185177664) * Y^4 * Z + (79361856) * Y^4 + (34292160) * Y^2 * Z^4 + ( - 2939328) * Y^2 * Z^3 + (608440896) * Y^2 * Z^2 + (238085568) * Y^2 * Z + ( - 290304) * Z^7 + (1741824) * Z^6 + (31352832) * Z^5 + ( - 141087744) * Z^4 + ( - 634894848) * Z^3, (79361856) * V * X^4 + (2539579392) * V * X^2 + (317447424) * V * Y^4 * Z + ( - 79361856) * V * Y^4 + (23514624) * V * Y^2 * Z^4 + (117573120) * V * Y^2 * Z^3 + ( - 423263232) * V * Y^2 * Z^2 + (5079158784) * V * Y^2 * Z + ( - 2539579392) * V * Y^2 + ( - 6967296) * V * Z^6 + ( - 125411328) * V * Z^5 + ( - 564350976) * V * Z^4 + (752467968) * V * Z^3 + (6772211712) * V * Z^2 + ( - 26453952) * X^4 * Y + (211631616) * X^2 * Y^3 + ( - 6858432) * X^2 * Y * Z^3 + ( - 255721536) * X^2 * Y * Z^2 + ( - 846526464) * X^2 * Y * Z + (2539579392) * X^2 * Y + ( - 185177664) * Y^5 + ( - 34292160) * Y^3 * Z^3 + (44089920) * Y^3 * Z^2 + (211631616) * Y^3 * Z + ( - 2539579392) * Y^3 + (290304) * Y * Z^6 + (10450944) * Y * Z^5 + (7838208) * Y * Z^4 + (188116992) * Y * Z^3 + (3386105856) * Y * Z^2 + ( - 10158317568) * Y * Z, ( - 714256704) * X^6 + (2142770112) * X^4 * Y^2 + ( - 396809280) * X^4 * Z^3 + ( - 4285540224) * X^4 * Z^2 + (2142770112) * X^4 * Z + ( - 2142770112) * X^2 * Y^4 + ( - 2063408256) * X^2 * Y^2 * Z^3 + ( - 4285540224) * X^2 * Y^2 * Z + ( - 47029248) * X^2 * Z^6 + ( - 1269789696) * X^2 * Z^5 + ( - 6348948480) * X^2 * Z^4 + (11428107264) * X^2 * Z^3 + (714256704) * Y^6 + ( - 396809280) * Y^4 * Z^3 + (4285540224) * Y^4 * Z^2 + (2142770112) * Y^4 * Z + (47029248) * Y^2 * Z^6 + ( - 1269789696) * Y^2 * Z^5 + (6348948480) * Y^2 * Z^4 + (11428107264) * Y^2 * Z^3 + (2322432) * Z^9 + ( - 376233984) * Z^7 + (15237476352) * Z^5 ]
+Args:[ U^3 - 3 * U * V^2 - 3 * U + X,  - 3 * U^2 * V + V^3 - 3 * V + Y,  - 3 * U^2 + 3 * V^2 + Z ]
+[ 2187 * V * X^4 + 69984 * V * X^2 + 8748 * V * Y^4 * Z - 2187 * V * Y^4 + 648 * V * Y^2 * Z^4 + 3240 * V * Y^2 * Z^3 - 11664 * V * Y^2 * Z^2 + 139968 * V * Y^2 * Z - 69984 * V * Y^2 - 192 * V * Z^6 - 3456 * V * Z^5 - 15552 * V * Z^4 + 20736 * V * Z^3 + 186624 * V * Z^2 - 729 * X^4 * Y + 5832 * X^2 * Y^3 - 189 * X^2 * Y * Z^3 - 7047 * X^2 * Y * Z^2 - 23328 * X^2 * Y * Z + 69984 * X^2 * Y - 5103 * Y^5 - 945 * Y^3 * Z^3 + 1215 * Y^3 * Z^2 + 5832 * Y^3 * Z - 69984 * Y^3 + 8 * Y * Z^6 + 288 * Y * Z^5 + 216 * Y * Z^4 + 5184 * Y * Z^3 + 93312 * Y * Z^2 - 279936 * Y * Z, 54 * V^2 * Y * Z + 27 * V * X^2 - 27 * V * Y^2 + 8 * V * Z^3 + 72 * V * Z^2 - 9 * Y * Z^2 - 27 * Y * Z, 9 * U * X + 6 * V^2 * Z - 9 * V * Y + Z^2 - 9 * Z, 243 * V^2 * X^2 - 243 * V^2 * Y^2 - 1296 * V^2 * Z - 108 * V * Y * Z^2 + 324 * V * Y * Z + 108 * X^2 * Z + 648 * X^2 + 135 * Y^2 * Z - 648 * Y^2 - 4 * Z^4 + 48 * Z^3 + 108 * Z^2 - 1944 * Z, 2 * V^3 + V * Z + 3 * V - Y, 6 * U * V^2 - U * Z + 9 * U - 3 * X, 3 * U^2 - 3 * V^2 - Z, 4 * U * V * Z - 3 * U * Y + 3 * V * X, 9 * U * V * Y - 2 * U * Z^2 + 18 * U * Z - 9 * V^2 * X - 6 * X * Z, 27 * U * Y^2 - 8 * U * Z^3 + 72 * U * Z^2 - 36 * V^2 * X * Z - 27 * V * X * Y - 24 * X * Z^2, 27 * V * X^2 * Z + 81 * V * X^2 + 135 * V * Y^2 * Z - 81 * V * Y^2 + 8 * V * Z^4 + 96 * V * Z^3 + 216 * V * Z^2 + 81 * X^2 * Y - 81 * Y^3 - 12 * Y * Z^3 - 324 * Y * Z, 18 * V^2 * Z^2 + 54 * V^2 * Z - 54 * V * Y * Z - 27 * X^2 + 27 * Y^2 + Z^3 - 18 * Z^2 + 81 * Z, 4374 * V * X^2 * Y + 8748 * V * Y^3 * Z - 4374 * V * Y^3 + 648 * V * Y * Z^4 + 5184 * V * Y * Z^3 + 17496 * V * Y * Z^2 - 729 * X^4 + 5832 * X^2 * Y^2 - 189 * X^2 * Z^3 - 2430 * X^2 * Z^2 + 2187 * X^2 * Z - 5103 * Y^4 - 945 * Y^2 * Z^3 + 972 * Y^2 * Z^2 - 19683 * Y^2 * Z + 8 * Z^6 - 72 * Z^5 - 648 * Z^4 + 5832 * Z^3, 8748 * V * Y^3 * Z^2 + 648 * V * Y * Z^5 + 5832 * V * Y * Z^4 + 17496 * V * Y * Z^3 + 17496 * V * Y * Z^2 - 729 * X^4 * Z - 2187 * X^4 + 5832 * X^2 * Y^2 * Z + 4374 * X^2 * Y^2 - 189 * X^2 * Z^4 - 2997 * X^2 * Z^3 - 5103 * X^2 * Z^2 + 6561 * X^2 * Z - 5103 * Y^4 * Z - 2187 * Y^4 - 945 * Y^2 * Z^4 + 81 * Y^2 * Z^3 - 16767 * Y^2 * Z^2 - 6561 * Y^2 * Z + 8 * Z^7 - 48 * Z^6 - 864 * Z^5 + 3888 * Z^4 + 17496 * Z^3, 19683 * X^6 - 59049 * X^4 * Y^2 + 10935 * X^4 * Z^3 + 118098 * X^4 * Z^2 - 59049 * X^4 * Z + 59049 * X^2 * Y^4 + 56862 * X^2 * Y^2 * Z^3 + 118098 * X^2 * Y^2 * Z + 1296 * X^2 * Z^6 + 34992 * X^2 * Z^5 + 174960 * X^2 * Z^4 - 314928 * X^2 * Z^3 - 19683 * Y^6 + 10935 * Y^4 * Z^3 - 118098 * Y^4 * Z^2 - 59049 * Y^4 * Z - 1296 * Y^2 * Z^6 + 34992 * Y^2 * Z^5 - 174960 * Y^2 * Z^4 - 314928 * Y^2 * Z^3 - 64 * Z^9 + 10368 * Z^7 - 419904 * Z^5 ]
+Warning:  Test 3 - staple
+------------------- CASE 1 -------------------
+Condition:
+  Green list: [  ]
+  Red list: [ U - 1 ]
+ Basis: [ (U - 1) * X, ( - U + 1) * Y ]
+------------------- CASE 2 -------------------
+Condition:
+  Green list: [ U - 1 ]
+  Red list: [  ]
+ Basis: [ (1) * X + (1) * Y ]
+Warning:  Test 4 - staple
+------------------- CASE 1 -------------------
+Condition:
+  Green list: [ U ]
+  Red list: [  ]
+ Basis: [ (1) * X, (1) * Y ]
+------------------- CASE 2 -------------------
+Condition:
+  Green list: [  ]
+  Red list: [ U, U - 1 ]
+ Basis: [ (U^2 - U) * X, (U - 1) * Y ]
+------------------- CASE 3 -------------------
+Condition:
+  Green list: [ U - 1 ]
+  Red list: [ U ]
+ Basis: [ (1) * X + (1) * Y ]
+Warning: Test 5 - a small robot example
+------------------- CASE 1 -------------------
+Condition:
+  Green list: [  ]
+  Red list: [ L3, A^2 + B^2, L2, A ]
+ Basis: [ ( - 2 * A * L2 * L3) * S2 + ( - 2 * A^2 * L2 - 2 * B^2 * L2) * S1 + (A^2 * B + B^3 + B * L2^2 - B * L3^2), ( - 2 * L2 * L3) * C2 + (A^2 + B^2 - L2^2 - L3^2), ( - 2 * A * L2) * C1 + ( - 2 * B * L2) * S1 + (A^2 + B^2 + L2^2 - L3^2), (4 * A^2 * L2^2 + 4 * B^2 * L2^2) * S1^2 + ( - 4 * A^2 * B * L2 - 4 * B^3 * L2 - 4 * B * L2^3 + 4 * B * L2 * L3^2) * S1 + (A^4 + 2 * A^2 * B^2 - 2 * A^2 * L2^2 - 2 * A^2 * L3^2 + B^4 + 2 * B^2 * L2^2 - 2 * B^2 * L3^2 + L2^4 - 2 * L2^2 * L3^2 + L3^4) ]
+------------------- CASE 2 -------------------
+Condition:
+  Green list: [ A^2 + B^2 ]
+  Red list: [ L3, A^2 * B + B^3 + B * L2^2 - B * L3^2, L2, A ]
+ Basis: [ (4 * A * B * L2^3 * L3 - 4 * A * B * L2 * L3^3) * S2 + ( - 2 * B^2 * L2^4 + 4 * B^2 * L2^2 * L3^2 - 2 * B^2 * L3^4), ( - 2 * L2 * L3) * C2 + ( - L2^2 - L3^2), (4 * A * L2^3 - 4 * A * L2 * L3^2) * C1 + (4 * B^2 * L2^2 - L2^4 + 2 * L2^2 * L3^2 - L3^4), ( - 4 * B * L2^3 + 4 * B * L2 * L3^2) * S1 + (4 * B^2 * L2^2 + L2^4 - 2 * L2^2 * L3^2 + L3^4) ]
+------------------- CASE 3 -------------------
+Condition:
+  Green list: [ A^2 + B^2, L2^2 - L3^2 ]
+  Red list: [ L3, A, L2, A^4 + 2 * A^2 * B^2 - 2 * A^2 * L2^2 - 2 * A^2 * L3^2 + B^4 + 2 * B^2 * L2^2 - 2 * B^2 * L3^2 + L2^4 - 2 * L2^2 * L3^2 + L3^4 ]
+ Basis: [ (4 * B^2 * L3^2) ]
+------------------- CASE 4 -------------------
+Condition:
+  Green list: [ A ]
+  Red list: [ L3, B, L2 ]
+ Basis: [ (4 * B^2 * L2^2) * C1^2 + (B^4 - 2 * B^2 * L2^2 - 2 * B^2 * L3^2 + L2^4 - 2 * L2^2 * L3^2 + L3^4), (2 * B * L2 * L3) * S2 + ( - 2 * B^2 * L2) * C1, ( - 2 * L2 * L3) * C2 + (B^2 - L2^2 - L3^2), ( - 2 * B * L2) * S1 + (B^2 + L2^2 - L3^2) ]
+------------------- CASE 5 -------------------
+Condition:
+  Green list: [ A, B ]
+  Red list: [ L3, L2, A^2 + B^2 + L2^2 - L3^2 ]
+ Basis: [ (L2^2 - L3^2) ]
+------------------- CASE 6 -------------------
+Condition:
+  Green list: [ A, B, L2^2 - L3^2 ]
+  Red list: [ L3, L2 ]
+ Basis: [ (1) * C1^2 + (1) * S1^2 + ( - 1), (L3) * S2, (L3) * C2 + (L2) ]
+Warning: Test 6 - Circle of Apollonius
+------------------- CASE 1 -------------------
+Condition:
+  Green list: [ U2, U1 ]
+  Red list: [  ]
+ Basis: [ (2) * X1, (2) * X2, (2) * X3, (2) * X4, ( - 4) * X6^2 + (8) * X6 * X8, (4) * S * X5^2 + ( - 8) * S * X5 * X7 + ( - 4) ]
+------------------- CASE 2 -------------------
+Condition:
+  Green list: [ U2 ]
+  Red list: [ U1 ]
+ Basis: [ ( - 4 * U1^3) ]
+------------------- CASE 3 -------------------
+Condition:
+  Green list: [ U1 ]
+  Red list: [ U2 ]
+ Basis: [ (4 * U2^2) ]
+------------------- CASE 4 -------------------
+Condition:
+  Green list: [  ]
+  Red list: [ U1, U2, U1^2 - U2^2, U1^2 + U2^2 ]
+ Basis: [ (2) * X1 + ( - U1), (2) * X2 + ( - U2), (2) * X3 + ( - U1), (2) * X4 + ( - U2), (U1^2 * U2 + U2^3) * X5 + ( - U1 * U2^3), ( - U1^2 - U2^2) * X6 + (U1^2 * U2), ( - 4 * U1^5 + 4 * U1 * U2^4) * X7 + (U1^6 + 2 * U1^4 * U2^2 - 3 * U1^2 * U2^4), ( - 4 * U1^4 * U2 + 4 * U2^5) * X8 + (3 * U1^4 * U2^2 - 2 * U1^2 * U2^4 - U2^6), (2 * U1^6 * U2^2 - 2 * U1^4 * U2^4) * S + (4 * U1^6 - 4 * U1^2 * U2^4) ]
+------------------- CASE 5 -------------------
+Condition:
+  Green list: [ U1^2 - U2^2 ]
+  Red list: [ U1, U1^2 + U2^2, U2 ]
+ Basis: [ (2) * X1 + ( - U1), (2) * X2 + ( - U2), (2) * X3 + ( - U1), (2) * X4 + ( - U2), (2 * U2^3) * X5 + ( - U1 * U2^3), ( - 2 * U2^2) * X6 + (U2^3), (4 * U1) * X7 + ( - 4 * U2) * X8, ( - 8 * U2^5) * S * X8 + (2 * U2^6) * S + ( - 8 * U2^4) ]
+------------------- CASE 6 -------------------
+Condition:
+  Green list: [ U1^2 + U2^2 ]
+  Red list: [ U1, U2 ]
+ Basis: [ ( - U2^3) ]
+Warning: Test 7
+------------------- CASE 1 -------------------
+Condition:
+  Green list: [  ]
+  Red list: [ A * C^2 + B * C^2, A^2 + B ]
+ Basis: [ (A^2 + B) * X^2 * Y + (A^3 * B + A^3 * C) * X * Y, (A * C^2 + B * C^2) * X^2 + (B) * Y + (4) ]
+------------------- CASE 2 -------------------
+Condition:
+  Green list: [ A^2 + B ]
+  Red list: [ A * C^2 + B * C^2, A^3 * B + A^3 * C ]
+ Basis: [ (A^3 * B + A^3 * C) * X * Y, (A * C^2 + B * C^2) * X^2 + (B) * Y + (4) ]
+------------------- CASE 3 -------------------
+Condition:
+  Green list: [ A^2 - C, B + C ]
+  Red list: [ A * C^2 + B * C^2 ]
+ Basis: [ (A * C^2 + B * C^2) * X^2 + (B) * Y + (4) ]
+------------------- CASE 4 -------------------
+Condition:
+  Green list: [ A * C^2 + B * C^2 ]
+  Red list: [ B, A^2 + B ]
+ Basis: [ (A^2 + B) * X^2 * Y + (A^3 * B + A^3 * C) * X * Y, (B) * Y + (4) ]
+------------------- CASE 5 -------------------
+Condition:
+  Green list: [ A * C^2 - C^2, A^2 + B, B * C^2 + C^2 ]
+  Red list: [ B, A^3 * B + A^3 * C ]
+ Basis: [ (A^3 * B + A^3 * C) * X * Y, (B) * Y + (4) ]
+------------------- CASE 6 -------------------
+Condition:
+  Green list: [ B + 1, C - 1, A - 1 ]
+  Red list: [ B ]
+ Basis: [ (B) * Y + (4) ]
+------------------- CASE 7 -------------------
+Condition:
+  Green list: [ B, C^2 ]
+  Red list: [ 4, A^2 + B ]
+ Basis: [ (A^2 + B) * X^2 * Y + (A^3 * B + A^3 * C) * X * Y, (4) ]
+------------------- CASE 8 -------------------
+Condition:
+  Green list: [ A^2, A * C^2, B ]
+  Red list: [ 4 ]
+ Basis: [ (4) ]
+Warning: Test 8
+------------------- CASE 1 -------------------
+Condition:
+  Green list: [  ]
+  Red list: [ A^2 ]
+ Basis: [ (A^2) * X + (5 * A) ]
+------------------- CASE 2 -------------------
+Condition:
+  Green list: [ A^2 ]
+  Red list: [  ]
+ Basis: [ ]
+Warning: Test 9 - the discriminant of a quadratic polynomial
+------------------- CASE 1 -------------------
+Condition:
+  Green list: [  ]
+  Red list: [ A, 4 * A * C - B^2 ]
+ Basis: [ (4 * A * C - B^2) ]
+------------------- CASE 2 -------------------
+Condition:
+  Green list: [ 4 * A * C - B^2 ]
+  Red list: [ A ]
+ Basis: [ (2 * A) * X + (B) ]
+Warning: Test 10 - the discriminant of a cubic polynomial
+------------------- CASE 1 -------------------
+Condition:
+  Green list: [  ]
+  Red list: [ P, 4 * P^3 + 27 * Q^2 ]
+ Basis: [ ( - 4 * P^3 - 27 * Q^2) ]
+------------------- CASE 2 -------------------
+Condition:
+  Green list: [ 4 * P^3 + 27 * Q^2 ]
+  Red list: [ P ]
+ Basis: [ (2 * P) * X + (3 * Q) ]
+------------------- CASE 3 -------------------
+Condition:
+  Green list: [ P ]
+  Red list: [ Q ]
+ Basis: [ (3 * Q) ]
+------------------- CASE 4 -------------------
+Condition:
+  Green list: [ P, Q ]
+  Red list: [  ]
+ Basis: [ (3) * X^2 ]
+Warning: Test 11 - the discriminant of a quartic polynomial
+------------------- CASE 1 -------------------
+Condition:
+  Green list: [  ]
+  Red list: [ 16 * P^4 * R - 4 * P^3 * Q^2 - 128 * P^2 * R^2 + 144 * P * Q^2 * R - 27 * Q^4 + 256 * R^3, P, 2 * P^3 - 8 * P * R + 9 * Q^2 ]
+ Basis: [ (16 * P^6 * R - 4 * P^5 * Q^2 - 128 * P^4 * R^2 + 144 * P^3 * Q^2 * R - 27 * P^2 * Q^4 + 256 * P^2 * R^3) ]
+------------------- CASE 2 -------------------
+Condition:
+  Green list: [ 16 * P^4 * R - 4 * P^3 * Q^2 - 128 * P^2 * R^2 + 144 * P * Q^2 * R - 27 * Q^4 + 256 * R^3 ]
+  Red list: [ P, 2 * P^3 - 8 * P * R + 9 * Q^2 ]
+ Basis: [ ( - 2 * P^3 + 8 * P * R - 9 * Q^2) * X + ( - P^2 * Q - 12 * Q * R) ]
+------------------- CASE 3 -------------------
+Condition:
+  Green list: [ 2 * P^3 - 8 * P * R + 9 * Q^2 ]
+  Red list: [ P, P^2 * Q + 12 * Q * R ]
+ Basis: [ ( - P^2 * Q - 12 * Q * R) ]
+------------------- CASE 4 -------------------
+Condition:
+  Green list: [ 2 * P^3 - 8 * P * R + 9 * Q^2, P^2 * Q + 12 * Q * R, 32 * P * Q * R - 9 * Q^3, 3 * P * Q^3 + 128 * Q * R^2, 27 * Q^5 + 4096 * Q * R^3, 8 * P^2 * R - 3 * P * Q^2 - 32 * R^2 ]
+  Red list: [ P ]
+ Basis: [ (2 * P) * X^2 + (3 * Q) * X + (4 * R) ]
+------------------- CASE 5 -------------------
+Condition:
+  Green list: [ P ]
+  Red list: [ Q, 72 * P * Q^2 * R - 27 * Q^4 + 256 * R^3 ]
+ Basis: [ (27 * Q^4 - 256 * R^3) ]
+------------------- CASE 6 -------------------
+Condition:
+  Green list: [ P, 27 * Q^4 - 256 * R^3 ]
+  Red list: [ Q ]
+ Basis: [ (3 * Q) * X + (4 * R) ]
+------------------- CASE 7 -------------------
+Condition:
+  Green list: [ P, Q ]
+  Red list: [ R ]
+ Basis: [ (4 * R) ]
+------------------- CASE 8 -------------------
+Condition:
+  Green list: [ P, Q, R ]
+  Red list: [  ]
+ Basis: [ (4) * X^3 ]
Index: /trunk/samples/colored-poly-tests.output.1
===================================================================
--- /trunk/samples/colored-poly-tests.output.1	(revision 14)
+++ /trunk/samples/colored-poly-tests.output.1	(revision 14)
@@ -0,0 +1,376 @@
+Starts dribbling to colored-poly-tests.output (1995/4/3, 23:27:44).
+real time : 0.100 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (WARN "Test 1")
+Warning: Test 1
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM "[4*x^2-3*x*y,4*x+5*y]" '(X Y) 'NIL)
+Condition:
+  Green list: [  ]
+  Red list: [  ]
+ Basis: [ (4) * X + (5) * Y, ( - 10) * Y^2 ]
+real time : 0.067 secs
+run time  : 0.017 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 2 - Enneper")
+Warning: Test 2 - Enneper
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (SETF VAL1
+            (STRING-GROBNER-SYSTEM
+                "[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
+                '(U V X Y Z) 'NIL :SUPPRESS-VALUE T))
+Condition:
+  Green list: [  ]
+  Red list: [  ]
+ Basis: [ ( - 3) * U^2 + (3) * V^2 + (1) * Z, ( - 6) * U * V^2 + (1) * U * Z + ( - 9) * U + (3) * X, (2) * V^3 + (1) * V * Z + (3) * V + ( - 1) * Y, (9) * U * V * Y + ( - 2) * U * Z^2 + (18) * U * Z + ( - 9) * V^2 * X + ( - 6) * X * Z, ( - 9) * U * X + ( - 6) * V^2 * Z + (9) * V * Y + ( - 1) * Z^2 + (9) * Z, ( - 4) * U * V * Z + (3) * U * Y + ( - 3) * V * X, ( - 27) * U * Y^2 + (8) * U * Z^3 + ( - 72) * U * Z^2 + (36) * V^2 * X * Z + (27) * V * X * Y + (24) * X * Z^2, (18) * V^2 * Z^2 + (54) * V^2 * Z + ( - 54) * V * Y * Z + ( - 27) * X^2 + (27) * Y^2 + (1) * Z^3 + ( - 18) * Z^2 + (81) * Z, ( - 54) * V^2 * Y * Z + ( - 27) * V * X^2 + (27) * V * Y^2 + ( - 8) * V * Z^3 + ( - 72) * V * Z^2 + (9) * Y * Z^2 + (27) * Y * Z, (243) * V^2 * X^2 + ( - 243) * V^2 * Y^2 + ( - 1296) * V^2 * Z + ( - 108) * V * Y * Z^2 + (324) * V * Y * Z + (108) * X^2 * Z + (648) * X^2 + (135) * Y^2 * Z + ( - 648) * Y^2 + ( - 4) * Z^4 + (48) * Z^3 + (108) * Z^2 + ( - 1944) * Z, ( - 81) * V * X^2 * Z + ( - 243) * V * X^2 + ( - 405) * V * Y^2 * Z + (243) * V * Y^2 + ( - 24) * V * Z^4 + ( - 288) * V * Z^3 + ( - 648) * V * Z^2 + ( - 243) * X^2 * Y + (243) * Y^3 + (36) * Y * Z^3 + (972) * Y * Z, ( - 4374) * V * X^2 * Y + ( - 8748) * V * Y^3 * Z + (4374) * V * Y^3 + ( - 648) * V * Y * Z^4 + ( - 5184) * V * Y * Z^3 + ( - 17496) * V * Y * Z^2 + (729) * X^4 + ( - 5832) * X^2 * Y^2 + (189) * X^2 * Z^3 + (2430) * X^2 * Z^2 + ( - 2187) * X^2 * Z + (5103) * Y^4 + (945) * Y^2 * Z^3 + ( - 972) * Y^2 * Z^2 + (19683) * Y^2 * Z + ( - 8) * Z^6 + (72) * Z^5 + (648) * Z^4 + ( - 5832) * Z^3, ( - 2187) * V * X^4 + ( - 69984) * V * X^2 + ( - 8748) * V * Y^4 * Z + (2187) * V * Y^4 + ( - 648) * V * Y^2 * Z^4 + ( - 3240) * V * Y^2 * Z^3 + (11664) * V * Y^2 * Z^2 + ( - 139968) * V * Y^2 * Z + (69984) * V * Y^2 + (192) * V * Z^6 + (3456) * V * Z^5 + (15552) * V * Z^4 + ( - 20736) * V * Z^3 + ( - 186624) * V * Z^2 + (729) * X^4 * Y + ( - 5832) * X^2 * Y^3 + (189) * X^2 * Y * Z^3 + (7047) * X^2 * Y * Z^2 + (23328) * X^2 * Y * Z + ( - 69984) * X^2 * Y + (5103) * Y^5 + (945) * Y^3 * Z^3 + ( - 1215) * Y^3 * Z^2 + ( - 5832) * Y^3 * Z + (69984) * Y^3 + ( - 8) * Y * Z^6 + ( - 288) * Y * Z^5 + ( - 216) * Y * Z^4 + ( - 5184) * Y * Z^3 + ( - 93312) * Y * Z^2 + (279936) * Y * Z, (43740) * V * Y^3 * Z^2 + (3240) * V * Y * Z^5 + (29160) * V * Y * Z^4 + (87480) * V * Y * Z^3 + (87480) * V * Y * Z^2 + ( - 3645) * X^4 * Z + ( - 10935) * X^4 + (29160) * X^2 * Y^2 * Z + (21870) * X^2 * Y^2 + ( - 945) * X^2 * Z^4 + ( - 14985) * X^2 * Z^3 + ( - 25515) * X^2 * Z^2 + (32805) * X^2 * Z + ( - 25515) * Y^4 * Z + ( - 10935) * Y^4 + ( - 4725) * Y^2 * Z^4 + (405) * Y^2 * Z^3 + ( - 83835) * Y^2 * Z^2 + ( - 32805) * Y^2 * Z + (40) * Z^7 + ( - 240) * Z^6 + ( - 4320) * Z^5 + (19440) * Z^4 + (87480) * Z^3, (98415) * X^6 + ( - 295245) * X^4 * Y^2 + (54675) * X^4 * Z^3 + (590490) * X^4 * Z^2 + ( - 295245) * X^4 * Z + (295245) * X^2 * Y^4 + (284310) * X^2 * Y^2 * Z^3 + (590490) * X^2 * Y^2 * Z + (6480) * X^2 * Z^6 + (174960) * X^2 * Z^5 + (874800) * X^2 * Z^4 + ( - 1574640) * X^2 * Z^3 + ( - 98415) * Y^6 + (54675) * Y^4 * Z^3 + ( - 590490) * Y^4 * Z^2 + ( - 295245) * Y^4 * Z + ( - 6480) * Y^2 * Z^6 + (174960) * Y^2 * Z^5 + ( - 874800) * Y^2 * Z^4 + ( - 1574640) * Y^2 * Z^3 + ( - 320) * Z^9 + (51840) * Z^7 + ( - 2099520) * Z^5 ]
+real time : 20.483 secs
+run time  : 10.100 secs
+VALUES--> (NIL)
+
+EVAL> (SETF VAL1
+            (GROBNER (MAPCAR #'COLORED-POLY-TO-POLY (CADAR VAL1))))
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (SETF VAL2
+            (STRING-GROBNER
+                "[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
+                '(U V X Y Z) :SUPPRESS-VALUE T))
+Args:[ U^3 - 3 * U * V^2 - 3 * U + X,  - 3 * U^2 * V + V^3 - 3 * V + Y,  - 3 * U^2 + 3 * V^2 + Z ]
+[ 2 * V^3 + V * Z + 3 * V - Y, 6 * U * V^2 - U * Z + 9 * U - 3 * X, 3 * U^2 - 3 * V^2 - Z, 4 * U * V * Z - 3 * U * Y + 3 * V * X, 9 * U * X + 6 * V^2 * Z - 9 * V * Y + Z^2 - 9 * Z, 9 * U * V * Y - 2 * U * Z^2 + 18 * U * Z - 9 * V^2 * X - 6 * X * Z, 18 * V^2 * Z^2 + 54 * V^2 * Z - 54 * V * Y * Z - 27 * X^2 + 27 * Y^2 + Z^3 - 18 * Z^2 + 81 * Z, 54 * V^2 * Y * Z + 27 * V * X^2 - 27 * V * Y^2 + 8 * V * Z^3 + 72 * V * Z^2 - 9 * Y * Z^2 - 27 * Y * Z, 27 * U * Y^2 - 8 * U * Z^3 + 72 * U * Z^2 - 36 * V^2 * X * Z - 27 * V * X * Y - 24 * X * Z^2, 243 * V^2 * X^2 - 243 * V^2 * Y^2 - 1296 * V^2 * Z - 108 * V * Y * Z^2 + 324 * V * Y * Z + 108 * X^2 * Z + 648 * X^2 + 135 * Y^2 * Z - 648 * Y^2 - 4 * Z^4 + 48 * Z^3 + 108 * Z^2 - 1944 * Z, 27 * V * X^2 * Z + 81 * V * X^2 + 135 * V * Y^2 * Z - 81 * V * Y^2 + 8 * V * Z^4 + 96 * V * Z^3 + 216 * V * Z^2 + 81 * X^2 * Y - 81 * Y^3 - 12 * Y * Z^3 - 324 * Y * Z, 4374 * V * X^2 * Y + 8748 * V * Y^3 * Z - 4374 * V * Y^3 + 648 * V * Y * Z^4 + 5184 * V * Y * Z^3 + 17496 * V * Y * Z^2 - 729 * X^4 + 5832 * X^2 * Y^2 - 189 * X^2 * Z^3 - 2430 * X^2 * Z^2 + 2187 * X^2 * Z - 5103 * Y^4 - 945 * Y^2 * Z^3 + 972 * Y^2 * Z^2 - 19683 * Y^2 * Z + 8 * Z^6 - 72 * Z^5 - 648 * Z^4 + 5832 * Z^3, 2187 * V * X^4 + 69984 * V * X^2 + 8748 * V * Y^4 * Z - 2187 * V * Y^4 + 648 * V * Y^2 * Z^4 + 3240 * V * Y^2 * Z^3 - 11664 * V * Y^2 * Z^2 + 139968 * V * Y^2 * Z - 69984 * V * Y^2 - 192 * V * Z^6 - 3456 * V * Z^5 - 15552 * V * Z^4 + 20736 * V * Z^3 + 186624 * V * Z^2 - 729 * X^4 * Y + 5832 * X^2 * Y^3 - 189 * X^2 * Y * Z^3 - 7047 * X^2 * Y * Z^2 - 23328 * X^2 * Y * Z + 69984 * X^2 * Y - 5103 * Y^5 - 945 * Y^3 * Z^3 + 1215 * Y^3 * Z^2 + 5832 * Y^3 * Z - 69984 * Y^3 + 8 * Y * Z^6 + 288 * Y * Z^5 + 216 * Y * Z^4 + 5184 * Y * Z^3 + 93312 * Y * Z^2 - 279936 * Y * Z, 8748 * V * Y^3 * Z^2 + 648 * V * Y * Z^5 + 5832 * V * Y * Z^4 + 17496 * V * Y * Z^3 + 17496 * V * Y * Z^2 - 729 * X^4 * Z - 2187 * X^4 + 5832 * X^2 * Y^2 * Z + 4374 * X^2 * Y^2 - 189 * X^2 * Z^4 - 2997 * X^2 * Z^3 - 5103 * X^2 * Z^2 + 6561 * X^2 * Z - 5103 * Y^4 * Z - 2187 * Y^4 - 945 * Y^2 * Z^4 + 81 * Y^2 * Z^3 - 16767 * Y^2 * Z^2 - 6561 * Y^2 * Z + 8 * Z^7 - 48 * Z^6 - 864 * Z^5 + 3888 * Z^4 + 17496 * Z^3, 19683 * X^6 - 59049 * X^4 * Y^2 + 10935 * X^4 * Z^3 + 118098 * X^4 * Z^2 - 59049 * X^4 * Z + 59049 * X^2 * Y^4 + 56862 * X^2 * Y^2 * Z^3 + 118098 * X^2 * Y^2 * Z + 1296 * X^2 * Z^6 + 34992 * X^2 * Z^5 + 174960 * X^2 * Z^4 - 314928 * X^2 * Z^3 - 19683 * Y^6 + 10935 * Y^4 * Z^3 - 118098 * Y^4 * Z^2 - 59049 * Y^4 * Z - 1296 * Y^2 * Z^6 + 34992 * Y^2 * Z^5 - 174960 * Y^2 * Z^4 - 314928 * Y^2 * Z^3 - 64 * Z^9 + 10368 * Z^7 - 419904 * Z^5 ]
+real time : 11.233 secs
+run time  : 4.367 secs
+VALUES--> (NIL)
+
+EVAL> (GROBNER-EQUAL VAL1 VAL2)
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (T)
+
+EVAL> (WARN " Test 3 - staple")
+Warning:  Test 3 - staple
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM "[x+y,x+u*y]" '(X Y) '(U))
+Condition:
+  Green list: [  ]
+  Red list: [ U - 1 ]
+ Basis: [ ( - U + 1) * Y, (U - 1) * X ]
+Condition:
+  Green list: [ U - 1 ]
+  Red list: [  ]
+ Basis: [ (1) * X + (1) * Y ]
+real time : 0.267 secs
+run time  : 0.050 secs
+VALUES--> NIL
+
+EVAL> (WARN " Test 4 - staple")
+Warning:  Test 4 - staple
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM "[x+y,u*x+y]" '(X Y) '(U))
+Condition:
+  Green list: [ U ]
+  Red list: [  ]
+ Basis: [ (1) * Y, (1) * X ]
+Condition:
+  Green list: [  ]
+  Red list: [ U, U - 1 ]
+ Basis: [ (U - 1) * Y, (U^2 - U) * X ]
+Condition:
+  Green list: [ U - 1 ]
+  Red list: [  ]
+ Basis: [ (1) * X + (1) * Y ]
+real time : 0.150 secs
+run time  : 0.067 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 5 - a small robot example")
+Warning: Test 5 - a small robot example
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM
+          "[a-l3*c1*c2+l3*s1*s2-l2*c1, b-l3*c1*s2-l3*c2*s1-l2*s1, c1^2+s1^2-1, c2^2+s2^2-1]"
+          '(C2 S2 C1 S1) '(A B L2 L3) :COVER '(("[]" "[l2,l3]")))
+Condition:
+  Green list: [  ]
+  Red list: [ L3, A^2 + B^2, L2, A ]
+ Basis: [ ( - 2 * A * L2) * C1 + ( - 2 * B * L2) * S1 + (A^2 + B^2 + L2^2 - L3^2), (4 * A^2 * L2^2 + 4 * B^2 * L2^2) * S1^2 + ( - 4 * A^2 * B * L2 - 4 * B^3 * L2 - 4 * B * L2^3 + 4 * B * L2 * L3^2) * S1 + (A^4 + 2 * A^2 * B^2 - 2 * A^2 * L2^2 - 2 * A^2 * L3^2 + B^4 + 2 * B^2 * L2^2 - 2 * B^2 * L3^2 + L2^4 - 2 * L2^2 * L3^2 + L3^4), ( - 2 * A * L2 * L3) * S2 + ( - 2 * A^2 * L2 - 2 * B^2 * L2) * S1 + (A^2 * B + B^3 + B * L2^2 - B * L3^2), ( - 2 * L2 * L3) * C2 + (A^2 + B^2 - L2^2 - L3^2) ]
+Condition:
+  Green list: [ A^2 + B^2 ]
+  Red list: [ L3, B * L2^2 - B * L3^2, L2, A, 4 * B^2 * L2^4 + 4 * B^2 * L2^2 * L3^2 + L2^6 - L2^4 * L3^2 - L2^2 * L3^4 + L3^6 ]
+ Basis: [ ( - 4 * B^2 * L2^4 - 4 * B^2 * L2^2 * L3^2 - L2^6 + L2^4 * L3^2 + L2^2 * L3^4 - L3^6) ]
+Condition:
+  Green list: [ A^2 + B^2, 4 * B^2 * L2^4 + 4 * B^2 * L2^2 * L3^2 + L2^6 - L2^4 * L3^2 - L2^2 * L3^4 + L3^6 ]
+  Red list: [ L3, B * L2^2 - B * L3^2, L2, A ]
+ Basis: [ ( - 4 * B * L2^3 + 4 * B * L2 * L3^2) * S1 + (4 * B^2 * L2^2 + L2^4 - 2 * L2^2 * L3^2 + L3^4), (4 * A * B * L2^3 * L3 - 4 * A * B * L2 * L3^3) * S2 + (12 * B^2 * L2^2 * L3^2 - 4 * B^2 * L3^4 + L2^6 - L2^4 * L3^2 - L2^2 * L3^4 + L3^6), ( - 2 * L2 * L3) * C2 + ( - L2^2 - L3^2), (4 * A * L2^3 - 4 * A * L2 * L3^2) * C1 + (4 * B^2 * L2^2 - L2^4 + 2 * L2^2 * L3^2 - L3^4) ]
+Condition:
+  Green list: [ A^2 + B^2, L2^2 - L3^2 ]
+  Red list: [ B^2, L3, A, L2 ]
+ Basis: [ (4 * B^2 * L3^2) ]
+Condition:
+  Green list: [ A ]
+  Red list: [ L3, B, L2, B^4 - 2 * B^2 * L3^2 - L2^4 + L3^4 ]
+ Basis: [ (B^4 - 2 * B^2 * L3^2 - L2^4 + L3^4) ]
+Condition:
+  Green list: [ A, B^4 - 2 * B^2 * L3^2 - L2^4 + L3^4 ]
+  Red list: [ L3, B, L2 ]
+ Basis: [ ( - 2 * B * L2) * S1 + (B^2 + L2^2 - L3^2), (4 * B^2 * L2^2) * C1^2 + ( - 2 * B^2 * L2^2 + 2 * L2^4 - 2 * L2^2 * L3^2), (2 * B * L2 * L3) * S2 + ( - 2 * B^2 * L2) * C1, ( - 2 * L2 * L3) * C2 + (B^2 - L2^2 - L3^2) ]
+Condition:
+  Green list: [ A, B ]
+  Red list: [ L3, L2, L2^2 - L3^2 ]
+ Basis: [ (L2^2 - L3^2) ]
+Condition:
+  Green list: [ A, B, L2^2 - L3^2 ]
+  Red list: [ L3, L2 ]
+ Basis: [ (1) * C1^2 + (1) * S1^2 + ( - 1), (L3) * S2, (L3) * C2 + (L2) ]
+real time : 27.650 secs
+run time  : 14.567 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 6 - Circle of Apollonius")
+Warning: Test 6 - Circle of Apollonius
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM
+          "[2*x1-u1,2*x2-u2,2*x3-u1,2*x4-u2,x5*u1-x6*u2,x5*u2+x6*u1-u1*u2,x1^2-2*x1*x7+x7^2+x8^2-x7^2-x8^2+2*x8*x2-x2^2,x1^2-2*x1*x7+x7^2+x6^2-2*x6*x8+x8^2-x3^2+2*x3*x7-x7^2-x4^2+2*x4*x8-x8^2,1-s*x5^2+2*s*x5*x7-s*x7^2-s*x6^2+2*s*x6*x8-s*x8^2+s*x1^2-2*s*x1*x7+s*x7^2+s*x8^2]"
+          '(S X1 X2 X3 X4 X5 X6 X7 X8) '(U1 U2))
+Condition:
+  Green list: [ U2, U1 ]
+  Red list: [  ]
+ Basis: [ (2) * X1, (2) * X2, (2) * X3, (2) * X4, ( - 4) * X6^2 + (8) * X6 * X8, (4) * S * X5^2 + ( - 8) * S * X5 * X7 + ( - 4) ]
+Condition:
+  Green list: [ U2 ]
+  Red list: [ U1 ]
+ Basis: [ ( - 4 * U1^3) ]
+Condition:
+  Green list: [ U1 ]
+  Red list: [ U2 ]
+ Basis: [ (4 * U2^2) ]
+Condition:
+  Green list: [  ]
+  Red list: [ U1, U1^2 - U2^2, U2, U1^2 + U2^2 ]
+ Basis: [ ( - U1^2 - U2^2) * X6 + (U1^2 * U2), ( - 4 * U1^4 * U2 + 4 * U2^5) * X8 + (3 * U1^4 * U2^2 - 2 * U1^2 * U2^4 - U2^6), (2 * U1^6 * U2^2 - 2 * U1^4 * U2^4) * S + (4 * U1^6 - 4 * U1^2 * U2^4), (2) * X1 + ( - U1), (2) * X2 + ( - U2), (2) * X3 + ( - U1), (2) * X4 + ( - U2), (U1^2 * U2 + U2^3) * X5 + ( - U1 * U2^3), ( - 4 * U1^5 + 4 * U1 * U2^4) * X7 + (U1^6 + 2 * U1^4 * U2^2 - 3 * U1^2 * U2^4) ]
+Condition:
+  Green list: [ U1^2 + U2^2 ]
+  Red list: [ U1, U2 ]
+ Basis: [ ( - U2^3) ]
+Condition:
+  Green list: [ U1^2 - U2^2 ]
+  Red list: [ U1, U2 ]
+ Basis: [ (4 * U1) * X7 + ( - 4 * U2) * X8, ( - 4 * U2^3) * S * X8 + (U2^4) * S + ( - 4 * U2^2), ( - 2 * U2^2) * X6 + (U2^3), (2) * X1 + ( - U1), (2) * X2 + ( - U2), (2) * X3 + ( - U1), (2) * X4 + ( - U2), (2 * U2^3) * X5 + ( - U1 * U2^3) ]
+real time : 9.217 secs
+run time  : 3.917 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 7")
+Warning: Test 7
+real time : 0.017 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (SETF FL
+            (PARSE-STRING-TO-SORTED-ALIST
+                "[a^2*x^2*y+b*x^2*y+a^3*b*x*y+a^3*c*x*y,c^2*a*x^2+c^2*b*x^2+b*y+4]"
+                '(X Y A B C)))
+real time : 0.117 secs
+run time  : 0.050 secs
+VALUES--> (((((2 1 2 0 0) . 1) ((2 1 0 1 0) . 1) ((1 1 3 1 0) . 1)
+             ((1 1 3 0 1) . 1))
+            (((2 0 1 0 2) . 1) ((2 0 0 1 2) . 1) ((0 1 0 1 0) . 1)
+             ((0 0 0 0 0) . 4))))
+
+EVAL> (SETF CFL (MAKE-COLORED-POLY-LIST FL 2))
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (((((2 1) (((2 0 0) . 1) ((0 1 0) . 1)) . :WHITE)
+             ((1 1) (((3 1 0) . 1) ((3 0 1) . 1)) . :WHITE))
+            (((2 0) (((1 0 2) . 1) ((0 1 2) . 1)) . :WHITE)
+             ((0 1) (((0 1 0) . 1)) . :WHITE)
+             ((0 0) (((0 0 0) . 4)) . :WHITE))))
+
+EVAL> (COND-SYSTEM-PRINT (DETERMINE CFL) '(X Y) '(A B C))
+Condition:
+  Green list: [  ]
+  Red list: [ A * C^2 + B * C^2, A^2 + B ]
+ Basis: [ (A^2 + B) * X^2 * Y + (A^3 * B + A^3 * C) * X * Y, (A * C^2 + B * C^2) * X^2 + (B) * Y + (4) ]
+Condition:
+  Green list: [ A^2 + B ]
+  Red list: [ A * C^2 + B * C^2, A^3 * B + A^3 * C ]
+ Basis: [ (A^3 * B + A^3 * C) * X * Y, (A * C^2 + B * C^2) * X^2 + (B) * Y + (4) ]
+Condition:
+  Green list: [ A^2 - C, B + C ]
+  Red list: [ A * C^2 + B * C^2 ]
+ Basis: [ (A * C^2 + B * C^2) * X^2 + (B) * Y + (4) ]
+Condition:
+  Green list: [ A * C^2 + B * C^2 ]
+  Red list: [ B, A^2 + B ]
+ Basis: [ (A^2 + B) * X^2 * Y + (A^3 * B + A^3 * C) * X * Y, (B) * Y + (4) ]
+Condition:
+  Green list: [ A * C^2 - C^2, A^2 + B, B * C^2 + C^2 ]
+  Red list: [ B, A^3 * B + A^3 * C ]
+ Basis: [ (A^3 * B + A^3 * C) * X * Y, (B) * Y + (4) ]
+Condition:
+  Green list: [ B + 1, A - 1, C - 1 ]
+  Red list: [ B ]
+ Basis: [ (B) * Y + (4) ]
+Condition:
+  Green list: [ B, C^2 ]
+  Red list: [ 4, A^2 + B ]
+ Basis: [ (A^2 + B) * X^2 * Y + (A^3 * B + A^3 * C) * X * Y, (4) ]
+Condition:
+  Green list: [ A^2, A * C^2, B ]
+  Red list: [ 4 ]
+ Basis: [ (4) ]
+real time : 2.967 secs
+run time  : 0.900 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 8")
+Warning: Test 8
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (SETF FL (PARSE-STRING-TO-SORTED-ALIST "[a^2*x+5*a]" '(X A)))
+real time : 0.017 secs
+run time  : 0.000 secs
+VALUES--> (((((1 2) . 1) ((0 1) . 5))))
+
+EVAL> (SETF CFL (MAKE-COLORED-POLY-LIST FL 1))
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (((((1) (((2) . 1)) . :WHITE) ((0) (((1) . 5)) . :WHITE))))
+
+EVAL> (COND-SYSTEM-PRINT (DETERMINE CFL) '(X) '(A))
+Condition:
+  Green list: [  ]
+  Red list: [ A^2 ]
+ Basis: [ (A^2) * X + (5 * A) ]
+Condition:
+  Green list: [ A^2 ]
+  Red list: [  ]
+ Basis: [ ]
+real time : 0.100 secs
+run time  : 0.017 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 9 - the discriminant of a quadratic polynomial")
+Warning: Test 9 - the discriminant of a quadratic polynomial
+real time : 0.017 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM "[a*x^2+b*x+c,2*a*x+b]" '(X) '(A B C)
+          :COVER (LIST (LIST "[]" "[a]")))
+Condition:
+  Green list: [  ]
+  Red list: [ A, 4 * A * C - B^2 ]
+ Basis: [ (4 * A * C - B^2) ]
+Condition:
+  Green list: [ 4 * A * C - B^2 ]
+  Red list: [ A ]
+ Basis: [ (2 * A) * X + (B) ]
+real time : 0.583 secs
+run time  : 0.083 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 10 - the discriminant of a cubic polynomial")
+Warning: Test 10 - the discriminant of a cubic polynomial
+real time : 0.017 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM "[x^3+p*x+q,3*x^2+p]" '(X) '(P Q) :COVER
+          (LIST (LIST "[]" "[]")))
+Condition:
+  Green list: [  ]
+  Red list: [ P, 4 * P^3 + 27 * Q^2 ]
+ Basis: [ ( - 4 * P^3 - 27 * Q^2) ]
+Condition:
+  Green list: [ 4 * P^3 + 27 * Q^2 ]
+  Red list: [ P ]
+ Basis: [ (2 * P) * X + (3 * Q) ]
+Condition:
+  Green list: [ P ]
+  Red list: [ Q ]
+ Basis: [ (3 * Q) ]
+Condition:
+  Green list: [ P, Q ]
+  Red list: [  ]
+ Basis: [ (3) * X^2 ]
+real time : 0.450 secs
+run time  : 0.117 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 11 - the discriminant of a quartic polynomial")
+Warning: Test 11 - the discriminant of a quartic polynomial
+real time : 0.000 secs
+run time  : 0.017 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM "[x^4+p*x^2+q*x+r,4*x^3+2*p*x+q]" '(X)
+          '(P Q R) :COVER (LIST (LIST "[]" "[]")))
+Condition:
+  Green list: [  ]
+  Red list: [ 16 * P^4 * R^2 - 4 * P^3 * Q^2 * R - 128 * P^2 * R^3 + 144 * P * Q^2 * R^2 - 27 * Q^4 * R + 256 * R^4, P, P^2 * Q + 12 * Q * R ]
+ Basis: [ (64 * P^5 * R^2 - 16 * P^4 * Q^2 * R - 512 * P^3 * R^3 + 576 * P^2 * Q^2 * R^2 - 108 * P * Q^4 * R + 1024 * P * R^4) ]
+Condition:
+  Green list: [ R ]
+  Red list: [ 4 * P^3 + 27 * Q^2, P, Q ]
+ Basis: [ ( - 4 * P^5 * Q^2 - 27 * P^2 * Q^4) ]
+Condition:
+  Green list: [ 16 * P^4 * R - 4 * P^3 * Q^2 - 128 * P^2 * R^2 + 144 * P * Q^2 * R - 27 * Q^4 + 256 * R^3 ]
+  Red list: [ P, P^2 * Q + 12 * Q * R ]
+ Basis: [ (2 * P^2 * Q + 24 * Q * R) * X + ( - 8 * P^2 * R + 3 * P * Q^2 + 32 * R^2) ]
+Condition:
+  Green list: [ P^2 * Q + 12 * Q * R ]
+  Red list: [ P, 8 * P^2 * R - 3 * P * Q^2 - 32 * R^2 ]
+ Basis: [ ( - 8 * P^2 * R + 3 * P * Q^2 + 32 * R^2) ]
+Condition:
+  Green list: [ Q, R ]
+  Red list: [ P ]
+ Basis: [ ( - 2 * P^3) * X ]
+Condition:
+  Green list: [ P^2 * Q + 12 * Q * R, 8 * P^2 * R - 3 * P * Q^2 - 32 * R^2, 3 * P * Q^3 + 128 * Q * R^2, 32 * P * Q * R - 9 * Q^3, 27 * Q^5 + 4096 * Q * R^3, 2 * P^3 - 8 * P * R + 9 * Q^2 ]
+  Red list: [ P ]
+ Basis: [ (2 * P) * X^2 + (3 * Q) * X + (4 * R) ]
+Condition:
+  Green list: [ P ]
+  Red list: [ R, Q ]
+ Basis: [ (Q^2 * R) ]
+Condition:
+  Green list: [ P, R ]
+  Red list: [ Q ]
+ Basis: [ (54 * Q^4) ]
+Condition:
+  Green list: [ P, Q ]
+  Red list: [ R ]
+ Basis: [ (4 * R) ]
+Condition:
+  Green list: [ P, Q, R ]
+  Red list: [  ]
+ Basis: [ (4) * X^3 ]
+real time : 10.733 secs
+run time  : 5.367 secs
+VALUES--> NIL
+
+EVAL> (DRIBBLE)
Index: /trunk/samples/colored-poly-tests.output.2
===================================================================
--- /trunk/samples/colored-poly-tests.output.2	(revision 14)
+++ /trunk/samples/colored-poly-tests.output.2	(revision 14)
@@ -0,0 +1,376 @@
+Starts dribbling to colored-poly-tests.output (1995/4/4, 1:36:51).
+real time : 0.033 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (WARN "Test 1")
+Warning: Test 1
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM "[4*x^2-3*x*y,4*x+5*y]" '(X Y) 'NIL)
+Condition:
+  Green list: [  ]
+  Red list: [  ]
+ Basis: [ (4) * X + (5) * Y, ( - 10) * Y^2 ]
+real time : 0.067 secs
+run time  : 0.033 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 2 - Enneper")
+Warning: Test 2 - Enneper
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (SETF VAL1
+            (STRING-GROBNER-SYSTEM
+                "[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
+                '(U V X Y Z) 'NIL :SUPPRESS-VALUE T))
+Condition:
+  Green list: [  ]
+  Red list: [  ]
+ Basis: [ ( - 3) * U^2 + (3) * V^2 + (1) * Z, ( - 6) * U * V^2 + (1) * U * Z + ( - 9) * U + (3) * X, (2) * V^3 + (1) * V * Z + (3) * V + ( - 1) * Y, (9) * U * V * Y + ( - 2) * U * Z^2 + (18) * U * Z + ( - 9) * V^2 * X + ( - 6) * X * Z, ( - 9) * U * X + ( - 6) * V^2 * Z + (9) * V * Y + ( - 1) * Z^2 + (9) * Z, ( - 4) * U * V * Z + (3) * U * Y + ( - 3) * V * X, ( - 27) * U * Y^2 + (8) * U * Z^3 + ( - 72) * U * Z^2 + (36) * V^2 * X * Z + (27) * V * X * Y + (24) * X * Z^2, (18) * V^2 * Z^2 + (54) * V^2 * Z + ( - 54) * V * Y * Z + ( - 27) * X^2 + (27) * Y^2 + (1) * Z^3 + ( - 18) * Z^2 + (81) * Z, ( - 54) * V^2 * Y * Z + ( - 27) * V * X^2 + (27) * V * Y^2 + ( - 8) * V * Z^3 + ( - 72) * V * Z^2 + (9) * Y * Z^2 + (27) * Y * Z, (243) * V^2 * X^2 + ( - 243) * V^2 * Y^2 + ( - 1296) * V^2 * Z + ( - 108) * V * Y * Z^2 + (324) * V * Y * Z + (108) * X^2 * Z + (648) * X^2 + (135) * Y^2 * Z + ( - 648) * Y^2 + ( - 4) * Z^4 + (48) * Z^3 + (108) * Z^2 + ( - 1944) * Z, ( - 81) * V * X^2 * Z + ( - 243) * V * X^2 + ( - 405) * V * Y^2 * Z + (243) * V * Y^2 + ( - 24) * V * Z^4 + ( - 288) * V * Z^3 + ( - 648) * V * Z^2 + ( - 243) * X^2 * Y + (243) * Y^3 + (36) * Y * Z^3 + (972) * Y * Z, ( - 4374) * V * X^2 * Y + ( - 8748) * V * Y^3 * Z + (4374) * V * Y^3 + ( - 648) * V * Y * Z^4 + ( - 5184) * V * Y * Z^3 + ( - 17496) * V * Y * Z^2 + (729) * X^4 + ( - 5832) * X^2 * Y^2 + (189) * X^2 * Z^3 + (2430) * X^2 * Z^2 + ( - 2187) * X^2 * Z + (5103) * Y^4 + (945) * Y^2 * Z^3 + ( - 972) * Y^2 * Z^2 + (19683) * Y^2 * Z + ( - 8) * Z^6 + (72) * Z^5 + (648) * Z^4 + ( - 5832) * Z^3, ( - 2187) * V * X^4 + ( - 69984) * V * X^2 + ( - 8748) * V * Y^4 * Z + (2187) * V * Y^4 + ( - 648) * V * Y^2 * Z^4 + ( - 3240) * V * Y^2 * Z^3 + (11664) * V * Y^2 * Z^2 + ( - 139968) * V * Y^2 * Z + (69984) * V * Y^2 + (192) * V * Z^6 + (3456) * V * Z^5 + (15552) * V * Z^4 + ( - 20736) * V * Z^3 + ( - 186624) * V * Z^2 + (729) * X^4 * Y + ( - 5832) * X^2 * Y^3 + (189) * X^2 * Y * Z^3 + (7047) * X^2 * Y * Z^2 + (23328) * X^2 * Y * Z + ( - 69984) * X^2 * Y + (5103) * Y^5 + (945) * Y^3 * Z^3 + ( - 1215) * Y^3 * Z^2 + ( - 5832) * Y^3 * Z + (69984) * Y^3 + ( - 8) * Y * Z^6 + ( - 288) * Y * Z^5 + ( - 216) * Y * Z^4 + ( - 5184) * Y * Z^3 + ( - 93312) * Y * Z^2 + (279936) * Y * Z, (43740) * V * Y^3 * Z^2 + (3240) * V * Y * Z^5 + (29160) * V * Y * Z^4 + (87480) * V * Y * Z^3 + (87480) * V * Y * Z^2 + ( - 3645) * X^4 * Z + ( - 10935) * X^4 + (29160) * X^2 * Y^2 * Z + (21870) * X^2 * Y^2 + ( - 945) * X^2 * Z^4 + ( - 14985) * X^2 * Z^3 + ( - 25515) * X^2 * Z^2 + (32805) * X^2 * Z + ( - 25515) * Y^4 * Z + ( - 10935) * Y^4 + ( - 4725) * Y^2 * Z^4 + (405) * Y^2 * Z^3 + ( - 83835) * Y^2 * Z^2 + ( - 32805) * Y^2 * Z + (40) * Z^7 + ( - 240) * Z^6 + ( - 4320) * Z^5 + (19440) * Z^4 + (87480) * Z^3, (98415) * X^6 + ( - 295245) * X^4 * Y^2 + (54675) * X^4 * Z^3 + (590490) * X^4 * Z^2 + ( - 295245) * X^4 * Z + (295245) * X^2 * Y^4 + (284310) * X^2 * Y^2 * Z^3 + (590490) * X^2 * Y^2 * Z + (6480) * X^2 * Z^6 + (174960) * X^2 * Z^5 + (874800) * X^2 * Z^4 + ( - 1574640) * X^2 * Z^3 + ( - 98415) * Y^6 + (54675) * Y^4 * Z^3 + ( - 590490) * Y^4 * Z^2 + ( - 295245) * Y^4 * Z + ( - 6480) * Y^2 * Z^6 + (174960) * Y^2 * Z^5 + ( - 874800) * Y^2 * Z^4 + ( - 1574640) * Y^2 * Z^3 + ( - 320) * Z^9 + (51840) * Z^7 + ( - 2099520) * Z^5 ]
+real time : 18.267 secs
+run time  : 10.200 secs
+VALUES--> (NIL)
+
+EVAL> (SETF VAL1
+            (GROBNER (MAPCAR #'COLORED-POLY-TO-POLY (CADAR VAL1))))
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (SETF VAL2
+            (STRING-GROBNER
+                "[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
+                '(U V X Y Z) :SUPPRESS-VALUE T))
+Args:[ U^3 - 3 * U * V^2 - 3 * U + X,  - 3 * U^2 * V + V^3 - 3 * V + Y,  - 3 * U^2 + 3 * V^2 + Z ]
+[ 54 * V^2 * Y * Z + 27 * V * X^2 - 27 * V * Y^2 + 8 * V * Z^3 + 72 * V * Z^2 - 9 * Y * Z^2 - 27 * Y * Z, 9 * U * X + 6 * V^2 * Z - 9 * V * Y + Z^2 - 9 * Z, 243 * V^2 * X^2 - 243 * V^2 * Y^2 - 1296 * V^2 * Z - 108 * V * Y * Z^2 + 324 * V * Y * Z + 108 * X^2 * Z + 648 * X^2 + 135 * Y^2 * Z - 648 * Y^2 - 4 * Z^4 + 48 * Z^3 + 108 * Z^2 - 1944 * Z, 2 * V^3 + V * Z + 3 * V - Y, 6 * U * V^2 - U * Z + 9 * U - 3 * X, 3 * U^2 - 3 * V^2 - Z, 4 * U * V * Z - 3 * U * Y + 3 * V * X, 9 * U * V * Y - 2 * U * Z^2 + 18 * U * Z - 9 * V^2 * X - 6 * X * Z, 27 * U * Y^2 - 8 * U * Z^3 + 72 * U * Z^2 - 36 * V^2 * X * Z - 27 * V * X * Y - 24 * X * Z^2, 18 * V^2 * Z^2 + 54 * V^2 * Z - 54 * V * Y * Z - 27 * X^2 + 27 * Y^2 + Z^3 - 18 * Z^2 + 81 * Z, 27 * V * X^2 * Z + 81 * V * X^2 + 135 * V * Y^2 * Z - 81 * V * Y^2 + 8 * V * Z^4 + 96 * V * Z^3 + 216 * V * Z^2 + 81 * X^2 * Y - 81 * Y^3 - 12 * Y * Z^3 - 324 * Y * Z, 4374 * V * X^2 * Y + 8748 * V * Y^3 * Z - 4374 * V * Y^3 + 648 * V * Y * Z^4 + 5184 * V * Y * Z^3 + 17496 * V * Y * Z^2 - 729 * X^4 + 5832 * X^2 * Y^2 - 189 * X^2 * Z^3 - 2430 * X^2 * Z^2 + 2187 * X^2 * Z - 5103 * Y^4 - 945 * Y^2 * Z^3 + 972 * Y^2 * Z^2 - 19683 * Y^2 * Z + 8 * Z^6 - 72 * Z^5 - 648 * Z^4 + 5832 * Z^3, 8748 * V * Y^3 * Z^2 + 648 * V * Y * Z^5 + 5832 * V * Y * Z^4 + 17496 * V * Y * Z^3 + 17496 * V * Y * Z^2 - 729 * X^4 * Z - 2187 * X^4 + 5832 * X^2 * Y^2 * Z + 4374 * X^2 * Y^2 - 189 * X^2 * Z^4 - 2997 * X^2 * Z^3 - 5103 * X^2 * Z^2 + 6561 * X^2 * Z - 5103 * Y^4 * Z - 2187 * Y^4 - 945 * Y^2 * Z^4 + 81 * Y^2 * Z^3 - 16767 * Y^2 * Z^2 - 6561 * Y^2 * Z + 8 * Z^7 - 48 * Z^6 - 864 * Z^5 + 3888 * Z^4 + 17496 * Z^3, 2187 * V * X^4 + 69984 * V * X^2 + 8748 * V * Y^4 * Z - 2187 * V * Y^4 + 648 * V * Y^2 * Z^4 + 3240 * V * Y^2 * Z^3 - 11664 * V * Y^2 * Z^2 + 139968 * V * Y^2 * Z - 69984 * V * Y^2 - 192 * V * Z^6 - 3456 * V * Z^5 - 15552 * V * Z^4 + 20736 * V * Z^3 + 186624 * V * Z^2 - 729 * X^4 * Y + 5832 * X^2 * Y^3 - 189 * X^2 * Y * Z^3 - 7047 * X^2 * Y * Z^2 - 23328 * X^2 * Y * Z + 69984 * X^2 * Y - 5103 * Y^5 - 945 * Y^3 * Z^3 + 1215 * Y^3 * Z^2 + 5832 * Y^3 * Z - 69984 * Y^3 + 8 * Y * Z^6 + 288 * Y * Z^5 + 216 * Y * Z^4 + 5184 * Y * Z^3 + 93312 * Y * Z^2 - 279936 * Y * Z, 19683 * X^6 - 59049 * X^4 * Y^2 + 10935 * X^4 * Z^3 + 118098 * X^4 * Z^2 - 59049 * X^4 * Z + 59049 * X^2 * Y^4 + 56862 * X^2 * Y^2 * Z^3 + 118098 * X^2 * Y^2 * Z + 1296 * X^2 * Z^6 + 34992 * X^2 * Z^5 + 174960 * X^2 * Z^4 - 314928 * X^2 * Z^3 - 19683 * Y^6 + 10935 * Y^4 * Z^3 - 118098 * Y^4 * Z^2 - 59049 * Y^4 * Z - 1296 * Y^2 * Z^6 + 34992 * Y^2 * Z^5 - 174960 * Y^2 * Z^4 - 314928 * Y^2 * Z^3 - 64 * Z^9 + 10368 * Z^7 - 419904 * Z^5 ]
+real time : 10.783 secs
+run time  : 5.500 secs
+VALUES--> (NIL)
+
+EVAL> (GROBNER-EQUAL VAL1 VAL2)
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (T)
+
+EVAL> (WARN " Test 3 - staple")
+Warning:  Test 3 - staple
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM "[x+y,x+u*y]" '(X Y) '(U))
+Condition:
+  Green list: [  ]
+  Red list: [ U - 1 ]
+ Basis: [ ( - U + 1) * Y, (U - 1) * X ]
+Condition:
+  Green list: [ U - 1 ]
+  Red list: [  ]
+ Basis: [ (1) * X + (1) * Y ]
+real time : 0.183 secs
+run time  : 0.067 secs
+VALUES--> NIL
+
+EVAL> (WARN " Test 4 - staple")
+Warning:  Test 4 - staple
+real time : 0.017 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM "[x+y,u*x+y]" '(X Y) '(U))
+Condition:
+  Green list: [ U ]
+  Red list: [  ]
+ Basis: [ (1) * Y, (1) * X ]
+Condition:
+  Green list: [  ]
+  Red list: [ U, U - 1 ]
+ Basis: [ (U - 1) * Y, (U^2 - U) * X ]
+Condition:
+  Green list: [ U - 1 ]
+  Red list: [  ]
+ Basis: [ (1) * X + (1) * Y ]
+real time : 0.200 secs
+run time  : 0.050 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 5 - a small robot example")
+Warning: Test 5 - a small robot example
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM
+          "[a-l3*c1*c2+l3*s1*s2-l2*c1, b-l3*c1*s2-l3*c2*s1-l2*s1, c1^2+s1^2-1, c2^2+s2^2-1]"
+          '(C2 S2 C1 S1) '(A B L2 L3) :COVER '(("[]" "[l2,l3]")))
+Condition:
+  Green list: [  ]
+  Red list: [ L3, A^2 + B^2, L2, A ]
+ Basis: [ ( - 2 * A * L2) * C1 + ( - 2 * B * L2) * S1 + (A^2 + B^2 + L2^2 - L3^2), (4 * A^2 * L2^2 + 4 * B^2 * L2^2) * S1^2 + ( - 4 * A^2 * B * L2 - 4 * B^3 * L2 - 4 * B * L2^3 + 4 * B * L2 * L3^2) * S1 + (A^4 + 2 * A^2 * B^2 - 2 * A^2 * L2^2 - 2 * A^2 * L3^2 + B^4 + 2 * B^2 * L2^2 - 2 * B^2 * L3^2 + L2^4 - 2 * L2^2 * L3^2 + L3^4), ( - 2 * A * L2 * L3) * S2 + ( - 2 * A^2 * L2 - 2 * B^2 * L2) * S1 + (A^2 * B + B^3 + B * L2^2 - B * L3^2), ( - 2 * L2 * L3) * C2 + (A^2 + B^2 - L2^2 - L3^2) ]
+Condition:
+  Green list: [ A^2 + B^2 ]
+  Red list: [ L3, B * L2^2 - B * L3^2, L2, A, 4 * B^2 * L2^4 + 4 * B^2 * L2^2 * L3^2 + L2^6 - L2^4 * L3^2 - L2^2 * L3^4 + L3^6 ]
+ Basis: [ ( - 4 * B^2 * L2^4 - 4 * B^2 * L2^2 * L3^2 - L2^6 + L2^4 * L3^2 + L2^2 * L3^4 - L3^6) ]
+Condition:
+  Green list: [ A^2 + B^2, 4 * B^2 * L2^4 + 4 * B^2 * L2^2 * L3^2 + L2^6 - L2^4 * L3^2 - L2^2 * L3^4 + L3^6 ]
+  Red list: [ L3, B * L2^2 - B * L3^2, L2, A ]
+ Basis: [ ( - 4 * B * L2^3 + 4 * B * L2 * L3^2) * S1 + (4 * B^2 * L2^2 + L2^4 - 2 * L2^2 * L3^2 + L3^4), (4 * A * B * L2^3 * L3 - 4 * A * B * L2 * L3^3) * S2 + (12 * B^2 * L2^2 * L3^2 - 4 * B^2 * L3^4 + L2^6 - L2^4 * L3^2 - L2^2 * L3^4 + L3^6), ( - 2 * L2 * L3) * C2 + ( - L2^2 - L3^2), (4 * A * L2^3 - 4 * A * L2 * L3^2) * C1 + (4 * B^2 * L2^2 - L2^4 + 2 * L2^2 * L3^2 - L3^4) ]
+Condition:
+  Green list: [ A^2 + B^2, L2^2 - L3^2 ]
+  Red list: [ B^2, L3, A, L2 ]
+ Basis: [ (4 * B^2 * L3^2) ]
+Condition:
+  Green list: [ A ]
+  Red list: [ L3, B, L2, B^4 - 2 * B^2 * L3^2 - L2^4 + L3^4 ]
+ Basis: [ (B^4 - 2 * B^2 * L3^2 - L2^4 + L3^4) ]
+Condition:
+  Green list: [ A, B^4 - 2 * B^2 * L3^2 - L2^4 + L3^4 ]
+  Red list: [ L3, B, L2 ]
+ Basis: [ ( - 2 * B * L2) * S1 + (B^2 + L2^2 - L3^2), (4 * B^2 * L2^2) * C1^2 + ( - 2 * B^2 * L2^2 + 2 * L2^4 - 2 * L2^2 * L3^2), (2 * B * L2 * L3) * S2 + ( - 2 * B^2 * L2) * C1, ( - 2 * L2 * L3) * C2 + (B^2 - L2^2 - L3^2) ]
+Condition:
+  Green list: [ A, B ]
+  Red list: [ L3, L2, L2^2 - L3^2 ]
+ Basis: [ (L2^2 - L3^2) ]
+Condition:
+  Green list: [ A, B, L2^2 - L3^2 ]
+  Red list: [ L3, L2 ]
+ Basis: [ (1) * C1^2 + (1) * S1^2 + ( - 1), (L3) * S2, (L3) * C2 + (L2) ]
+real time : 18.717 secs
+run time  : 10.633 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 6 - Circle of Apollonius")
+Warning: Test 6 - Circle of Apollonius
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM
+          "[2*x1-u1,2*x2-u2,2*x3-u1,2*x4-u2,x5*u1-x6*u2,x5*u2+x6*u1-u1*u2,x1^2-2*x1*x7+x7^2+x8^2-x7^2-x8^2+2*x8*x2-x2^2,x1^2-2*x1*x7+x7^2+x6^2-2*x6*x8+x8^2-x3^2+2*x3*x7-x7^2-x4^2+2*x4*x8-x8^2,1-s*x5^2+2*s*x5*x7-s*x7^2-s*x6^2+2*s*x6*x8-s*x8^2+s*x1^2-2*s*x1*x7+s*x7^2+s*x8^2]"
+          '(S X1 X2 X3 X4 X5 X6 X7 X8) '(U1 U2))
+Condition:
+  Green list: [ U2, U1 ]
+  Red list: [  ]
+ Basis: [ (2) * X1, (2) * X2, (2) * X3, (2) * X4, ( - 4) * X6^2 + (8) * X6 * X8, (4) * S * X5^2 + ( - 8) * S * X5 * X7 + ( - 4) ]
+Condition:
+  Green list: [ U2 ]
+  Red list: [ U1 ]
+ Basis: [ ( - 4 * U1^3) ]
+Condition:
+  Green list: [ U1 ]
+  Red list: [ U2 ]
+ Basis: [ (4 * U2^2) ]
+Condition:
+  Green list: [  ]
+  Red list: [ U1, U1^2 - U2^2, U2, U1^2 + U2^2 ]
+ Basis: [ ( - U1^2 - U2^2) * X6 + (U1^2 * U2), ( - 4 * U1^4 * U2 + 4 * U2^5) * X8 + (3 * U1^4 * U2^2 - 2 * U1^2 * U2^4 - U2^6), (2 * U1^6 * U2^2 - 2 * U1^4 * U2^4) * S + (4 * U1^6 - 4 * U1^2 * U2^4), (2) * X1 + ( - U1), (2) * X2 + ( - U2), (2) * X3 + ( - U1), (2) * X4 + ( - U2), (U1^2 * U2 + U2^3) * X5 + ( - U1 * U2^3), ( - 4 * U1^5 + 4 * U1 * U2^4) * X7 + (U1^6 + 2 * U1^4 * U2^2 - 3 * U1^2 * U2^4) ]
+Condition:
+  Green list: [ U1^2 + U2^2 ]
+  Red list: [ U1, U2 ]
+ Basis: [ ( - U2^3) ]
+Condition:
+  Green list: [ U1^2 - U2^2 ]
+  Red list: [ U1, U2 ]
+ Basis: [ (4 * U1) * X7 + ( - 4 * U2) * X8, ( - 4 * U2^3) * S * X8 + (U2^4) * S + ( - 4 * U2^2), ( - 2 * U2^2) * X6 + (U2^3), (2) * X1 + ( - U1), (2) * X2 + ( - U2), (2) * X3 + ( - U1), (2) * X4 + ( - U2), (2 * U2^3) * X5 + ( - U1 * U2^3) ]
+real time : 8.133 secs
+run time  : 4.000 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 7")
+Warning: Test 7
+real time : 0.017 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (SETF FL
+            (PARSE-STRING-TO-SORTED-ALIST
+                "[a^2*x^2*y+b*x^2*y+a^3*b*x*y+a^3*c*x*y,c^2*a*x^2+c^2*b*x^2+b*y+4]"
+                '(X Y A B C)))
+real time : 0.100 secs
+run time  : 0.050 secs
+VALUES--> (((((2 1 2 0 0) . 1) ((2 1 0 1 0) . 1) ((1 1 3 1 0) . 1)
+             ((1 1 3 0 1) . 1))
+            (((2 0 1 0 2) . 1) ((2 0 0 1 2) . 1) ((0 1 0 1 0) . 1)
+             ((0 0 0 0 0) . 4))))
+
+EVAL> (SETF CFL (MAKE-COLORED-POLY-LIST FL 2))
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (((((2 1) (((2 0 0) . 1) ((0 1 0) . 1)) . :WHITE)
+             ((1 1) (((3 1 0) . 1) ((3 0 1) . 1)) . :WHITE))
+            (((2 0) (((1 0 2) . 1) ((0 1 2) . 1)) . :WHITE)
+             ((0 1) (((0 1 0) . 1)) . :WHITE)
+             ((0 0) (((0 0 0) . 4)) . :WHITE))))
+
+EVAL> (COND-SYSTEM-PRINT (DETERMINE CFL) '(X Y) '(A B C))
+Condition:
+  Green list: [  ]
+  Red list: [ A * C^2 + B * C^2, A^2 + B ]
+ Basis: [ (A^2 + B) * X^2 * Y + (A^3 * B + A^3 * C) * X * Y, (A * C^2 + B * C^2) * X^2 + (B) * Y + (4) ]
+Condition:
+  Green list: [ A^2 + B ]
+  Red list: [ A * C^2 + B * C^2, A^3 * B + A^3 * C ]
+ Basis: [ (A^3 * B + A^3 * C) * X * Y, (A * C^2 + B * C^2) * X^2 + (B) * Y + (4) ]
+Condition:
+  Green list: [ A^2 - C, B + C ]
+  Red list: [ A * C^2 + B * C^2 ]
+ Basis: [ (A * C^2 + B * C^2) * X^2 + (B) * Y + (4) ]
+Condition:
+  Green list: [ A * C^2 + B * C^2 ]
+  Red list: [ B, A^2 + B ]
+ Basis: [ (A^2 + B) * X^2 * Y + (A^3 * B + A^3 * C) * X * Y, (B) * Y + (4) ]
+Condition:
+  Green list: [ A * C^2 - C^2, A^2 + B, B * C^2 + C^2 ]
+  Red list: [ B, A^3 * B + A^3 * C ]
+ Basis: [ (A^3 * B + A^3 * C) * X * Y, (B) * Y + (4) ]
+Condition:
+  Green list: [ B + 1, C - 1, A - 1 ]
+  Red list: [ B ]
+ Basis: [ (B) * Y + (4) ]
+Condition:
+  Green list: [ B, C^2 ]
+  Red list: [ 4, A^2 + B ]
+ Basis: [ (A^2 + B) * X^2 * Y + (A^3 * B + A^3 * C) * X * Y, (4) ]
+Condition:
+  Green list: [ A^2, A * C^2, B ]
+  Red list: [ 4 ]
+ Basis: [ (4) ]
+real time : 2.033 secs
+run time  : 0.650 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 8")
+Warning: Test 8
+real time : 0.017 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (SETF FL (PARSE-STRING-TO-SORTED-ALIST "[a^2*x+5*a]" '(X A)))
+real time : 0.017 secs
+run time  : 0.017 secs
+VALUES--> (((((1 2) . 1) ((0 1) . 5))))
+
+EVAL> (SETF CFL (MAKE-COLORED-POLY-LIST FL 1))
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (((((1) (((2) . 1)) . :WHITE) ((0) (((1) . 5)) . :WHITE))))
+
+EVAL> (COND-SYSTEM-PRINT (DETERMINE CFL) '(X) '(A))
+Condition:
+  Green list: [  ]
+  Red list: [ A^2 ]
+ Basis: [ (A^2) * X + (5 * A) ]
+Condition:
+  Green list: [ A^2 ]
+  Red list: [  ]
+ Basis: [ ]
+real time : 0.100 secs
+run time  : 0.000 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 9 - the discriminant of a quadratic polynomial")
+Warning: Test 9 - the discriminant of a quadratic polynomial
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM "[a*x^2+b*x+c,2*a*x+b]" '(X) '(A B C)
+          :COVER (LIST (LIST "[]" "[a]")))
+Condition:
+  Green list: [  ]
+  Red list: [ A, 4 * A * C - B^2 ]
+ Basis: [ (4 * A * C - B^2) ]
+Condition:
+  Green list: [ 4 * A * C - B^2 ]
+  Red list: [ A ]
+ Basis: [ (2 * A) * X + (B) ]
+real time : 0.267 secs
+run time  : 0.100 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 10 - the discriminant of a cubic polynomial")
+Warning: Test 10 - the discriminant of a cubic polynomial
+real time : 0.017 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM "[x^3+p*x+q,3*x^2+p]" '(X) '(P Q) :COVER
+          (LIST (LIST "[]" "[]")))
+Condition:
+  Green list: [  ]
+  Red list: [ P, 4 * P^3 + 27 * Q^2 ]
+ Basis: [ ( - 4 * P^3 - 27 * Q^2) ]
+Condition:
+  Green list: [ 4 * P^3 + 27 * Q^2 ]
+  Red list: [ P ]
+ Basis: [ (2 * P) * X + (3 * Q) ]
+Condition:
+  Green list: [ P ]
+  Red list: [ Q ]
+ Basis: [ (3 * Q) ]
+Condition:
+  Green list: [ P, Q ]
+  Red list: [  ]
+ Basis: [ (3) * X^2 ]
+real time : 0.533 secs
+run time  : 0.133 secs
+VALUES--> NIL
+
+EVAL> (WARN "Test 11 - the discriminant of a quartic polynomial")
+Warning: Test 11 - the discriminant of a quartic polynomial
+real time : 0.000 secs
+run time  : 0.000 secs
+VALUES--> (NIL)
+
+EVAL> (STRING-GROBNER-SYSTEM "[x^4+p*x^2+q*x+r,4*x^3+2*p*x+q]" '(X)
+          '(P Q R) :COVER (LIST (LIST "[]" "[]")))
+Condition:
+  Green list: [  ]
+  Red list: [ 16 * P^4 * R^2 - 4 * P^3 * Q^2 * R - 128 * P^2 * R^3 + 144 * P * Q^2 * R^2 - 27 * Q^4 * R + 256 * R^4, P, P^2 * Q + 12 * Q * R ]
+ Basis: [ (64 * P^5 * R^2 - 16 * P^4 * Q^2 * R - 512 * P^3 * R^3 + 576 * P^2 * Q^2 * R^2 - 108 * P * Q^4 * R + 1024 * P * R^4) ]
+Condition:
+  Green list: [ R ]
+  Red list: [ 4 * P^3 + 27 * Q^2, P, Q ]
+ Basis: [ ( - 4 * P^5 * Q^2 - 27 * P^2 * Q^4) ]
+Condition:
+  Green list: [ 16 * P^4 * R - 4 * P^3 * Q^2 - 128 * P^2 * R^2 + 144 * P * Q^2 * R - 27 * Q^4 + 256 * R^3 ]
+  Red list: [ P, P^2 * Q + 12 * Q * R ]
+ Basis: [ (2 * P^2 * Q + 24 * Q * R) * X + ( - 8 * P^2 * R + 3 * P * Q^2 + 32 * R^2) ]
+Condition:
+  Green list: [ P^2 * Q + 12 * Q * R ]
+  Red list: [ P, 8 * P^2 * R - 3 * P * Q^2 - 32 * R^2 ]
+ Basis: [ ( - 8 * P^2 * R + 3 * P * Q^2 + 32 * R^2) ]
+Condition:
+  Green list: [ R, Q ]
+  Red list: [ P ]
+ Basis: [ ( - 2 * P^3) * X ]
+Condition:
+  Green list: [ P^2 * Q + 12 * Q * R, 8 * P^2 * R - 3 * P * Q^2 - 32 * R^2, 3 * P * Q^3 + 128 * Q * R^2, 32 * P * Q * R - 9 * Q^3, 27 * Q^5 + 4096 * Q * R^3, 2 * P^3 - 8 * P * R + 9 * Q^2 ]
+  Red list: [ P ]
+ Basis: [ (2 * P) * X^2 + (3 * Q) * X + (4 * R) ]
+Condition:
+  Green list: [ P ]
+  Red list: [ R, Q ]
+ Basis: [ (Q^2 * R) ]
+Condition:
+  Green list: [ P, R ]
+  Red list: [ Q ]
+ Basis: [ (54 * Q^4) ]
+Condition:
+  Green list: [ P, Q ]
+  Red list: [ R ]
+ Basis: [ (4 * R) ]
+Condition:
+  Green list: [ P, Q, R ]
+  Red list: [  ]
+ Basis: [ (4) * X^3 ]
+real time : 5.333 secs
+run time  : 2.667 secs
+VALUES--> NIL
+
+EVAL> (DRIBBLE)
Index: /trunk/samples/midpoints.output
===================================================================
--- /trunk/samples/midpoints.output	(revision 14)
+++ /trunk/samples/midpoints.output	(revision 14)
@@ -0,0 +1,40 @@
+Verification that the generic case has one solution
+----------------------------------------------------------------
+(C1) eqns:[ (2) * U1 + ( - X2 - X3), (2) * V1 + ( - Y3), (2) * U2 + ( - X3), (2) * V2 + ( - Y3), (2) * U3 + ( - X2), (2) * V3, ( - 3 * X2 * Y3) * Y + (X2 * Y3^2), ( - 3 * X2 * Y3^2) * X + (X2^2 * Y3^2 + X2 * X3 * Y3^2) ];
+
+(D1) [- X3 - X2 + 2 U1, 2 V1 - Y3, 2 U2 - X3, 2 V2 - Y3, 2 U3 - X2, 2 V3, 
+
+			      2			     2	   2   2	    2
+			 X2 Y3  - 3 X2 Y Y3, X2 X3 Y3  + X2  Y3  - 3 X X2 Y3 ]
+(C2) solve(%,[x,y,u1,v1,u2,v2,u3,v3]);
+
+	   X3 + X2      Y3	 X3 + X2       Y3       X3	 Y3	  X2
+(D2) [[X = -------, Y = --, U1 = -------, V1 = --, U2 = --, V2 = --, U3 = --, 
+	      3	        3	    2	       2        2	 2	  2
+
+----------------------------------------------------------------
+>(load "midpoints")
+Loading midpoints.lisp
+Condition:
+  Green list: [  ]
+  Red list: [ X2 * Y3^2 ]
+ Basis: [ (2) * U1 + ( - X2 - X3), (2) * V1 + ( - Y3), (2) * U2 + ( - X3), (2) * V2 + ( - Y3), (2) * U3 + ( - X2), (2) * V3, ( - 3 * X2 * Y3) * Y + (X2 * Y3^2), ( - 3 * X2 * Y3^2) * X + (X2^2 * Y3^2 + X2 * X3 * Y3^2) ]
+Condition:
+  Green list: [ X2 ]
+  Red list: [ Y3 ]
+ Basis: [ (2) * U1 + ( - X3), (2) * V1 + ( - Y3), (2) * U2 + ( - X3), (2) * V2 + ( - Y3), (2) * U3, (2) * V3, ( - Y3) * X + (X3) * Y ]
+Condition:
+  Green list: [ Y3 ]
+  Red list: [ X2 + X3 ]
+ Basis: [ (2) * U1 + ( - X2 - X3), (2) * V1, (2) * U2 + ( - X3), (2) * V2, (2) * U3 + ( - X2), (2) * V3, (X2 + X3) * Y ]
+Condition:
+  Green list: [ Y3, X2 + X3 ]
+  Red list: [ X3 ]
+ Basis: [ (2) * U1, (2) * V1, (2) * U2 + ( - X3), (2) * V2, (2) * U3 + (X3), (2) * V3, (3 * X3) * Y ]
+Condition:
+  Green list: [ X2, Y3, X3 ]
+  Red list: [  ]
+ Basis: [ (2) * U1, (2) * V1, (2) * U2, (2) * V2, (2) * U3, (2) * V3 ]
+Finished loading midpoints.lisp
+T
+
Index: /trunk/samples/poly4.output
===================================================================
--- /trunk/samples/poly4.output	(revision 14)
+++ /trunk/samples/poly4.output	(revision 14)
@@ -0,0 +1,37 @@
+(time (STRING-GROBNER-SYSTEM
+"[A0*X^4+A1*X^3+A2*X^2+A3*X+A4,4*A0*X^3+3*A1*X^2+2*A2*X+A3]"
+'(X)
+'(A0 A1 A2 A3 A4)
+:COVER (LIST (LIST "[]" "[A0]"))
+:MAIN-ORDER #'LEX>
+:PARAMETER-ORDER #'GREVLEX>))
+Condition:
+  Green list: [  ]
+  Red list: [ A1^2 * A2^2 * A3^2 - 4 * A0 * A2^3 * A3^2 - 4 * A1^3 * A3^3 + 18 * A0 * A1 * A2 * A3^3 - 27 * A0^2 * A3^4 - 4 * A1^2 * A2^3 * A4 + 16 * A0 * A2^4 * A4 + 18 * A1^3 * A2 * A3 * A4 - 80 * A0 * A1 * A2^2 * A3 * A4 - 6 * A0 * A1^2 * A3^2 * A4 + 144 * A0^2 * A2 * A3^2 * A4 - 27 * A1^4 * A4^2 + 144 * A0 * A1^2 * A2 * A4^2 - 128 * A0^2 * A2^2 * A4^2 - 192 * A0^2 * A1 * A3 * A4^2 + 256 * A0^3 * A4^3, 3 * A1^2 - 8 * A0 * A2, A0, A1^2 * A2^2 - 4 * A0 * A2^3 - 3 * A1^3 * A3 + 14 * A0 * A1 * A2 * A3 - 18 * A0^2 * A3^2 - 6 * A0 * A1^2 * A4 + 16 * A0^2 * A2 * A4 ]
+ Basis: [ ( - 144 * A0 * A1^6 * A2^2 * A3^2 + 1344 * A0^2 * A1^4 * A2^3 * A3^2 - 4096 * A0^3 * A1^2 * A2^4 * A3^2 + 4096 * A0^4 * A2^5 * A3^2 + 576 * A0 * A1^7 * A3^3 - 5664 * A0^2 * A1^5 * A2 * A3^3 + 17920 * A0^3 * A1^3 * A2^2 * A3^3 - 18432 * A0^4 * A1 * A2^3 * A3^3 + 3888 * A0^3 * A1^4 * A3^4 - 20736 * A0^4 * A1^2 * A2 * A3^4 + 27648 * A0^5 * A2^2 * A3^4 + 576 * A0 * A1^6 * A2^3 * A4 - 5376 * A0^2 * A1^4 * A2^4 * A4 + 16384 * A0^3 * A1^2 * A2^5 * A4 - 16384 * A0^4 * A2^6 * A4 - 2592 * A0 * A1^7 * A2 * A3 * A4 + 25344 * A0^2 * A1^5 * A2^2 * A3 * A4 - 79872 * A0^3 * A1^3 * A2^3 * A3 * A4 + 81920 * A0^4 * A1 * A2^4 * A3 * A4 + 864 * A0^2 * A1^6 * A3^2 * A4 - 25344 * A0^3 * A1^4 * A2 * A3^2 * A4 + 116736 * A0^4 * A1^2 * A2^2 * A3^2 * A4 - 147456 * A0^5 * A2^3 * A3^2 * A4 + 3888 * A0 * A1^8 * A4^2 - 41472 * A0^2 * A1^6 * A2 * A4^2 + 156672 * A0^3 * A1^4 * A2^2 * A4^2 - 245760 * A0^4 * A1^2 * A2^3 * A4^2 + 131072 * A0^5 * A2^4 * A4^2 + 27648 * A0^3 * A1^5 * A3 * A4^2 - 147456 * A0^4 * A1^3 * A2 * A3 * A4^2 + 196608 * A0^5 * A1 * A2^2 * A3 * A4^2 - 36864 * A0^4 * A1^4 * A4^3 + 196608 * A0^5 * A1^2 * A2 * A4^3 - 262144 * A0^6 * A2^2 * A4^3) ]
+Condition:
+  Green list: [ A1^2 * A2^2 * A3^2 - 4 * A0 * A2^3 * A3^2 - 4 * A1^3 * A3^3 + 18 * A0 * A1 * A2 * A3^3 - 27 * A0^2 * A3^4 - 4 * A1^2 * A2^3 * A4 + 16 * A0 * A2^4 * A4 + 18 * A1^3 * A2 * A3 * A4 - 80 * A0 * A1 * A2^2 * A3 * A4 - 6 * A0 * A1^2 * A3^2 * A4 + 144 * A0^2 * A2 * A3^2 * A4 - 27 * A1^4 * A4^2 + 144 * A0 * A1^2 * A2 * A4^2 - 128 * A0^2 * A2^2 * A4^2 - 192 * A0^2 * A1 * A3 * A4^2 + 256 * A0^3 * A4^3 ]
+  Red list: [ A1^2 * A2^2 - 4 * A0 * A2^3 - 3 * A1^3 * A3 + 14 * A0 * A1 * A2 * A3 - 18 * A0^2 * A3^2 - 6 * A0 * A1^2 * A4 + 16 * A0^2 * A2 * A4, A0, 3 * A1^2 - 8 * A0 * A2 ]
+ Basis: [ ]
+Condition:
+  Green list: [ A1^2 * A2^2 - 4 * A0 * A2^3 - 3 * A1^3 * A3 + 14 * A0 * A1 * A2 * A3 - 18 * A0^2 * A3^2 - 6 * A0 * A1^2 * A4 + 16 * A0^2 * A2 * A4 ]
+  Red list: [ A1^2 * A2 * A3 - 4 * A0 * A2^2 * A3 + 3 * A0 * A1 * A3^2 - 9 * A1^3 * A4 + 32 * A0 * A1 * A2 * A4 - 48 * A0^2 * A3 * A4, A0, 3 * A1^2 - 8 * A0 * A2 ]
+ Basis: [ ( - 16 * A0 * A1^2 * A2 * A3 + 64 * A0^2 * A2^2 * A3 - 48 * A0^2 * A1 * A3^2 + 144 * A0 * A1^3 * A4 - 512 * A0^2 * A1 * A2 * A4 + 768 * A0^3 * A3 * A4) ]
+Condition:
+  Green list: [ A1^2 * A2^2 - 4 * A0 * A2^3 - 3 * A1^3 * A3 + 14 * A0 * A1 * A2 * A3 - 18 * A0^2 * A3^2 - 6 * A0 * A1^2 * A4 + 16 * A0^2 * A2 * A4, A1^2 * A2 * A3 - 4 * A0 * A2^2 * A3 + 3 * A0 * A1 * A3^2 - 9 * A1^3 * A4 + 32 * A0 * A1 * A2 * A4 - 48 * A0^2 * A3 * A4, A2^2 * A3^2 - 3 * A1 * A3^3 - 4 * A2^3 * A4 + 14 * A1 * A2 * A3 * A4 - 6 * A0 * A3^2 * A4 - 18 * A1^2 * A4^2 + 16 * A0 * A2 * A4^2, A1 * A2 * A3^2 - 9 * A0 * A3^3 - 4 * A1 * A2^2 * A4 + 3 * A1^2 * A3 * A4 + 32 * A0 * A2 * A3 * A4 - 48 * A0 * A1 * A4^2, A1^2 * A3^2 - 3 * A0 * A2 * A3^2 - 3 * A1^2 * A2 * A4 + 8 * A0 * A2^2 * A4 + 4 * A0 * A1 * A3 * A4 - 32 * A0^2 * A4^2 ]
+  Red list: [ A0, 3 * A1^2 - 8 * A0 * A2 ]
+ Basis: [ ]
+Condition:
+  Green list: [ 3 * A1^2 - 8 * A0 * A2 ]
+  Red list: [ A0, A1 * A2 - 6 * A0 * A3 ]
+ Basis: [ ( - 2 * A1 * A2 + 12 * A0 * A3) * X + ( - A1 * A3 + 16 * A0 * A4) ]
+Condition:
+  Green list: [ 3 * A1^2 - 8 * A0 * A2, A1 * A2 - 6 * A0 * A3, 4 * A2^2 - 9 * A1 * A3 ]
+  Red list: [ A0, A1 * A3 - 16 * A0 * A4 ]
+ Basis: [ ( - A1 * A3 + 16 * A0 * A4) ]
+Condition:
+  Green list: [ A2^2 - 36 * A0 * A4, 3 * A1^2 - 8 * A0 * A2, A1 * A2 - 6 * A0 * A3, A1 * A3 - 16 * A0 * A4, 3 * A3^2 - 8 * A2 * A4, A2 * A3 - 6 * A1 * A4 ]
+  Red list: [ A0 ]
+ Basis: [ ]
+real time : 50.133 secs
+run time  : 45.150 secs
Index: /trunk/samples/ratpoly-tests.output
===================================================================
--- /trunk/samples/ratpoly-tests.output	(revision 14)
+++ /trunk/samples/ratpoly-tests.output	(revision 14)
@@ -0,0 +1,200 @@
+Starts dribbling to ratpoly-tests.output (1995/3/28, 23:27:4).
+VALUE--> NIL
+
+EVAL> (SETF F
+            (PARSE-STRING-TO-SORTED-ALIST x^2*y-3*x*y^2+x^2-3*x*y
+                '(X Y)))
+VALUE--> (((2 1) . 1) ((2 0) . 1) ((1 2) . -3) ((1 1) . -3))
+
+EVAL> (SETF G
+            (PARSE-STRING-TO-SORTED-ALIST x^3*y-4*y^2+y+x^3-4*y+1
+                '(X Y)))
+VALUE--> (((3 1) . 1) ((3 0) . 1) ((0 2) . -4) ((0 1) . -3)
+          ((0 0) . 1))
+
+EVAL> (POLY-PRINT F '(X Y))
+X^2 * Y + X^2 - 3 * X * Y^2 - 3 * X * Y
+VALUE--> (((2 1) . 1) ((2 0) . 1) ((1 2) . -3) ((1 1) . -3))
+
+EVAL> (POLY-PRINT G '(X Y))
+X^3 * Y + X^3 - 4 * Y^2 - 3 * Y + 1
+VALUE--> (((3 1) . 1) ((3 0) . 1) ((0 2) . -4) ((0 1) . -3)
+          ((0 0) . 1))
+
+EVAL> (SETF RF (POLY-TO-RATPOLY F))
+VALUE--> (2 ((((1) . 1) ((0) . 1)) ((0) . 1)) 1
+          ((((2) . -3) ((1) . -3)) ((0) . 1)))
+
+EVAL> (SETF RG (POLY-TO-RATPOLY G))
+VALUE--> (3 ((((1) . 1) ((0) . 1)) ((0) . 1)) 0
+          ((((2) . -4) ((1) . -3) ((0) . 1)) ((0) . 1)))
+
+EVAL> (RATPOLY-PRINT RF '(X Y))
+((Y + 1) / (1)) * X^2 + (( - 3 * Y^2 - 3 * Y) / (1)) * X
+VALUE--> (2 ((((1) . 1) ((0) . 1)) ((0) . 1)) 1
+          ((((2) . -3) ((1) . -3)) ((0) . 1)))
+
+EVAL> (RATPOLY-PRINT RG '(X Y))
+((Y + 1) / (1)) * X^3 + (( - 4 * Y^2 - 3 * Y + 1) / (1))
+VALUE--> (3 ((((1) . 1) ((0) . 1)) ((0) . 1)) 0
+          ((((2) . -4) ((1) . -3) ((0) . 1)) ((0) . 1)))
+
+EVAL> (SETF RES (RATPOLY-RESULTANT RF RG))
+VALUE--> (0
+          ((((9) . 108) ((8) . 513) ((7) . 929) ((6) . 738) ((5) . 149)
+            ((4) . -112) ((3) . -37) ((2) . 14) ((1) . 3) ((0) . -1))
+           ((0) . -1)))
+
+EVAL> (RATPOLY-PRINT RES '(X Y))
+((108 * Y^9 + 513 * Y^8 + 929 * Y^7 + 738 * Y^6 + 149 * Y^5 - 112 * Y^4 - 37 * Y^3 + 14 * Y^2 + 3 * Y - 1) / ( - 1))
+VALUE--> (0
+          ((((9) . 108) ((8) . 513) ((7) . 929) ((6) . 738) ((5) . 149)
+            ((4) . -112) ((3) . -37) ((2) . 14) ((1) . 3) ((0) . -1))
+           ((0) . -1)))
+
+EVAL> (SETF RES (RATPOLY-TO-POLY RES))
+VALUE--> (((0 9) . -108) ((0 8) . -513) ((0 7) . -929) ((0 6) . -738)
+          ((0 5) . -149) ((0 4) . 112) ((0 3) . 37) ((0 2) . -14)
+          ((0 1) . -3) ((0 0) . 1))
+
+EVAL> (POLY-PRINT RES '(X Y))
+ - 108 * Y^9 - 513 * Y^8 - 929 * Y^7 - 738 * Y^6 - 149 * Y^5 + 112 * Y^4 + 37 * Y^3 - 14 * Y^2 - 3 * Y + 1
+VALUE--> (((0 9) . -108) ((0 8) . -513) ((0 7) . -929) ((0 6) . -738)
+          ((0 5) . -149) ((0 4) . 112) ((0 3) . 37) ((0 2) . -14)
+          ((0 1) . -3) ((0 0) . 1))
+
+EVAL> (SETF DISC (RATPOLY-DISCRIMINANT RF))
+VALUE--> (0 ((((4) . -9) ((3) . -18) ((2) . -9)) ((0) . 1)))
+
+EVAL> (RATPOLY-PRINT DISC '(X Y))
+(( - 9 * Y^4 - 18 * Y^3 - 9 * Y^2) / (1))
+VALUE--> (0 ((((4) . -9) ((3) . -18) ((2) . -9)) ((0) . 1)))
+
+EVAL> (SETF DISC (RATPOLY-TO-POLY DISC))
+VALUE--> (((0 4) . -9) ((0 3) . -18) ((0 2) . -9))
+
+EVAL> (POLY-PRINT DISC '(X Y))
+ - 9 * Y^4 - 18 * Y^3 - 9 * Y^2
+VALUE--> (((0 4) . -9) ((0 3) . -18) ((0 2) . -9))
+
+EVAL> (SETF F (PARSE-STRING-TO-SORTED-ALIST x^2*y-3*x-1 '(X Y)))
+VALUE--> (((2 1) . 1) ((1 0) . -3) ((0 0) . -1))
+
+EVAL> (SETF G (PARSE-STRING-TO-SORTED-ALIST 6*x^2+y^2-4 '(X Y)))
+VALUE--> (((2 0) . 6) ((0 2) . 1) ((0 0) . -4))
+
+EVAL> (SETF RF (POLY-TO-RATPOLY F))
+VALUE--> (2 ((((1) . 1)) ((0) . 1)) 1 ((((0) . -3)) ((0) . 1)) 0
+          ((((0) . -1)) ((0) . 1)))
+
+EVAL> (SETF RG (POLY-TO-RATPOLY G))
+VALUE--> (2 ((((0) . 6)) ((0) . 1)) 0
+          ((((2) . 1) ((0) . -4)) ((0) . 1)))
+
+EVAL> (SETF RES (RATPOLY-RESULTANT RF RG))
+VALUE--> (0
+          ((((6) . 1) ((4) . -8) ((3) . 12) ((2) . 70) ((1) . -48)
+            ((0) . -180))
+           ((0) . 1)))
+
+EVAL> (SETF RES (RATPOLY-TO-POLY RES))
+VALUE--> (((0 6) . 1) ((0 4) . -8) ((0 3) . 12) ((0 2) . 70)
+          ((0 1) . -48) ((0 0) . -180))
+
+EVAL> (POLY-PRINT RES '(X Y))
+Y^6 - 8 * Y^4 + 12 * Y^3 + 70 * Y^2 - 48 * Y - 180
+VALUE--> (((0 6) . 1) ((0 4) . -8) ((0 3) . 12) ((0 2) . 70)
+          ((0 1) . -48) ((0 0) . -180))
+
+EVAL> (SETF RES (POLY-RESULTANT F G))
+VALUE--> (((0 6) . 1) ((0 4) . -8) ((0 3) . 12) ((0 2) . 70)
+          ((0 1) . -48) ((0 0) . -180))
+
+EVAL> (POLY-PRINT RES '(X Y))
+Y^6 - 8 * Y^4 + 12 * Y^3 + 70 * Y^2 - 48 * Y - 180
+VALUE--> (((0 6) . 1) ((0 4) . -8) ((0 3) . 12) ((0 2) . 70)
+          ((0 1) . -48) ((0 0) . -180))
+
+EVAL> (SETF F
+            (PARSE-STRING-TO-SORTED-ALIST 6*x^4-23*x^3+32*x^2-19*x+4
+                '(X)))
+VALUE--> (((4) . 6) ((3) . -23) ((2) . 32) ((1) . -19) ((0) . 4))
+
+EVAL> (SETF RF (POLY-TO-RATPOLY F))
+VALUE--> (4 (((NIL . 6)) (NIL . 1)) 3 (((NIL . -23)) (NIL . 1)) 2
+          (((NIL . 32)) (NIL . 1)) 1 (((NIL . -19)) (NIL . 1)) 0
+          (((NIL . 4)) (NIL . 1)))
+
+EVAL> (SETF RG (RATPOLY-DIFF RF))
+VALUE--> (3 (((NIL . 24)) (NIL . 1)) 2 (((NIL . -69)) (NIL . 1)) 1
+          (((NIL . 64)) (NIL . 1)) 0 (((NIL . -19)) (NIL . 1)))
+
+EVAL> (SETF G (RATPOLY-TO-POLY RG))
+VALUE--> (((3) . 24) ((2) . -69) ((1) . 64) ((0) . -19))
+
+EVAL> (SETF RES (RATPOLY-RESULTANT RF RG))
+VALUE--> NIL
+
+EVAL> (SETF RES (RATPOLY-TO-POLY RES))
+VALUE--> NIL
+
+EVAL> (POLY-PRINT RES '(X))
+0
+VALUE--> NIL
+
+EVAL> (SETF RES (POLY-RESULTANT F G))
+VALUE--> NIL
+
+EVAL> (POLY-PRINT RES '(X))
+0
+VALUE--> NIL
+
+EVAL> (SETF F
+            (PARSE-STRING-TO-SORTED-ALIST 6*x^4+23*x^3-30*x^2-19*x+4
+                '(X)))
+VALUE--> (((4) . 6) ((3) . 23) ((2) . -30) ((1) . -19) ((0) . 4))
+
+EVAL> (SETF RF (POLY-TO-RATPOLY F))
+VALUE--> (4 (((NIL . 6)) (NIL . 1)) 3 (((NIL . 23)) (NIL . 1)) 2
+          (((NIL . -30)) (NIL . 1)) 1 (((NIL . -19)) (NIL . 1)) 0
+          (((NIL . 4)) (NIL . 1)))
+
+EVAL> (SETF RG (RATPOLY-DIFF RF))
+VALUE--> (3 (((NIL . 24)) (NIL . 1)) 2 (((NIL . 69)) (NIL . 1)) 1
+          (((NIL . -60)) (NIL . 1)) 0 (((NIL . -19)) (NIL . 1)))
+
+EVAL> (SETF G (RATPOLY-TO-POLY RG))
+VALUE--> (((3) . 24) ((2) . 69) ((1) . -60) ((0) . -19))
+
+EVAL> (SETF RES (RATPOLY-RESULTANT RF RG))
+VALUE--> (0 (((NIL . 13867656600)) (NIL . 1)))
+
+EVAL> (SETF RES (RATPOLY-TO-POLY RES))
+VALUE--> (((0) . 13867656600))
+
+EVAL> (POLY-PRINT RES '(X))
+13867656600
+VALUE--> (((0) . 13867656600))
+
+EVAL> (SETF RES (POLY-RESULTANT F G))
+VALUE--> (((0) . 13867656600))
+
+EVAL> (POLY-PRINT RES '(X))
+13867656600
+VALUE--> (((0) . 13867656600))
+
+EVAL> (SETF DISC (RATPOLY-DISCRIMINANT RF))
+VALUE--> (0 (((NIL . 2311276100)) (NIL . 1)))
+
+EVAL> (RATPOLY-PRINT DISC '(X Y))
+((2311276100) / (1))
+VALUE--> (0 (((NIL . 2311276100)) (NIL . 1)))
+
+EVAL> (SETF DISC (RATPOLY-TO-POLY DISC))
+VALUE--> (((0) . 2311276100))
+
+EVAL> (POLY-PRINT DISC '(X Y))
+2311276100
+VALUE--> (((0) . 2311276100))
+
+EVAL> (DRIBBLE)
Index: /trunk/samples/robot.output
===================================================================
--- /trunk/samples/robot.output	(revision 14)
+++ /trunk/samples/robot.output	(revision 14)
@@ -0,0 +1,30 @@
+EVAL> (STRING-GROBNER-SYSTEM
+          "[a-l3*c1*c2+l3*s1*s2-l2*c1, b-l3*c1*s2-l3*c2*s1-l2*s1, c1^2+s1^2-1, c2^2+s2^2-1]"
+          '(C2 S2 C1 S1) '(A B L2 L3) :COVER '(("[]" "[l2,l3]")))
+Condition:
+  Green list: [  ]
+  Red list: [ L3, A^2 + B^2, L2, A ]
+ Basis: [ ( - 2 * A * L2) * C1 + ( - 2 * B * L2) * S1 + (A^2 + B^2 + L2^2 - L3^2), (4 * A^2 * L2^2 + 4 * B^2 * L2^2) * S1^2 + ( - 4 * A^2 * B * L2 - 4 * B^3 * L2 - 4 * B * L2^3 + 4 * B * L2 * L3^2) * S1 + (A^4 + 2 * A^2 * B^2 - 2 * A^2 * L2^2 - 2 * A^2 * L3^2 + B^4 + 2 * B^2 * L2^2 - 2 * B^2 * L3^2 + L2^4 - 2 * L2^2 * L3^2 + L3^4), ( - 2 * A * L2 * L3) * S2 + ( - 2 * A^2 * L2 - 2 * B^2 * L2) * S1 + (A^2 * B + B^3 + B * L2^2 - B * L3^2), ( - 2 * L2 * L3) * C2 + (A^2 + B^2 - L2^2 - L3^2) ]
+Condition:
+  Green list: [ A^2 + B^2 ]
+  Red list: [ L3, B * L2^2 - B * L3^2, L2, A ]
+ Basis: [ ( - 4 * B * L2^3 + 4 * B * L2 * L3^2) * S1 + (4 * B^2 * L2^2 + L2^4 - 2 * L2^2 * L3^2 + L3^4), (4 * A * B * L2^3 * L3 - 4 * A * B * L2 * L3^3) * S2 + ( - 2 * B^2 * L2^4 + 4 * B^2 * L2^2 * L3^2 - 2 * B^2 * L3^4), ( - 2 * L2 * L3) * C2 + ( - L2^2 - L3^2), (4 * A * L2^3 - 4 * A * L2 * L3^2) * C1 + (4 * B^2 * L2^2 - L2^4 + 2 * L2^2 * L3^2 - L3^4) ]
+Condition:
+  Green list: [ A^2 + B^2, L2^2 - L3^2 ]
+  Red list: [ B^2, L3, A, L2 ]
+ Basis: [ (4 * B^2 * L3^2) ]
+Condition:
+  Green list: [ A ]
+  Red list: [ L3, B, L2 ]
+ Basis: [ ( - 2 * B * L2) * S1 + (B^2 + L2^2 - L3^2), ( - 2 * L2 * L3) * C2 + (B^2 - L2^2 - L3^2) ]
+Condition:
+  Green list: [ A, B ]
+  Red list: [ L3, L2, L2^2 - L3^2 ]
+ Basis: [ (L2^2 - L3^2) ]
+Condition:
+  Green list: [ A, B, L2^2 - L3^2 ]
+  Red list: [ L3, L2 ]
+ Basis: [ ]
+real time : 10.183 secs
+run time  : 9.017 secs
+VALUES--> NIL
Index: /trunk/samples/shash2.output
===================================================================
--- /trunk/samples/shash2.output	(revision 14)
+++ /trunk/samples/shash2.output	(revision 14)
@@ -0,0 +1,1 @@
+[ 2 * E1 + E3 * E4 * H4^2 * X4 + E3 * H4 * X4 + 2 * E3 * Y4 - 2 * E4^2 * H2 * X4 - E4^2 * H3 * H4 * X4 - E4^2 * H4 * X4 * Y1 - E4^2 * H4 * X4 * Y2 - E4^2 * H4 * X4 * Y3 - E4^2 * H4 * X4 * Y4 + 3 * E4 * H3 * X4 + E4 * H4 * X1 * X4 + E4 * H4 * X2 * X4 + E4 * H4 * X3 * X4 + E4 * H4 * X4^2 + E4 * X4 * Y1 + E4 * X4 * Y2 + E4 * X4 * Y3 + 3 * E4 * X4 * Y4 - X1 * X4 - X2 * X4 - X3 * X4 + X4^2, E3 * E4 * H3 * H4^2 + 2 * E3 * E4 * H4^2 * Y4 - 2 * E3 * H2 + E3 * H3 * H4 + 2 * E3 * H4^2 * X4 - 2 * E4^2 * H2 * H3 - 4 * E4^2 * H2 * Y4 - E4^2 * H3^2 * H4 - E4^2 * H3 * H4 * Y1 - E4^2 * H3 * H4 * Y2 - E4^2 * H3 * H4 * Y3 - 3 * E4^2 * H3 * H4 * Y4 - 2 * E4^2 * H4 * Y1 * Y4 - 2 * E4^2 * H4 * Y2 * Y4 - 2 * E4^2 * H4 * Y3 * Y4 - 2 * E4^2 * H4 * Y4^2 - 4 * E4 * H2 * X4 + 3 * E4 * H3^2 + E4 * H3 * H4 * X1 + E4 * H3 * H4 * X2 + E4 * H3 * H4 * X3 - E4 * H3 * H4 * X4 + E4 * H3 * Y1 + E4 * H3 * Y2 + E4 * H3 * Y3 + 9 * E4 * H3 * Y4 + 2 * E4 * H4 * X1 * Y4 + 2 * E4 * H4 * X2 * Y4 + 2 * E4 * H4 * X3 * Y4 - 2 * E4 * H4 * X4 * Y1 - 2 * E4 * H4 * X4 * Y2 - 2 * E4 * H4 * X4 * Y3 + 2 * E4 * Y1 * Y4 - 2 * E4 * Y2 * Y3 + 4 * E4 * Y2 * Y4 + 4 * E4 * Y3 * Y4 + 4 * E4 * Y4^2 - H3 * X1 - H3 * X2 - H3 * X3 + 7 * H3 * X4 - 2 * H4 * X2 * X3 + 2 * H4 * X2 * X4 + 2 * H4 * X3 * X4 + 2 * H4 * X4^2 - 2 * X1 * Y4 - 2 * X2 * Y3 - 2 * X3 * Y2 + 2 * X4 * Y1 + 4 * X4 * Y2 + 4 * X4 * Y3 + 4 * X4 * Y4, E3 * H2^2 - E3 * H3^2 * H4^2 - 2 * E3 * H3 * H4^3 * X4 - 2 * E3 * H3 * H4^2 * Y4 - E3 * H4^4 * X4^2 - 2 * E3 * H4^3 * X4 * Y4 - E3 * H4^2 * Y4^2 + 2 * E4 * H2 * H3^2 + 4 * E4 * H2 * H3 * H4 * X4 + 6 * E4 * H2 * H3 * Y4 + 2 * E4 * H2 * H4^2 * X4^2 + 4 * E4 * H2 * H4 * X4 * Y4 + 4 * E4 * H2 * Y4^2 + E4 * H3^3 * H4 + 2 * E4 * H3^2 * H4^2 * X4 + E4 * H3^2 * H4 * Y1 + E4 * H3^2 * H4 * Y2 + E4 * H3^2 * H4 * Y3 + 3 * E4 * H3^2 * H4 * Y4 + E4 * H3 * H4^3 * X4^2 + 2 * E4 * H3 * H4^2 * X4 * Y1 + 2 * E4 * H3 * H4^2 * X4 * Y2 + 2 * E4 * H3 * H4^2 * X4 * Y3 + 4 * E4 * H3 * H4^2 * X4 * Y4 + 2 * E4 * H3 * H4 * Y1 * Y4 + 2 * E4 * H3 * H4 * Y2 * Y4 + 2 * E4 * H3 * H4 * Y3 * Y4 + 4 * E4 * H3 * H4 * Y4^2 + E4 * H4^3 * X4^2 * Y1 + E4 * H4^3 * X4^2 * Y2 + E4 * H4^3 * X4^2 * Y3 + E4 * H4^3 * X4^2 * Y4 + 2 * E4 * H4^2 * X4 * Y1 * Y4 + E4 * H4^2 * X4 * Y2 * Y3 + E4 * H4^2 * X4 * Y2 * Y4 + E4 * H4^2 * X4 * Y3 * Y4 + 3 * E4 * H4^2 * X4 * Y4^2 - 2 * E4 * H4 * Y2 * Y3 * Y4 + 2 * E4 * H4 * Y2 * Y4^2 + 2 * E4 * H4 * Y3 * Y4^2 + 2 * E4 * H4 * Y4^3 + 2 * H2 * H3 * X4 + 2 * H2 * H4 * X4^2 + H2 * X4 * Y1 + H2 * X4 * Y2 + H2 * X4 * Y3 + H2 * X4 * Y4 - 3 * H3^3 - 10 * H3^2 * H4 * X4 - H3^2 * Y1 - H3^2 * Y2 - H3^2 * Y3 - 11 * H3^2 * Y4 + H3 * H4^2 * X1 * X2 + H3 * H4^2 * X1 * X3 - 3 * H3 * H4^2 * X1 * X4 + H3 * H4^2 * X2 * X3 - 3 * H3 * H4^2 * X2 * X4 - 3 * H3 * H4^2 * X3 * X4 - 5 * H3 * H4^2 * X4^2 + 2 * H3 * H4 * X2 * Y1 - 2 * H3 * H4 * X2 * Y4 + 2 * H3 * H4 * X3 * Y1 + 2 * H3 * H4 * X3 * Y2 - 4 * H3 * H4 * X3 * Y4 - 8 * H3 * H4 * X4 * Y1 - 6 * H3 * H4 * X4 * Y2 - 4 * H3 * H4 * X4 * Y3 - 12 * H3 * H4 * X4 * Y4 + H3 * Y1 * Y2 + H3 * Y1 * Y3 - 4 * H3 * Y1 * Y4 + H3 * Y2 * Y3 - 4 * H3 * Y2 * Y4 - 4 * H3 * Y3 * Y4 - 11 * H3 * Y4^2 + H4^3 * X1 * X2 * X3 - H4^3 * X1 * X2 * X4 - H4^3 * X1 * X3 * X4 - H4^3 * X2 * X4^2 - H4^3 * X3 * X4^2 - H4^3 * X4^3 + H4^2 * X1 * X2 * Y1 - H4^2 * X1 * X2 * Y2 + H4^2 * X1 * X2 * Y3 + H4^2 * X1 * X2 * Y4 + H4^2 * X1 * X3 * Y1 + H4^2 * X1 * X3 * Y2 - H4^2 * X1 * X3 * Y3 + H4^2 * X1 * X3 * Y4 - 3 * H4^2 * X1 * X4 * Y1 - H4^2 * X1 * X4 * Y2 - H4^2 * X1 * X4 * Y3 - H4^2 * X1 * X4 * Y4 + H4^2 * X2 * X3 * Y1 + H4^2 * X2 * X3 * Y2 - H4^2 * X2 * X3 * Y3 - H4^2 * X2 * X3 * Y4 - H4^2 * X2 * X4 * Y1 - H4^2 * X2 * X4 * Y2 - 2 * H4^2 * X2 * X4 * Y4 - H4^2 * X3 * X4 * Y1 + H4^2 * X3 * X4 * Y3 - 4 * H4^2 * X3 * X4 * Y4 - H4^2 * X4^2 * Y1 - 2 * H4^2 * X4^2 * Y2 - 2 * H4^2 * X4^2 * Y3 - H4^2 * X4^2 * Y4 - H4 * X1 * Y2^2 + H4 * X1 * Y2 * Y3 + H4 * X1 * Y2 * Y4 - H4 * X1 * Y3^2 + H4 * X1 * Y3 * Y4 - H4 * X1 * Y4^2 + H4 * X2 * Y1^2 + H4 * X2 * Y1 * Y3 + H4 * X2 * Y1 * Y4 - H4 * X2 * Y3^2 - H4 * X2 * Y3 * Y4 - H4 * X2 * Y4^2 + H4 * X3 * Y1^2 + H4 * X3 * Y1 * Y2 + H4 * X3 * Y1 * Y4 + H4 * X3 * Y2^2 - H4 * X3 * Y2 * Y4 - 3 * H4 * X3 * Y4^2 - 3 * H4 * X4 * Y1^2 - H4 * X4 * Y1 * Y2 - H4 * X4 * Y1 * Y3 - 5 * H4 * X4 * Y1 * Y4 - H4 * X4 * Y2^2 - H4 * X4 * Y2 * Y3 - 3 * H4 * X4 * Y2 * Y4 + H4 * X4 * Y3^2 - 3 * H4 * X4 * Y3 * Y4 - 3 * H4 * X4 * Y4^2 + Y1 * Y2 * Y3 + Y1 * Y2 * Y4 + Y1 * Y3 * Y4 - 3 * Y1 * Y4^2 + Y2 * Y3 * Y4 - 3 * Y2 * Y4^2 - 3 * Y3 * Y4^2 - 3 * Y4^3, E3 * H2 * Y1 - E3 * H2 * Y4 - E3 * H3 * H4 * Y1 + E3 * H3 * H4 * Y4 - E3 * H4^2 * X4 * Y1 + E3 * H4^2 * X4 * Y4 - E3 * H4 * Y1 * Y4 + E3 * H4 * Y4^2 + E4 * H3^2 * Y1 - E4 * H3^2 * Y4 + E4 * H3 * H4 * X4 * Y1 - E4 * H3 * H4 * X4 * Y4 + 4 * E4 * H3 * Y1 * Y4 - 4 * E4 * H3 * Y4^2 - E4 * H4 * X1 * Y1^2 + 2 * E4 * H4 * X1 * Y1 * Y4 + E4 * H4 * X1 * Y2 * Y3 - E4 * H4 * X1 * Y2 * Y4 - E4 * H4 * X1 * Y3 * Y4 + E4 * H4 * X4 * Y1^2 - 2 * E4 * H4 * X4 * Y2 * Y3 + 2 * E4 * H4 * X4 * Y2 * Y4 + 2 * E4 * H4 * X4 * Y3 * Y4 - 3 * E4 * H4 * X4 * Y4^2 - E4 * Y1^3 + 3 * E4 * Y1^2 * Y4 + E4 * Y1 * Y4^2 - 3 * E4 * Y4^3 + H3^2 * X1 - H3^2 * X4 - H3 * H4 * X1^2 + 5 * H3 * H4 * X1 * X4 - 4 * H3 * H4 * X4^2 - H3 * X1 * Y1 + 5 * H3 * X1 * Y4 + 3 * H3 * X4 * Y1 - 7 * H3 * X4 * Y4 - H4^2 * X1^2 * X2 - H4^2 * X1^2 * X3 + H4^2 * X1^2 * X4 + 3 * H4^2 * X1 * X2 * X4 + 3 * H4^2 * X1 * X3 * X4 - 2 * H4^2 * X1 * X4^2 - H4^2 * X2 * X3 * X4 - H4^2 * X2 * X4^2 - H4^2 * X3 * X4^2 - H4 * X1^2 * Y1 - H4 * X1^2 * Y2 - H4 * X1^2 * Y3 + H4 * X1^2 * Y4 - H4 * X1 * X2 * Y1 + H4 * X1 * X2 * Y4 - H4 * X1 * X3 * Y1 + H4 * X1 * X3 * Y4 + 4 * H4 * X1 * X4 * Y1 + 3 * H4 * X1 * X4 * Y2 + 3 * H4 * X1 * X4 * Y3 + 2 * H4 * X2 * X4 * Y1 - H4 * X2 * X4 * Y3 - H4 * X2 * X4 * Y4 + 2 * H4 * X3 * X4 * Y1 - H4 * X3 * X4 * Y2 - H4 * X3 * X4 * Y4 - 3 * H4 * X4^2 * Y1 - H4 * X4^2 * Y2 - H4 * X4^2 * Y3 - 3 * H4 * X4^2 * Y4 - X1 * Y1^2 - X1 * Y1 * Y2 - X1 * Y1 * Y3 + 2 * X1 * Y1 * Y4 - X1 * Y2 * Y3 + 2 * X1 * Y2 * Y4 + 2 * X1 * Y3 * Y4 + 2 * X1 * Y4^2 + 2 * X4 * Y1^2 + 2 * X4 * Y1 * Y2 + 2 * X4 * Y1 * Y3 - 2 * X4 * Y1 * Y4 + X4 * Y2 * Y3 - 3 * X4 * Y2 * Y4 - 3 * X4 * Y3 * Y4 - 3 * X4 * Y4^2, E3 * H2 * Y2 - E3 * H2 * Y4 - E3 * H3 * H4 * Y2 + E3 * H3 * H4 * Y4 - E3 * H4^2 * X4 * Y2 + E3 * H4^2 * X4 * Y4 - E3 * H4 * Y2 * Y4 + E3 * H4 * Y4^2 + E4 * H3^2 * Y2 - E4 * H3^2 * Y4 + E4 * H3 * H4 * X4 * Y2 - E4 * H3 * H4 * X4 * Y4 + 4 * E4 * H3 * Y2 * Y4 - 4 * E4 * H3 * Y4^2 - E4 * H4 * X2 * Y2^2 + E4 * H4 * X2 * Y2 * Y3 + E4 * H4 * X2 * Y2 * Y4 - E4 * H4 * X2 * Y3 * Y4 + E4 * H4 * X4 * Y2^2 - 2 * E4 * H4 * X4 * Y2 * Y3 + 2 * E4 * H4 * X4 * Y2 * Y4 + 2 * E4 * H4 * X4 * Y3 * Y4 - 3 * E4 * H4 * X4 * Y4^2 - E4 * Y2^3 + 3 * E4 * Y2^2 * Y4 + E4 * Y2 * Y4^2 - 3 * E4 * Y4^3 + H3^2 * X2 - H3^2 * X4 - H3 * H4 * X2^2 + 5 * H3 * H4 * X2 * X4 - 4 * H3 * H4 * X4^2 - H3 * X2 * Y2 + 5 * H3 * X2 * Y4 + 3 * H3 * X4 * Y2 - 7 * H3 * X4 * Y4 - H4^2 * X1 * X2^2 - H4^2 * X1 * X2 * X3 + 4 * H4^2 * X1 * X2 * X4 + H4^2 * X1 * X3 * X4 - 3 * H4^2 * X1 * X4^2 + H4^2 * X2 * X3 * X4 - H4^2 * X3 * X4^2 - H4 * X1 * X2 * Y2 - H4 * X1 * X2 * Y3 + 2 * H4 * X1 * X2 * Y4 + 2 * H4 * X1 * X4 * Y2 + H4 * X1 * X4 * Y3 - 3 * H4 * X1 * X4 * Y4 - H4 * X2^2 * Y1 - H4 * X2^2 * Y2 - H4 * X2 * X3 * Y1 + H4 * X2 * X3 * Y4 + 4 * H4 * X2 * X4 * Y1 + 3 * H4 * X2 * X4 * Y2 + H4 * X2 * X4 * Y3 + 2 * H4 * X2 * X4 * Y4 + H4 * X3 * X4 * Y1 - H4 * X3 * X4 * Y4 - 3 * H4 * X4^2 * Y1 - H4 * X4^2 * Y2 - H4 * X4^2 * Y3 - 3 * H4 * X4^2 * Y4 - X2 * Y1 * Y2 - X2 * Y1 * Y3 + 2 * X2 * Y1 * Y4 - X2 * Y2^2 - X2 * Y2 * Y3 + 2 * X2 * Y2 * Y4 + 2 * X2 * Y3 * Y4 + 2 * X2 * Y4^2 + 2 * X4 * Y1 * Y2 + X4 * Y1 * Y3 - 3 * X4 * Y1 * Y4 + 2 * X4 * Y2^2 + 2 * X4 * Y2 * Y3 - 2 * X4 * Y2 * Y4 - 3 * X4 * Y3 * Y4 - 3 * X4 * Y4^2, E3 * H2 * Y3 - E3 * H2 * Y4 - E3 * H3 * H4 * Y3 + E3 * H3 * H4 * Y4 - E3 * H4^2 * X4 * Y3 + E3 * H4^2 * X4 * Y4 - E3 * H4 * Y3 * Y4 + E3 * H4 * Y4^2 + E4 * H3^2 * Y3 - E4 * H3^2 * Y4 + E4 * H3 * H4 * X4 * Y3 - E4 * H3 * H4 * X4 * Y4 + 4 * E4 * H3 * Y3 * Y4 - 4 * E4 * H3 * Y4^2 + E4 * H4 * X3 * Y2 * Y3 - E4 * H4 * X3 * Y2 * Y4 - E4 * H4 * X3 * Y3^2 + E4 * H4 * X3 * Y3 * Y4 - 2 * E4 * H4 * X4 * Y2 * Y3 + 2 * E4 * H4 * X4 * Y2 * Y4 + E4 * H4 * X4 * Y3^2 + 2 * E4 * H4 * X4 * Y3 * Y4 - 3 * E4 * H4 * X4 * Y4^2 - E4 * Y3^3 + 3 * E4 * Y3^2 * Y4 + E4 * Y3 * Y4^2 - 3 * E4 * Y4^3 + H3^2 * X3 - H3^2 * X4 - H3 * H4 * X3^2 + 5 * H3 * H4 * X3 * X4 - 4 * H3 * H4 * X4^2 - H3 * X3 * Y3 + 5 * H3 * X3 * Y4 + 3 * H3 * X4 * Y3 - 7 * H3 * X4 * Y4 - H4^2 * X1 * X2 * X3 + H4^2 * X1 * X2 * X4 - H4^2 * X1 * X3^2 + 4 * H4^2 * X1 * X3 * X4 - 3 * H4^2 * X1 * X4^2 + H4^2 * X2 * X3 * X4 - H4^2 * X2 * X4^2 - H4 * X1 * X3 * Y2 - H4 * X1 * X3 * Y3 + 2 * H4 * X1 * X3 * Y4 + H4 * X1 * X4 * Y2 + 2 * H4 * X1 * X4 * Y3 - 3 * H4 * X1 * X4 * Y4 - H4 * X2 * X3 * Y1 + H4 * X2 * X3 * Y4 + H4 * X2 * X4 * Y1 - H4 * X2 * X4 * Y4 - H4 * X3^2 * Y1 - H4 * X3^2 * Y3 + 4 * H4 * X3 * X4 * Y1 + H4 * X3 * X4 * Y2 + 3 * H4 * X3 * X4 * Y3 + 2 * H4 * X3 * X4 * Y4 - 3 * H4 * X4^2 * Y1 - H4 * X4^2 * Y2 - H4 * X4^2 * Y3 - 3 * H4 * X4^2 * Y4 - X3 * Y1 * Y2 - X3 * Y1 * Y3 + 2 * X3 * Y1 * Y4 - X3 * Y2 * Y3 + 2 * X3 * Y2 * Y4 - X3 * Y3^2 + 2 * X3 * Y3 * Y4 + 2 * X3 * Y4^2 + X4 * Y1 * Y2 + 2 * X4 * Y1 * Y3 - 3 * X4 * Y1 * Y4 + 2 * X4 * Y2 * Y3 - 3 * X4 * Y2 * Y4 + 2 * X4 * Y3^2 - 2 * X4 * Y3 * Y4 - 3 * X4 * Y4^2, E3 * H4 * X1 * Y1 - E3 * H4 * X1 * Y4 - E3 * H4 * X4 * Y1 + E3 * H4 * X4 * Y4 + E3 * Y1^2 - 2 * E3 * Y1 * Y4 + E3 * Y4^2 - E4 * H3 * X1 * Y1 + E4 * H3 * X1 * Y4 + E4 * H3 * X4 * Y1 - E4 * H3 * X4 * Y4 - 2 * E4 * X1 * Y1 * Y4 - E4 * X1 * Y2 * Y3 + E4 * X1 * Y2 * Y4 + E4 * X1 * Y3 * Y4 + E4 * X1 * Y4^2 + E4 * X4 * Y1^2 + E4 * X4 * Y2 * Y3 - E4 * X4 * Y2 * Y4 - E4 * X4 * Y3 * Y4 - H3 * X1^2 + 2 * H3 * X1 * X4 - H3 * X4^2 - H4 * X1^2 * X4 - H4 * X1 * X2 * X3 + H4 * X1 * X2 * X4 + H4 * X1 * X3 * X4 + H4 * X1 * X4^2 + H4 * X2 * X3 * X4 - H4 * X2 * X4^2 - H4 * X3 * X4^2 - 2 * X1^2 * Y4 - X1 * X2 * Y3 + X1 * X2 * Y4 - X1 * X3 * Y2 + X1 * X3 * Y4 + X1 * X4 * Y2 + X1 * X4 * Y3 + 2 * X1 * X4 * Y4 + X2 * X4 * Y3 - X2 * X4 * Y4 + X3 * X4 * Y2 - X3 * X4 * Y4 - X4^2 * Y2 - X4^2 * Y3, E3 * H4 * X2 * Y1 - E3 * H4 * X2 * Y4 - E3 * H4 * X4 * Y1 + E3 * H4 * X4 * Y4 + E3 * Y1 * Y2 - E3 * Y1 * Y4 - E3 * Y2 * Y4 + E3 * Y4^2 - E4 * H3 * X2 * Y1 + E4 * H3 * X2 * Y4 + E4 * H3 * X4 * Y1 - E4 * H3 * X4 * Y4 - E4 * X2 * Y1^2 + E4 * X2 * Y4^2 + E4 * X4 * Y1^2 + E4 * X4 * Y2 * Y3 - E4 * X4 * Y2 * Y4 - E4 * X4 * Y3 * Y4 - H3 * X1 * X2 + H3 * X1 * X4 + H3 * X2 * X4 - H3 * X4^2 - H4 * X1 * X2^2 + H4 * X1 * X4^2 + H4 * X2^2 * X4 + H4 * X2 * X3 * X4 - H4 * X2 * X4^2 - H4 * X3 * X4^2 - X1 * X2 * Y1 - X1 * X2 * Y2 + X1 * X4 * Y1 + X1 * X4 * Y4 + X2 * X4 * Y2 + X2 * X4 * Y3 + X3 * X4 * Y2 - X3 * X4 * Y4 - X4^2 * Y2 - X4^2 * Y3, E3 * H4 * X2 * Y2 - E3 * H4 * X2 * Y4 - E3 * H4 * X4 * Y2 + E3 * H4 * X4 * Y4 + E3 * Y2^2 - 2 * E3 * Y2 * Y4 + E3 * Y4^2 - E4 * H3 * X2 * Y2 + E4 * H3 * X2 * Y4 + E4 * H3 * X4 * Y2 - E4 * H3 * X4 * Y4 - E4 * X2 * Y2 * Y3 - E4 * X2 * Y2 * Y4 + E4 * X2 * Y3 * Y4 + E4 * X2 * Y4^2 + E4 * X4 * Y2^2 + E4 * X4 * Y2 * Y3 - E4 * X4 * Y2 * Y4 - E4 * X4 * Y3 * Y4 - H3 * X2^2 + 2 * H3 * X2 * X4 - H3 * X4^2 - H4 * X2^2 * X3 + 2 * H4 * X2 * X3 * X4 - H4 * X3 * X4^2 - X2^2 * Y3 - X2^2 * Y4 - X2 * X3 * Y2 + X2 * X3 * Y4 + X2 * X4 * Y2 + 2 * X2 * X4 * Y3 + X2 * X4 * Y4 + X3 * X4 * Y2 - X3 * X4 * Y4 - X4^2 * Y2 - X4^2 * Y3, E3 * H4 * X3 * Y1 - E3 * H4 * X3 * Y4 - E3 * H4 * X4 * Y1 + E3 * H4 * X4 * Y4 + E3 * Y1 * Y3 - E3 * Y1 * Y4 - E3 * Y3 * Y4 + E3 * Y4^2 - E4 * H3 * X3 * Y1 + E4 * H3 * X3 * Y4 + E4 * H3 * X4 * Y1 - E4 * H3 * X4 * Y4 - E4 * X3 * Y1^2 + E4 * X3 * Y4^2 + E4 * X4 * Y1^2 + E4 * X4 * Y2 * Y3 - E4 * X4 * Y2 * Y4 - E4 * X4 * Y3 * Y4 - H3 * X1 * X3 + H3 * X1 * X4 + H3 * X3 * X4 - H3 * X4^2 - H4 * X1 * X3^2 + H4 * X1 * X4^2 + H4 * X2 * X3 * X4 - H4 * X2 * X4^2 + H4 * X3^2 * X4 - H4 * X3 * X4^2 - X1 * X3 * Y1 - X1 * X3 * Y3 + X1 * X4 * Y1 + X1 * X4 * Y4 + X2 * X4 * Y3 - X2 * X4 * Y4 + X3 * X4 * Y2 + X3 * X4 * Y3 - X4^2 * Y2 - X4^2 * Y3, E3 * H4 * X3 * Y2 - E3 * H4 * X3 * Y4 - E3 * H4 * X4 * Y2 + E3 * H4 * X4 * Y4 + E3 * Y2 * Y3 - E3 * Y2 * Y4 - E3 * Y3 * Y4 + E3 * Y4^2 - E4 * H3 * X3 * Y2 + E4 * H3 * X3 * Y4 + E4 * H3 * X4 * Y2 - E4 * H3 * X4 * Y4 - E4 * X3 * Y2^2 + E4 * X3 * Y4^2 + E4 * X4 * Y2^2 + E4 * X4 * Y2 * Y3 - E4 * X4 * Y2 * Y4 - E4 * X4 * Y3 * Y4 - H3 * X2 * X3 + H3 * X2 * X4 + H3 * X3 * X4 - H3 * X4^2 - H4 * X2 * X3^2 + H4 * X2 * X3 * X4 + H4 * X3^2 * X4 - H4 * X3 * X4^2 - X2 * X3 * Y2 - X2 * X3 * Y3 + X2 * X4 * Y2 + X2 * X4 * Y3 + X3 * X4 * Y2 + X3 * X4 * Y3 - X4^2 * Y2 - X4^2 * Y3, E3 * H4 * X3 * Y3 - E3 * H4 * X3 * Y4 - E3 * H4 * X4 * Y3 + E3 * H4 * X4 * Y4 + E3 * Y3^2 - 2 * E3 * Y3 * Y4 + E3 * Y4^2 - E4 * H3 * X3 * Y3 + E4 * H3 * X3 * Y4 + E4 * H3 * X4 * Y3 - E4 * H3 * X4 * Y4 - E4 * X3 * Y2 * Y3 + E4 * X3 * Y2 * Y4 - E4 * X3 * Y3 * Y4 + E4 * X3 * Y4^2 + E4 * X4 * Y2 * Y3 - E4 * X4 * Y2 * Y4 + E4 * X4 * Y3^2 - E4 * X4 * Y3 * Y4 - H3 * X3^2 + 2 * H3 * X3 * X4 - H3 * X4^2 - H4 * X2 * X3^2 + 2 * H4 * X2 * X3 * X4 - H4 * X2 * X4^2 - X2 * X3 * Y3 + X2 * X3 * Y4 + X2 * X4 * Y3 - X2 * X4 * Y4 - X3^2 * Y2 - X3^2 * Y4 + 2 * X3 * X4 * Y2 + X3 * X4 * Y3 + X3 * X4 * Y4 - X4^2 * Y2 - X4^2 * Y3, E4 * H2 * Y1 - E4 * H2 * Y4 + E4 * H4 * Y1 * Y4 + E4 * H4 * Y2 * Y3 - E4 * H4 * Y2 * Y4 - E4 * H4 * Y3 * Y4 - H3 * H4 * X1 + H3 * H4 * X4 - 2 * H3 * Y1 + 2 * H3 * Y4 - H4^2 * X1 * X2 - H4^2 * X1 * X3 + H4^2 * X1 * X4 + H4^2 * X2 * X3 - H4 * X1 * Y1 - H4 * X1 * Y2 - H4 * X1 * Y3 + H4 * X1 * Y4 - H4 * X2 * Y1 + H4 * X2 * Y3 - H4 * X3 * Y1 + H4 * X3 * Y2 + H4 * X4 * Y1 + H4 * X4 * Y4 - Y1^2 - Y1 * Y2 - Y1 * Y3 + Y2 * Y4 + Y3 * Y4 + Y4^2, H1 + H2 * X4 + H3 * Y4 + H4 * X4 * Y4 + Y4^2, H2 * X1 - H2 * X4 + H3 * Y1 - H3 * Y4 + H4 * X1 * Y1 - H4 * X4 * Y4 + Y1^2 - Y4^2, H2 * X2 - H2 * X4 + H3 * Y2 - H3 * Y4 + H4 * X2 * Y2 - H4 * X4 * Y4 + Y2^2 - Y4^2, H2 * X3 - H2 * X4 + H3 * Y3 - H3 * Y4 + H4 * X3 * Y3 - H4 * X4 * Y4 + Y3^2 - Y4^2, H3 * X2 * Y3 - H3 * X2 * Y4 - H3 * X3 * Y2 + H3 * X3 * Y4 + H3 * X4 * Y2 - H3 * X4 * Y3 - H4 * X2 * X3 * Y2 + H4 * X2 * X3 * Y3 + H4 * X2 * X4 * Y2 - H4 * X2 * X4 * Y4 - H4 * X3 * X4 * Y3 + H4 * X3 * X4 * Y4 + X2 * Y3^2 - X2 * Y4^2 - X3 * Y2^2 + X3 * Y4^2 + X4 * Y2^2 - X4 * Y3^2, H3 * X1 * Y3 - H3 * X1 * Y4 - H3 * X3 * Y1 + H3 * X3 * Y4 + H3 * X4 * Y1 - H3 * X4 * Y3 - H4 * X1 * X3 * Y1 + H4 * X1 * X3 * Y3 + H4 * X1 * X4 * Y1 - H4 * X1 * X4 * Y4 - H4 * X3 * X4 * Y3 + H4 * X3 * X4 * Y4 + X1 * Y3^2 - X1 * Y4^2 - X3 * Y1^2 + X3 * Y4^2 + X4 * Y1^2 - X4 * Y3^2, H3 * X1 * Y2 - H3 * X1 * Y4 - H3 * X2 * Y1 + H3 * X2 * Y4 + H3 * X4 * Y1 - H3 * X4 * Y2 - H4 * X1 * X2 * Y1 + H4 * X1 * X2 * Y2 + H4 * X1 * X4 * Y1 - H4 * X1 * X4 * Y4 - H4 * X2 * X4 * Y2 + H4 * X2 * X4 * Y4 + X1 * Y2^2 - X1 * Y4^2 - X2 * Y1^2 + X2 * Y4^2 + X4 * Y1^2 - X4 * Y2^2, E3 * X2 * Y3 - E3 * X2 * Y4 - E3 * X3 * Y2 + E3 * X3 * Y4 + E3 * X4 * Y2 - E3 * X4 * Y3 - E4 * X2 * X3 * Y2 + E4 * X2 * X3 * Y3 + E4 * X2 * X4 * Y2 - E4 * X2 * X4 * Y4 - E4 * X3 * X4 * Y3 + E4 * X3 * X4 * Y4 - X2^2 * X3 + X2^2 * X4 + X2 * X3^2 - X2 * X4^2 - X3^2 * X4 + X3 * X4^2, E3 * X1 * Y3 - E3 * X1 * Y4 - E3 * X3 * Y1 + E3 * X3 * Y4 + E3 * X4 * Y1 - E3 * X4 * Y3 - E4 * X1 * X3 * Y1 + E4 * X1 * X3 * Y3 + E4 * X1 * X4 * Y1 - E4 * X1 * X4 * Y4 - E4 * X3 * X4 * Y3 + E4 * X3 * X4 * Y4 - X1^2 * X3 + X1^2 * X4 + X1 * X3^2 - X1 * X4^2 - X3^2 * X4 + X3 * X4^2, E3 * X1 * Y2 - E3 * X1 * Y4 - E3 * X2 * Y1 + E3 * X2 * Y4 + E3 * X4 * Y1 - E3 * X4 * Y2 - E4 * X1 * X2 * Y1 + E4 * X1 * X2 * Y2 + E4 * X1 * X4 * Y1 - E4 * X1 * X4 * Y4 - E4 * X2 * X4 * Y2 + E4 * X2 * X4 * Y4 - X1^2 * X2 + X1^2 * X4 + X1 * X2^2 - X1 * X4^2 - X2^2 * X4 + X2 * X4^2, H4 * X1 * X2 * Y1 * Y3 - H4 * X1 * X2 * Y1 * Y4 - H4 * X1 * X2 * Y2 * Y3 + H4 * X1 * X2 * Y2 * Y4 - H4 * X1 * X3 * Y1 * Y2 + H4 * X1 * X3 * Y1 * Y4 + H4 * X1 * X3 * Y2 * Y3 - H4 * X1 * X3 * Y3 * Y4 + H4 * X1 * X4 * Y1 * Y2 - H4 * X1 * X4 * Y1 * Y3 - H4 * X1 * X4 * Y2 * Y4 + H4 * X1 * X4 * Y3 * Y4 + H4 * X2 * X3 * Y1 * Y2 - H4 * X2 * X3 * Y1 * Y3 - H4 * X2 * X3 * Y2 * Y4 + H4 * X2 * X3 * Y3 * Y4 - H4 * X2 * X4 * Y1 * Y2 + H4 * X2 * X4 * Y1 * Y4 + H4 * X2 * X4 * Y2 * Y3 - H4 * X2 * X4 * Y3 * Y4 + H4 * X3 * X4 * Y1 * Y3 - H4 * X3 * X4 * Y1 * Y4 - H4 * X3 * X4 * Y2 * Y3 + H4 * X3 * X4 * Y2 * Y4 - X1 * Y2^2 * Y3 + X1 * Y2^2 * Y4 + X1 * Y2 * Y3^2 - X1 * Y2 * Y4^2 - X1 * Y3^2 * Y4 + X1 * Y3 * Y4^2 + X2 * Y1^2 * Y3 - X2 * Y1^2 * Y4 - X2 * Y1 * Y3^2 + X2 * Y1 * Y4^2 + X2 * Y3^2 * Y4 - X2 * Y3 * Y4^2 - X3 * Y1^2 * Y2 + X3 * Y1^2 * Y4 + X3 * Y1 * Y2^2 - X3 * Y1 * Y4^2 - X3 * Y2^2 * Y4 + X3 * Y2 * Y4^2 + X4 * Y1^2 * Y2 - X4 * Y1^2 * Y3 - X4 * Y1 * Y2^2 + X4 * Y1 * Y3^2 + X4 * Y2^2 * Y3 - X4 * Y2 * Y3^2, E4 * Y2^2 * Y3 - E4 * Y2^2 * Y4 - E4 * Y2 * Y3^2 + E4 * Y2 * Y4^2 + E4 * Y3^2 * Y4 - E4 * Y3 * Y4^2 + H4 * X1 * X2 * Y3 - H4 * X1 * X2 * Y4 - H4 * X1 * X3 * Y2 + H4 * X1 * X3 * Y4 + H4 * X1 * X4 * Y2 - H4 * X1 * X4 * Y3 + H4 * X2 * X3 * Y2 - H4 * X2 * X3 * Y3 - H4 * X2 * X4 * Y2 + H4 * X2 * X4 * Y4 + H4 * X3 * X4 * Y3 - H4 * X3 * X4 * Y4 + X2 * Y1 * Y3 - X2 * Y1 * Y4 + X2 * Y2 * Y3 - X2 * Y2 * Y4 - X2 * Y3^2 + X2 * Y4^2 - X3 * Y1 * Y2 + X3 * Y1 * Y4 + X3 * Y2^2 - X3 * Y2 * Y3 + X3 * Y3 * Y4 - X3 * Y4^2 + X4 * Y1 * Y2 - X4 * Y1 * Y3 - X4 * Y2^2 + X4 * Y2 * Y4 + X4 * Y3^2 - X4 * Y3 * Y4, E4 * H3 * Y2 * Y3 - E4 * H3 * Y2 * Y4 - E4 * H3 * Y3 * Y4 + E4 * H3 * Y4^2 + E4 * H4 * X4 * Y2 * Y3 - E4 * H4 * X4 * Y2 * Y4 - E4 * H4 * X4 * Y3 * Y4 + E4 * H4 * X4 * Y4^2 + E4 * Y2 * Y3^2 - E4 * Y2 * Y4^2 - E4 * Y3^2 * Y4 + E4 * Y4^3 + H3 * H4 * X2 * X3 - H3 * H4 * X2 * X4 - H3 * H4 * X3 * X4 + H3 * H4 * X4^2 + 2 * H3 * X3 * Y2 - 2 * H3 * X3 * Y4 - 2 * H3 * X4 * Y2 + 2 * H3 * X4 * Y4 + H4^2 * X1 * X2 * X3 - H4^2 * X1 * X2 * X4 - H4^2 * X1 * X3 * X4 + H4^2 * X1 * X4^2 + H4 * X1 * X3 * Y2 - H4 * X1 * X3 * Y4 - H4 * X1 * X4 * Y2 + H4 * X1 * X4 * Y4 + H4 * X2 * X3 * Y1 + H4 * X2 * X3 * Y2 - H4 * X2 * X4 * Y1 - H4 * X2 * X4 * Y2 - H4 * X3 * X4 * Y1 - H4 * X3 * X4 * Y4 + H4 * X4^2 * Y1 + H4 * X4^2 * Y4 + X3 * Y1 * Y2 - X3 * Y1 * Y4 + X3 * Y2^2 + X3 * Y2 * Y3 - X3 * Y3 * Y4 - X3 * Y4^2 - X4 * Y1 * Y2 + X4 * Y1 * Y4 - X4 * Y2^2 - X4 * Y2 * Y3 + X4 * Y3 * Y4 + X4 * Y4^2, E3 * E4 * Y2 * Y3 - E3 * E4 * Y2 * Y4 - E3 * E4 * Y3 * Y4 + E3 * E4 * Y4^2 + E3 * H4 * X2 * X3 - E3 * H4 * X2 * X4 - E3 * H4 * X3 * X4 + E3 * H4 * X4^2 + 2 * E3 * X3 * Y2 - 2 * E3 * X3 * Y4 - 2 * E3 * X4 * Y2 + 2 * E3 * X4 * Y4 + E4^2 * X4 * Y2 * Y3 - E4^2 * X4 * Y2 * Y4 - E4^2 * X4 * Y3 * Y4 + E4^2 * X4 * Y4^2 + E4 * H4 * X1 * X2 * X3 - E4 * H4 * X1 * X2 * X4 - E4 * H4 * X1 * X3 * X4 + E4 * H4 * X1 * X4^2 + E4 * X2 * X3 * Y2 - E4 * X2 * X3 * Y3 - E4 * X2 * X4 * Y2 + E4 * X2 * X4 * Y3 + E4 * X3 * X4 * Y2 + E4 * X3 * X4 * Y3 - 2 * E4 * X3 * X4 * Y4 - E4 * X4^2 * Y2 - E4 * X4^2 * Y3 + 2 * E4 * X4^2 * Y4 - X1 * X2 * X3 + X1 * X2 * X4 + X1 * X3 * X4 - X1 * X4^2 + X2^2 * X3 - X2^2 * X4 - X2 * X3^2 + X2 * X3 * X4 + X3^2 * X4 - 2 * X3 * X4^2 + X4^3, E4 * Y1 * Y3 - E4 * Y1 * Y4 - E4 * Y2 * Y3 + E4 * Y2 * Y4 + H4 * X1 * X3 - H4 * X1 * X4 - H4 * X2 * X3 + H4 * X2 * X4 + X1 * Y3 - X1 * Y4 - X2 * Y3 + X2 * Y4 + X3 * Y1 - X3 * Y2 - X4 * Y1 + X4 * Y2, E4 * H2 * Y3 - E4 * H2 * Y4 + E4 * H4 * Y2 * Y3 - E4 * H4 * Y2 * Y4 - H3 * H4 * X3 + H3 * H4 * X4 - 2 * H3 * Y3 + 2 * H3 * Y4 - H4^2 * X1 * X3 + H4^2 * X1 * X4 - H4 * X1 * Y3 + H4 * X1 * Y4 - H4 * X3 * Y1 - H4 * X3 * Y3 + H4 * X4 * Y1 + H4 * X4 * Y4 - Y1 * Y3 + Y1 * Y4 - Y2 * Y3 + Y2 * Y4 - Y3^2 + Y4^2, E3 * E4 * H4 * Y3 - E3 * E4 * H4 * Y4 - E3 * H4 * X3 + E3 * H4 * X4 - 2 * E3 * Y3 + 2 * E3 * Y4 - E4^2 * H3 * Y3 + E4^2 * H3 * Y4 - E4^2 * Y3^2 + E4^2 * Y4^2 - E4 * H3 * X3 + E4 * H3 * X4 - E4 * H4 * X1 * X3 + E4 * H4 * X1 * X4 - E4 * H4 * X2 * X3 + E4 * H4 * X2 * X4 - 2 * E4 * X3 * Y3 + 2 * E4 * X4 * Y4 + X1 * X3 - X1 * X4 + X2 * X3 - X2 * X4 - X3^2 + X4^2, E3 * H4^2 * X3 - E3 * H4^2 * X4 + E3 * H4 * Y3 - E3 * H4 * Y4 - E4 * H3 * H4 * X3 + E4 * H3 * H4 * X4 + E4 * H3 * Y3 - E4 * H3 * Y4 - E4 * H4 * X3 * Y1 - E4 * H4 * X3 * Y2 + E4 * H4 * X3 * Y3 - E4 * H4 * X3 * Y4 + E4 * H4 * X4 * Y1 + E4 * H4 * X4 * Y2 + E4 * H4 * X4 * Y3 - E4 * H4 * X4 * Y4 + E4 * Y3^2 - E4 * Y4^2 + 2 * H3 * X3 - 2 * H3 * X4 + H4 * X3^2 - H4 * X4^2 + X3 * Y1 + X3 * Y2 + X3 * Y3 + X3 * Y4 - X4 * Y1 - X4 * Y2 - X4 * Y3 - X4 * Y4, E4 * H3 * Y3^2 - 2 * E4 * H3 * Y3 * Y4 + E4 * H3 * Y4^2 - E4 * H4 * X3 * Y2 * Y3 + E4 * H4 * X3 * Y2 * Y4 + E4 * H4 * X3 * Y3^2 - E4 * H4 * X3 * Y3 * Y4 + E4 * H4 * X4 * Y2 * Y3 - E4 * H4 * X4 * Y2 * Y4 - E4 * H4 * X4 * Y3 * Y4 + E4 * H4 * X4 * Y4^2 + E4 * Y3^3 - E4 * Y3^2 * Y4 - E4 * Y3 * Y4^2 + E4 * Y4^3 + H3 * H4 * X3^2 - 2 * H3 * H4 * X3 * X4 + H3 * H4 * X4^2 + 2 * H3 * X3 * Y3 - 2 * H3 * X3 * Y4 - 2 * H3 * X4 * Y3 + 2 * H3 * X4 * Y4 + H4^2 * X1 * X3^2 - 2 * H4^2 * X1 * X3 * X4 + H4^2 * X1 * X4^2 + H4 * X1 * X3 * Y3 - H4 * X1 * X3 * Y4 - H4 * X1 * X4 * Y3 + H4 * X1 * X4 * Y4 + H4 * X3^2 * Y1 + H4 * X3^2 * Y3 - 2 * H4 * X3 * X4 * Y1 - H4 * X3 * X4 * Y3 - H4 * X3 * X4 * Y4 + H4 * X4^2 * Y1 + H4 * X4^2 * Y4 + X3 * Y1 * Y3 - X3 * Y1 * Y4 + X3 * Y2 * Y3 - X3 * Y2 * Y4 + X3 * Y3^2 - X3 * Y4^2 - X4 * Y1 * Y3 + X4 * Y1 * Y4 - X4 * Y2 * Y3 + X4 * Y2 * Y4 - X4 * Y3^2 + X4 * Y4^2, E3 * E4 * Y3^2 - 2 * E3 * E4 * Y3 * Y4 + E3 * E4 * Y4^2 + E3 * H4 * X3^2 - 2 * E3 * H4 * X3 * X4 + E3 * H4 * X4^2 + 2 * E3 * X3 * Y3 - 2 * E3 * X3 * Y4 - 2 * E3 * X4 * Y3 + 2 * E3 * X4 * Y4 - E4^2 * X3 * Y2 * Y3 + E4^2 * X3 * Y2 * Y4 + E4^2 * X3 * Y3^2 - E4^2 * X3 * Y3 * Y4 + E4^2 * X4 * Y2 * Y3 - E4^2 * X4 * Y2 * Y4 - E4^2 * X4 * Y3 * Y4 + E4^2 * X4 * Y4^2 + E4 * H4 * X1 * X3^2 - 2 * E4 * H4 * X1 * X3 * X4 + E4 * H4 * X1 * X4^2 - E4 * X2 * X3 * Y3 + E4 * X2 * X3 * Y4 + E4 * X2 * X4 * Y3 - E4 * X2 * X4 * Y4 - E4 * X3^2 * Y2 + 2 * E4 * X3^2 * Y3 - E4 * X3^2 * Y4 + 2 * E4 * X3 * X4 * Y2 - E4 * X3 * X4 * Y3 - E4 * X3 * X4 * Y4 - E4 * X4^2 * Y2 - E4 * X4^2 * Y3 + 2 * E4 * X4^2 * Y4 - X1 * X3^2 + 2 * X1 * X3 * X4 - X1 * X4^2 - X2 * X3^2 + 2 * X2 * X3 * X4 - X2 * X4^2 + X3^3 - X3^2 * X4 - X3 * X4^2 + X4^3, E4 * Y1 * Y2 - E4 * Y1 * Y4 - E4 * Y2 * Y3 + E4 * Y3 * Y4 + H4 * X1 * X2 - H4 * X1 * X4 - H4 * X2 * X3 + H4 * X3 * X4 + X1 * Y2 - X1 * Y4 + X2 * Y1 - X2 * Y3 - X3 * Y2 + X3 * Y4 - X4 * Y1 + X4 * Y3, E4 * H2 * Y2 - E4 * H2 * Y4 + E4 * H4 * Y2 * Y3 - E4 * H4 * Y3 * Y4 - H3 * H4 * X2 + H3 * H4 * X4 - 2 * H3 * Y2 + 2 * H3 * Y4 - H4^2 * X1 * X2 + H4^2 * X1 * X4 - H4 * X1 * Y2 + H4 * X1 * Y4 - H4 * X2 * Y1 - H4 * X2 * Y2 + H4 * X4 * Y1 + H4 * X4 * Y4 - Y1 * Y2 + Y1 * Y4 - Y2^2 - Y2 * Y3 + Y3 * Y4 + Y4^2, E3 * H4^2 * X2 - E3 * H4^2 * X4 + E3 * H4 * Y2 - E3 * H4 * Y4 - E4 * H3 * H4 * X2 + E4 * H3 * H4 * X4 + E4 * H3 * Y2 - E4 * H3 * Y4 - E4 * H4 * X2 * Y1 + E4 * H4 * X2 * Y2 - E4 * H4 * X2 * Y3 - E4 * H4 * X2 * Y4 + E4 * H4 * X4 * Y1 + E4 * H4 * X4 * Y2 + E4 * H4 * X4 * Y3 - E4 * H4 * X4 * Y4 + E4 * Y2^2 - E4 * Y4^2 + 2 * H3 * X2 - 2 * H3 * X4 + H4 * X2^2 - H4 * X4^2 + X2 * Y1 + X2 * Y2 + X2 * Y3 + X2 * Y4 - X4 * Y1 - X4 * Y2 - X4 * Y3 - X4 * Y4, E3 * H4^2 * X1 - E3 * H4^2 * X4 + E3 * H4 * Y1 - E3 * H4 * Y4 - E4 * H3 * H4 * X1 + E4 * H3 * H4 * X4 + E4 * H3 * Y1 - E4 * H3 * Y4 + E4 * H4 * X1 * Y1 - E4 * H4 * X1 * Y2 - E4 * H4 * X1 * Y3 - E4 * H4 * X1 * Y4 + E4 * H4 * X4 * Y1 + E4 * H4 * X4 * Y2 + E4 * H4 * X4 * Y3 - E4 * H4 * X4 * Y4 + E4 * Y1^2 - E4 * Y4^2 + 2 * H3 * X1 - 2 * H3 * X4 + H4 * X1^2 - H4 * X4^2 + X1 * Y1 + X1 * Y2 + X1 * Y3 + X1 * Y4 - X4 * Y1 - X4 * Y2 - X4 * Y3 - X4 * Y4, E3 * H2 * H4 - E3 * H3 * H4^2 - E3 * H4^3 * X4 - E3 * H4^2 * Y4 + E4 * H2 * H3 + 2 * E4 * H2 * H4 * X4 + 2 * E4 * H2 * Y4 + E4 * H3^2 * H4 + E4 * H3 * H4^2 * X4 + E4 * H3 * H4 * Y1 + E4 * H3 * H4 * Y2 + E4 * H3 * H4 * Y3 + 2 * E4 * H3 * H4 * Y4 + E4 * H4^2 * X4 * Y1 + E4 * H4^2 * X4 * Y2 + E4 * H4^2 * X4 * Y3 + E4 * H4^2 * X4 * Y4 + 2 * E4 * H4 * Y1 * Y4 + E4 * H4 * Y2 * Y3 + E4 * H4 * Y2 * Y4 + E4 * H4 * Y3 * Y4 + E4 * H4 * Y4^2 - 2 * H3^2 - 4 * H3 * H4 * X4 - H3 * Y1 - H3 * Y2 - H3 * Y3 - 5 * H3 * Y4 + H4^2 * X2 * X3 - H4^2 * X2 * X4 - H4^2 * X3 * X4 - H4^2 * X4^2 + H4 * X2 * Y3 - H4 * X2 * Y4 + H4 * X3 * Y2 - H4 * X3 * Y4 - H4 * X4 * Y1 - 2 * H4 * X4 * Y2 - 2 * H4 * X4 * Y3 - 3 * H4 * X4 * Y4 - 2 * Y1 * Y4 - 2 * Y2 * Y4 - 2 * Y3 * Y4 - 2 * Y4^2, E4 * H2^2 + 2 * E4 * H2 * H4 * Y4 - E4 * H4^2 * Y2 * Y3 + E4 * H4^2 * Y2 * Y4 + E4 * H4^2 * Y3 * Y4 - 2 * H2 * H3 - 2 * H2 * H4 * X4 - H2 * Y1 - H2 * Y2 - H2 * Y3 - H2 * Y4 + H3^2 * H4 + H3 * H4^2 * X1 + H3 * H4^2 * X2 + H3 * H4^2 * X3 - H3 * H4^2 * X4 + 2 * H3 * H4 * Y1 + 2 * H3 * H4 * Y2 + 2 * H3 * H4 * Y3 - 4 * H3 * H4 * Y4 + H4^3 * X1 * X2 + H4^3 * X1 * X3 - H4^3 * X1 * X4 + H4^2 * X1 * Y1 + H4^2 * X1 * Y2 + H4^2 * X1 * Y3 - H4^2 * X1 * Y4 + H4^2 * X2 * Y1 + H4^2 * X2 * Y2 + H4^2 * X3 * Y1 + H4^2 * X3 * Y3 - H4^2 * X4 * Y1 - 3 * H4^2 * X4 * Y4 + H4 * Y1^2 + H4 * Y1 * Y2 + H4 * Y1 * Y3 - H4 * Y1 * Y4 + H4 * Y2^2 + H4 * Y2 * Y3 - H4 * Y2 * Y4 + H4 * Y3^2 - H4 * Y3 * Y4 - 3 * H4 * Y4^2, E3 * E4 * H4 * Y2 - E3 * E4 * H4 * Y4 - E3 * H4 * X2 + E3 * H4 * X4 - 2 * E3 * Y2 + 2 * E3 * Y4 - E4^2 * H3 * Y2 + E4^2 * H3 * Y4 - E4^2 * Y2^2 + E4^2 * Y4^2 - E4 * H3 * X2 + E4 * H3 * X4 - E4 * H4 * X1 * X2 + E4 * H4 * X1 * X4 - E4 * H4 * X2 * X3 + E4 * H4 * X3 * X4 - 2 * E4 * X2 * Y2 + 2 * E4 * X4 * Y4 + X1 * X2 - X1 * X4 - X2^2 + X2 * X3 - X3 * X4 + X4^2, E3 * E4 * H4 * Y1 - E3 * E4 * H4 * Y4 - E3 * H4 * X1 + E3 * H4 * X4 - 2 * E3 * Y1 + 2 * E3 * Y4 - E4^2 * H3 * Y1 + E4^2 * H3 * Y4 - E4^2 * Y1^2 + E4^2 * Y4^2 - E4 * H3 * X1 + E4 * H3 * X4 - E4 * H4 * X1 * X2 - E4 * H4 * X1 * X3 + E4 * H4 * X2 * X4 + E4 * H4 * X3 * X4 - 2 * E4 * X1 * Y1 + 2 * E4 * X4 * Y4 - X1^2 + X1 * X2 + X1 * X3 - X2 * X4 - X3 * X4 + X4^2, 2 * E2 - E3 * E4 * H4^2 - E3 * H4 + 2 * E4^2 * H2 + E4^2 * H3 * H4 + E4^2 * H4 * Y1 + E4^2 * H4 * Y2 + E4^2 * H4 * Y3 + E4^2 * H4 * Y4 - 3 * E4 * H3 - E4 * H4 * X1 - E4 * H4 * X2 - E4 * H4 * X3 - E4 * H4 * X4 - E4 * Y1 - E4 * Y2 - E4 * Y3 - E4 * Y4 + X1 + X2 + X3 + X4, E4 * H3 * Y2^2 - 2 * E4 * H3 * Y2 * Y4 + E4 * H3 * Y4^2 + E4 * H4 * X2 * Y2^2 - E4 * H4 * X2 * Y2 * Y3 - E4 * H4 * X2 * Y2 * Y4 + E4 * H4 * X2 * Y3 * Y4 + E4 * H4 * X4 * Y2 * Y3 - E4 * H4 * X4 * Y2 * Y4 - E4 * H4 * X4 * Y3 * Y4 + E4 * H4 * X4 * Y4^2 + E4 * Y2^3 - E4 * Y2^2 * Y4 - E4 * Y2 * Y4^2 + E4 * Y4^3 + H3 * H4 * X2^2 - 2 * H3 * H4 * X2 * X4 + H3 * H4 * X4^2 + 2 * H3 * X2 * Y2 - 2 * H3 * X2 * Y4 - 2 * H3 * X4 * Y2 + 2 * H3 * X4 * Y4 + H4^2 * X1 * X2^2 - 2 * H4^2 * X1 * X2 * X4 + H4^2 * X1 * X4^2 + H4 * X1 * X2 * Y2 - H4 * X1 * X2 * Y4 - H4 * X1 * X4 * Y2 + H4 * X1 * X4 * Y4 + H4 * X2^2 * Y1 + H4 * X2^2 * Y2 - 2 * H4 * X2 * X4 * Y1 - H4 * X2 * X4 * Y2 - H4 * X2 * X4 * Y4 + H4 * X4^2 * Y1 + H4 * X4^2 * Y4 + X2 * Y1 * Y2 - X2 * Y1 * Y4 + X2 * Y2^2 + X2 * Y2 * Y3 - X2 * Y3 * Y4 - X2 * Y4^2 - X4 * Y1 * Y2 + X4 * Y1 * Y4 - X4 * Y2^2 - X4 * Y2 * Y3 + X4 * Y3 * Y4 + X4 * Y4^2, E4 * H3 * Y1^2 - 2 * E4 * H3 * Y1 * Y4 + E4 * H3 * Y4^2 + E4 * H4 * X1 * Y1^2 - 2 * E4 * H4 * X1 * Y1 * Y4 - E4 * H4 * X1 * Y2 * Y3 + E4 * H4 * X1 * Y2 * Y4 + E4 * H4 * X1 * Y3 * Y4 + E4 * H4 * X4 * Y2 * Y3 - E4 * H4 * X4 * Y2 * Y4 - E4 * H4 * X4 * Y3 * Y4 + E4 * H4 * X4 * Y4^2 + E4 * Y1^3 - E4 * Y1^2 * Y4 - E4 * Y1 * Y4^2 + E4 * Y4^3 + H3 * H4 * X1^2 - 2 * H3 * H4 * X1 * X4 + H3 * H4 * X4^2 + 2 * H3 * X1 * Y1 - 2 * H3 * X1 * Y4 - 2 * H3 * X4 * Y1 + 2 * H3 * X4 * Y4 + H4^2 * X1^2 * X2 + H4^2 * X1^2 * X3 - H4^2 * X1^2 * X4 - H4^2 * X1 * X2 * X3 - H4^2 * X1 * X2 * X4 - H4^2 * X1 * X3 * X4 + H4^2 * X1 * X4^2 + H4^2 * X2 * X3 * X4 + H4 * X1^2 * Y1 + H4 * X1^2 * Y2 + H4 * X1^2 * Y3 - H4 * X1^2 * Y4 + H4 * X1 * X2 * Y1 - H4 * X1 * X2 * Y3 + H4 * X1 * X3 * Y1 - H4 * X1 * X3 * Y2 - 2 * H4 * X1 * X4 * Y1 - H4 * X1 * X4 * Y2 - H4 * X1 * X4 * Y3 - H4 * X2 * X4 * Y1 + H4 * X2 * X4 * Y3 - H4 * X3 * X4 * Y1 + H4 * X3 * X4 * Y2 + H4 * X4^2 * Y1 + H4 * X4^2 * Y4 + X1 * Y1^2 + X1 * Y1 * Y2 + X1 * Y1 * Y3 - X1 * Y2 * Y4 - X1 * Y3 * Y4 - X1 * Y4^2 - X4 * Y1^2 - X4 * Y1 * Y2 - X4 * Y1 * Y3 + X4 * Y2 * Y4 + X4 * Y3 * Y4 + X4 * Y4^2, E3 * E4 * Y2^2 - 2 * E3 * E4 * Y2 * Y4 + E3 * E4 * Y4^2 + E3 * H4 * X2^2 - 2 * E3 * H4 * X2 * X4 + E3 * H4 * X4^2 + 2 * E3 * X2 * Y2 - 2 * E3 * X2 * Y4 - 2 * E3 * X4 * Y2 + 2 * E3 * X4 * Y4 + E4^2 * X2 * Y2^2 - E4^2 * X2 * Y2 * Y3 - E4^2 * X2 * Y2 * Y4 + E4^2 * X2 * Y3 * Y4 + E4^2 * X4 * Y2 * Y3 - E4^2 * X4 * Y2 * Y4 - E4^2 * X4 * Y3 * Y4 + E4^2 * X4 * Y4^2 + E4 * H4 * X1 * X2^2 - 2 * E4 * H4 * X1 * X2 * X4 + E4 * H4 * X1 * X4^2 + 2 * E4 * X2^2 * Y2 - E4 * X2^2 * Y3 - E4 * X2^2 * Y4 - E4 * X2 * X3 * Y2 + E4 * X2 * X3 * Y4 - E4 * X2 * X4 * Y2 + 2 * E4 * X2 * X4 * Y3 - E4 * X2 * X4 * Y4 + E4 * X3 * X4 * Y2 - E4 * X3 * X4 * Y4 - E4 * X4^2 * Y2 - E4 * X4^2 * Y3 + 2 * E4 * X4^2 * Y4 - X1 * X2^2 + 2 * X1 * X2 * X4 - X1 * X4^2 + X2^3 - X2^2 * X3 - X2^2 * X4 + 2 * X2 * X3 * X4 - X2 * X4^2 - X3 * X4^2 + X4^3, E3 * E4 * Y1^2 - 2 * E3 * E4 * Y1 * Y4 + E3 * E4 * Y4^2 + E3 * H4 * X1^2 - 2 * E3 * H4 * X1 * X4 + E3 * H4 * X4^2 + 2 * E3 * X1 * Y1 - 2 * E3 * X1 * Y4 - 2 * E3 * X4 * Y1 + 2 * E3 * X4 * Y4 + E4^2 * X1 * Y1^2 - 2 * E4^2 * X1 * Y1 * Y4 - E4^2 * X1 * Y2 * Y3 + E4^2 * X1 * Y2 * Y4 + E4^2 * X1 * Y3 * Y4 + E4^2 * X4 * Y2 * Y3 - E4^2 * X4 * Y2 * Y4 - E4^2 * X4 * Y3 * Y4 + E4^2 * X4 * Y4^2 + E4 * H4 * X1^2 * X2 + E4 * H4 * X1^2 * X3 - E4 * H4 * X1^2 * X4 - E4 * H4 * X1 * X2 * X3 - E4 * H4 * X1 * X2 * X4 - E4 * H4 * X1 * X3 * X4 + E4 * H4 * X1 * X4^2 + E4 * H4 * X2 * X3 * X4 + 2 * E4 * X1^2 * Y1 - 2 * E4 * X1^2 * Y4 - E4 * X1 * X2 * Y3 + E4 * X1 * X2 * Y4 - E4 * X1 * X3 * Y2 + E4 * X1 * X3 * Y4 - 2 * E4 * X1 * X4 * Y1 + E4 * X1 * X4 * Y2 + E4 * X1 * X4 * Y3 + E4 * X2 * X4 * Y3 - E4 * X2 * X4 * Y4 + E4 * X3 * X4 * Y2 - E4 * X3 * X4 * Y4 - E4 * X4^2 * Y2 - E4 * X4^2 * Y3 + 2 * E4 * X4^2 * Y4 + X1^3 - X1^2 * X2 - X1^2 * X3 - X1^2 * X4 + 2 * X1 * X2 * X4 + 2 * X1 * X3 * X4 - X1 * X4^2 - X2 * X4^2 - X3 * X4^2 + X4^3, E3 * E4 * H4^3 - E3 * H4^2 - 2 * E4^2 * H2 * H4 - E4^2 * H3 * H4^2 - E4^2 * H4^2 * Y1 - E4^2 * H4^2 * Y2 - E4^2 * H4^2 * Y3 - E4^2 * H4^2 * Y4 + 2 * E4 * H2 + 5 * E4 * H3 * H4 + E4 * H4^2 * X1 + E4 * H4^2 * X2 + E4 * H4^2 * X3 + E4 * H4^2 * X4 + 3 * E4 * H4 * Y1 + 3 * E4 * H4 * Y2 + 3 * E4 * H4 * Y3 + 3 * E4 * H4 * Y4 - 4 * H3 - H4 * X1 - H4 * X2 - H4 * X3 - H4 * X4 - 2 * Y1 - 2 * Y2 - 2 * Y3 - 2 * Y4 ]
Index: /trunk/src/ChangeLog
===================================================================
--- /trunk/src/ChangeLog	(revision 14)
+++ /trunk/src/ChangeLog	(revision 14)
@@ -0,0 +1,309 @@
+Sun Dec 21 05:12:56 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp: *** empty log message ***
+
+Sat Dec 20 18:03:29 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp: *** empty log message ***
+
+Tue Dec 16 06:21:44 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp, make-cgb.lisp: *** empty log message ***
+
+Mon Dec 15 23:02:46 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp, svpoly.lisp: *** empty log message ***
+
+Sun Dec 14 23:53:06 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* svpoly.lisp: *** empty log message ***
+
+	* svpoly.lisp, SVpoly.lisp, sv-poly.lisp: Initial revision
+
+Sat Dec 13 16:36:30 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* prover.lisp, string-grobner.lisp, coefficient-ring.lisp, modular.lisp, cgb-lisp.lisp, modular-poly.lisp, make-cgb.lisp:
+	*** empty log message ***
+
+	* modular-poly.lisp: Initial revision
+
+	* poly.lisp, modular.lisp, make-cgb.lisp: *** empty log message ***
+
+	* modular.lisp: Initial revision
+
+	* poly.lisp, poly-gcd.lisp, rat.lisp, dynamics.lisp, ratpoly.lisp, string-grobner.lisp, coefficient-ring.lisp, prover.lisp, grobner.lisp:
+	*** empty log message ***
+
+Fri Dec 12 22:40:37 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp: *** empty log message ***
+
+	* trivial.lisp: Initial revision
+
+	* string-grobner.lisp: *** empty log message ***
+
+Thu Dec 11 23:20:29 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp: *** empty log message ***
+
+Thu Dec 11 05:15:16 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp: *** empty log message ***
+
+Wed Dec 10 06:30:04 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* coefficient-ring.lisp: *** empty log message ***
+
+Tue Dec  9 17:54:13 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp: *** empty log message ***
+
+Sun Dec  7 06:23:34 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* coefficient-ring.lisp, xgcd.lisp, make-cgb.lisp:
+	*** empty log message ***
+
+	* xgcd.lisp: Initial revision
+
+	* coefficient-ring.lisp, parse.lisp, infix.lisp, prover.lisp, cgb-lisp.lisp:
+	*** empty log message ***
+
+Sat Dec  6 23:44:07 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* string-grobner.lisp, prover.lisp, grobner.lisp, colored-poly.lisp, cgb-lisp.lisp, make-cgb.lisp:
+	*** empty log message ***
+
+Fri Dec  5 07:08:00 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* make-cgb.lisp, prover.lisp, cgb-lisp.lisp: *** empty log message ***
+
+Thu Dec  4 07:43:34 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* prover.lisp: *** empty log message ***
+
+	* prover.lisp: Initial revision
+
+	* grobner.lisp, parse.lisp, cgb-lisp.lisp, dynamics.lisp, colored-poly.lisp, division.lisp:
+	*** empty log message ***
+
+Wed Dec  3 06:55:20 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* string-grobner.lisp, parse.lisp, printer.lisp, cgb-lisp.lisp, coefficient-ring.lisp, rat.lisp:
+	*** empty log message ***
+
+Tue Dec  2 23:41:29 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* monom.lisp: *** empty log message ***
+
+Mon Dec  1 07:58:09 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp, string-grobner.lisp, cgb-lisp.lisp, make-cgb.lisp:
+	*** empty log message ***
+
+	* cgb-lisp.lisp: Initial revision
+
+	* example.lisp, make-cgb.lisp, grobner.lisp, string-grobner.lisp:
+	*** empty log message ***
+
+	* example.lisp: Initial revision
+
+	* colored-poly.lisp, grobner.lisp, order.lisp:
+	*** empty log message ***
+
+Sun Nov 30 23:55:40 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp, coefficient-ring.lisp: *** empty log message ***
+
+Sat Nov 29 21:03:56 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* make-cgb.lisp, grobner.lisp: *** empty log message ***
+
+Sat Nov 29 09:51:41 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* coefficient-ring.lisp, infix.lisp, make-cgb.lisp, parse.lisp, ratpoly.lisp, dynamics.lisp, rat.lisp:
+	*** empty log message ***
+
+Fri Nov 28 23:35:54 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* rat.lisp, colored-poly.lisp, grobner.lisp, poly-with-sugar.lisp, division.lisp, poly.lisp, term.lisp, make-cgb.lisp, parse.lisp, string-grobner.lisp, infix.lisp, printer.lisp, monom.lisp, order.lisp, makelist.lisp, defsystem.lisp, dynamics.lisp, ratpoly.lisp, poly-gcd.lisp, coefficient-ring.lisp:
+	*** empty log message ***
+
+	* make-cgb.lisp: Initial revision
+
+	* defsystem.lisp, poly.lisp, colored-poly.lisp, division.lisp, dynamics.lisp, grobner.lisp, parse.lisp, poly-gcd.lisp, poly-with-sugar.lisp, rat.lisp, ratpoly.lisp, string-grobner.lisp, term.lisp, makelist.lisp, printer.lisp, order.lisp, monom.lisp:
+	*** empty log message ***
+
+Thu Nov 27 23:25:11 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* makelist.lisp, dynamics.lisp, division.lisp, coefficient-ring.lisp, parse.lisp, defsystem.lisp, infix.lisp:
+	*** empty log message ***
+
+	* infix.lisp:
+	Defined \[ as prefix operator to be able to read lists [x1,x2,...,xn]
+
+	* infix.lisp: *** empty log message ***
+
+	* infix.lisp: Initial revision
+
+	* grobner.lisp: *** empty log message ***
+
+Wed Nov 26 06:27:35 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp, poly-with-sugar.lisp, poly.lisp, colored-poly.lisp, division.lisp, string-grobner.lisp:
+	*** empty log message ***
+
+Tue Nov 25 23:54:51 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* colored-poly.lisp, division.lisp, grobner.lisp, poly-with-sugar.lisp, coefficient-ring.lisp, defsystem.lisp, ratpoly.lisp, poly.lisp, term.lisp:
+	*** empty log message ***
+
+	* poly-with-sugar.lisp: Initial revision
+
+	* dynamics.lisp, term.lisp: *** empty log message ***
+
+Sun Nov 23 18:57:38 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp, division.lisp, coefficient-ring.lisp, poly.lisp, term.lisp, poly-gcd.lisp, monom.lisp, string-grobner.lisp, ratpoly.lisp, rat.lisp, dynamics.lisp, colored-poly.lisp, defsystem.lisp:
+	*** empty log message ***
+
+	* poly.lisp: Initial revision
+
+	* term.lisp, monom.lisp: *** empty log message ***
+
+	* term.lisp: Initial revision
+
+	* monom.lisp: *** empty log message ***
+
+	* ratpoly.lisp, rat.lisp, printer.lisp, poly-gcd.lisp, parse.lisp, order.lisp, makelist.lisp, dynamics.lisp, division.lisp, coefficient-ring.lisp, colored-poly.lisp, defsystem.lisp, grobner.lisp, monom.lisp, string-grobner.lisp:
+	Initial revision
+
+Sun Oct 26 02:04:56 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp, string-grobner.lisp, order.lisp, defsystem.lisp:
+	*** empty log message ***
+
+	* order.lisp:
+	Changed order functions to return 1, -1 and 0 as opposed to multiple values.
+
+Sat Oct 25 23:41:43 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp, order.lisp, defsystem.lisp, string-grobner.lisp, makelist.lisp:
+	*** empty log message ***
+
+	* grobner.lisp:
+	Functions operating on strings move to string-grobner.lisp
+
+	* grobner.lisp: *** empty log message ***
+
+	* string-grobner.lisp:
+	Extracted interface functions operating on strings from the general Grobner package.
+
+	* string-grobner.lisp: Initial revision
+
+	* TODO: *** empty log message ***
+
+	* TODO: Initial revision
+
+	* grobner.lisp, defsystem.lisp: *** empty log message ***
+
+Thu Oct 23 08:31:41 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp: *** empty log message ***
+
+	* grobner.lisp: Added brief documentation for every exported symbol.
+
+	* grobner.lisp, colored-poly.lisp: *** empty log message ***
+
+Tue Oct 21 09:49:22 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* shash2.lisp: Initial revision
+
+	* grobner.lisp: *** empty log message ***
+
+Tue Sep 23 03:24:27 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* colored-poly-tests.lisp, grobner.lisp: *** empty log message ***
+
+Sun Sep 21 03:23:25 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* defsystem.lisp, colored-poly.lisp: *** empty log message ***
+
+Sat Sep 20 23:20:37 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* grobner.lisp, colored-poly.lisp, defsystem.lisp, colored-poly-tests.lisp, ratpoly.lisp:
+	*** empty log message ***
+
+	* ratpoly.lisp: Initial revision
+
+	* ratpoly-tests.lisp: *** empty log message ***
+
+	* ratpoly-tests.lisp: Initial revision
+
+	* rat.lisp: *** empty log message ***
+
+	* rat.lisp: Initial revision
+
+	* printer.lisp: *** empty log message ***
+
+	* printer.lisp: Initial revision
+
+	* poly1.lisp: *** empty log message ***
+
+	* poly1.lisp: Initial revision
+
+	* poly-gcd.lisp: *** empty log message ***
+
+	* poly-gcd.lisp: Initial revision
+
+	* order.lisp: *** empty log message ***
+
+	* order.lisp: Initial revision
+
+	* ngrobner.lisp: *** empty log message ***
+
+	* ngrobner.lisp: Initial revision
+
+	* monom.lisp: *** empty log message ***
+
+	* monom.lisp: Initial revision
+
+	* makelist.lisp: *** empty log message ***
+
+	* makelist.lisp: Initial revision
+
+	* grobner.lisp, geometry.lisp: *** empty log message ***
+
+	* geometry.lisp: Initial revision
+
+	* division.lisp: *** empty log message ***
+
+	* division.lisp: Initial revision
+
+Tue Aug 19 05:13:35 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* colored-poly.lisp, grobner.lisp, colored-poly-tests.lisp, defsystem.lisp:
+	*** empty log message ***
+
+Mon Aug 18 21:27:54 1997  Marek Rychlik  <marek@garnet.rychliknet.com>
+
+	* colored-poly.lisp, colored-poly-tests.lisp: *** empty log message ***
+
+	* colored-poly-tests.lisp: Initial revision
+
+	* parse.lisp, defsystem.lisp, colored-poly.lisp, grobner.lisp:
+	*** empty log message ***
+
+	* colored-poly.lisp: Initial revision
+
+	* parse.lisp: *** empty log message ***
+
+	* parse.lisp: Initial revision
+
+	* defsystem.lisp: *** empty log message ***
+
+	* defsystem.lisp: Initial revision
+
+	* grobner.lisp: *** empty log message ***
+
+	* grobner.lisp: Initial revision
+
Index: /trunk/src/DEAD_CODE/sugar.lisp
===================================================================
--- /trunk/src/DEAD_CODE/sugar.lisp	(revision 14)
+++ /trunk/src/DEAD_CODE/sugar.lisp	(revision 14)
@@ -0,0 +1,83 @@
+
+
+;;------------------------------------------------------------------------------------------------
+;;
+;; A different implementation of the sugar strategy
+;;
+;;------------------------------------------------------------------------------------------------
+
+(defvar *default-sugar-limit* 4 
+  "The default sugar level which triggers aborting S-polynomial calculation.")
+
+(defun grobner-sugar (F-no-sugar pred start top-reduction-only ring
+				 &optional (sugar-limit *default-sugar-limit*)
+				 &aux (s (1- (length F-no-sugar))) B M F)
+  (declare (fixnum s))
+  (unless (plusp s) (return-from grobner-sugar F-no-sugar)) ;cut startup costs
+  #+debug (debug-cgb "~&GROBNER BASIS - SUGER LIMIT:~d" sugar-limit)
+  #+debug (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
+  #+grobner-check  (when (plusp start)
+		     (grobner-test (subseq F-no-sugar 0 start)
+				   (subseq F-no-sugar 0 start) pred ring))
+  (setf F (mapcar #'(lambda (x) (poly-add-sugar x ring)) F-no-sugar)
+	B (nconc (makelist (list i j) (i 0 (1- start)) (j start s))
+		 (makelist (list i j) (i start (1- s)) (j (1+ i) s)))
+	M (make-hash-table :test #'equal)
+	B (grobner-sugar-sort-pairs B F pred ring))
+  ;;Initialize treated pairs
+  (dotimes (i (1- start))
+    (do ((j (1+ i) (1+ j))) ((>= j start))
+      (setf (gethash (list i j) M) t)))
+  (do ((G F) pair)
+      ((endp B)
+       (setf G (mapcar #'poly-with-sugar-poly G))
+       #+grobner-check(grobner-test G F-no-sugar pred ring)
+       #+debug(debug-cgb "~&GROBNER ENDED WITH SUGAR: ~d" sugar-limit)
+       G)
+    ;;Find a pair with sugar < sugar-limit
+    ;;If no pair found, increase sugar limit and repeat
+    (loop
+     (setf pair (find sugar-limit B :test #'>
+		      :key #'(lambda (p) (spoly-sugar (elt G (first p)) (elt G (second p)) ring))))
+     (cond
+      ((null pair)
+       (incf sugar-limit)
+       #+debug(debug-cgb "~&RAISED SUGAR LEVEL: ~d" sugar-limit))
+      (t
+       (setf B (delete pair B))
+       (return))))
+    (cond
+     ((Criterion-1-with-sugar pair G)
+      #+debug(debug-cgb "[B1]"))
+     ((Criterion-2-with-sugar pair G M)
+      #+debug(debug-cgb "[B2]"))
+     (t
+      (let ((SP  (normal-form-with-sugar (spoly-with-sugar (elt G (first pair))
+							   (elt G (second pair)) pred ring)
+					 G pred top-reduction-only ring
+					 sugar-limit)))
+	(cond
+	 ((poly-with-sugar-zerop SP))
+	 (t
+	  #+debug
+	  (when (>= (poly-with-sugar-sugar SP) sugar-limit)
+	    (debug-cgb "*"))
+	  (setf s (1+ s)
+		(poly-with-sugar-poly SP) (grobner-primitive-part (poly-with-sugar-poly SP) ring)
+		G (nconc G (list SP))
+		B (grobner-sugar-merge-pairs B (makelist (list i s)
+							 (i 0 (1- s)))
+					     G pred ring))
+	  #+debug (debug-cgb "~&Polynomials: ~d; Pairs left: ~d; Treated pairs: ~d;"
+			     (length G) (length B)
+			     (hash-table-count M)))))
+      (setf (gethash pair M) t)))))
+
+
+(defun grobner-sugar-merge-pairs (B C G pred ring)
+  (declare (ignore G pred ring))
+  "Merges lists of critical pairs. It simply nconcs the lists at this time."
+  (nconc B C))
+
+(defun grobner-sugar-sort-pairs (C G pred ring)
+  (grobner-sugar-merge-pairs nil C G pred ring))
Index: /trunk/src/TAGS
===================================================================
--- /trunk/src/TAGS	(revision 14)
+++ /trunk/src/TAGS	(revision 14)
@@ -0,0 +1,619 @@
+
+
+cgb-lisp.lisp,140
+(defpackage "CGB-LISP"22,1268
+(defvar *examples*30,1582
+(defun example 91,3934
+(defun run-example 97,4159
+(defun all-examples 109,4670
+
+
+coefficient-ring.lisp,206
+(defpackage "COEFFICIENT-RING"13,698
+(defstruct ring40,1203
+(defvar *ring-of-integers*59,1995
+(defvar *field-of-rationals*74,2313
+(defun field-modulo-prime 91,2748
+(defvar *coefficient-ring* 110,3437
+
+
+colored-poly.lisp,1755
+(defpackage "COLORED-POLY"11,623
+(defmacro debug-cgb 31,1387
+(defun make-colored-poly 34,1484
+(defun make-colored-poly-list 75,2972
+(defun color-poly-list 81,3235
+(defun color-poly 92,3845
+(defun colored-poly-to-poly 108,4324
+(defun colored-poly-print 117,4678
+(defun colored-poly-print-list 151,6122
+(defun determine 176,6987
+(defun determine-1 202,8365
+(defun determine-white-term 217,9039
+(defun determine-white-term 267,11026
+(defun cond-system-print 337,13993
+(defun cond-print 361,15097
+(defun add-pairs 370,15395
+(defun cond-part 386,16050
+(defun cond-hm 391,16206
+(defun delete-green-polys 399,16461
+(defun grobner-system 406,16738
+(defun reorder-pairs 495,20156
+(defun colored-Criterion-1 515,20953
+(defun colored-Criterion-2 523,21221
+(defun cond-normal-form 542,21810
+(defun cond-spoly 602,24035
+(defun cond-lm 631,25152
+(defun cond-lc 637,25351
+(defun colored-term-times-poly 643,25503
+(defun colored-scalar-times-poly 648,25694
+(defun colored-term* 656,25944
+(defun color* 663,26192
+(defun color+ 673,26460
+(defun color- 684,26769
+(defun colored-poly+ 688,26835
+(defun colored-poly- 711,27645
+(defun colored-term-uminus 734,28423
+(defun colored-minus-poly 738,28582
+(defun string-grobner-system 742,28728
+(defun string-cond 768,29721
+(defun string-cover 779,30276
+(defun saturate-cover 787,30610
+(defun saturate-cond 794,30970
+(defun string-determine 801,31271
+(defun tidy-grobner-system 819,31968
+(defun tidy-pair 827,32225
+(defun tidy-cond 848,32948
+(defun colored-reduction 854,33203
+(defun green-reduce-colored-poly 901,34882
+(defun green-reduce-colored-list 914,35404
+(defun cond-system-green-reduce 925,35756
+(defun parse-to-colored-poly-list 936,36089
+(defun red-reduction 949,36823
+
+
+division.lisp,86
+(defpackage "DIVISION"11,618
+(defun divide 20,879
+(defun poly-exact-divide 47,1882
+
+
+dynamics.lisp,1057
+(defpackage "DYNAMICS"13,690
+(defun poly-scalar-composition 33,1365
+(defun poly-composition 44,1831
+(defun poly-dynamic-power 52,2235
+(defun poly-scalar-evaluate 58,2504
+(defun poly-evaluate 75,2944
+(defun factorial 79,3142
+(defun poly-scalar-diff 84,3295
+(defun poly-diff 92,3616
+(defun scalar-partial 98,3851
+(defun partial 103,4055
+(defun determinant 110,4313
+(defun minor 125,4806
+(defun drop-row 129,4985
+(defun drop-column 133,5080
+(defun drop-elt 137,5207
+(defun matrix- 143,5350
+(defun scalar-times-matrix 147,5512
+(defun monom-times-matrix 151,5670
+(defun term-times-matrix 155,5826
+(defun poly-list- 161,6016
+(defun scalar-times-poly-list 166,6208
+(defun monom-times-poly-list 171,6379
+(defun term-times-poly-list 176,6553
+(defun characteristic-combination 184,6817
+(defun characteristic-combination-poly-list 195,7401
+(defun characteristic-matrix 206,7945
+(defun characteristic-polynomial 219,8540
+(defun identity-matrix 228,9020
+(defun print-matrix 237,9403
+(defun jacobi-matrix 242,9587
+(defun jacobian 248,9836
+
+
+example.lisp,137
+(defpackage "CGB-LISP"12,618
+(defun example 22,979
+(defun run-example 28,1204
+(defun all-examples 39,1672
+(defvar *examples*47,1869
+
+
+grobner.lisp,3523
+(defpackage "GROBNER"12,688
+(defvar *grobner-debug* 61,1702
+(defvar *buchberger-merge-pairs* 64,1780
+(defvar *gebauer-moeller-merge-pairs* 68,1983
+(defvar *grobner-function* 72,2202
+(defun select-grobner-algorithm 75,2304
+(defun grobner 87,2752
+(defmacro debug-cgb 109,3873
+(defun spoly 117,4228
+(defun grobner-primitive-part 136,4864
+(defun grobner-content 154,5326
+(defun normal-form 163,5686
+(defun buchberger 206,7541
+(defun grobner-op 255,9601
+(defun buchberger-sort-pairs 319,11390
+(defun mock-spoly 329,11801
+(defun buchberger-merge-pairs-use-mock-spoly 350,12550
+(defun buchberger-merge-pairs-smallest-lcm 374,13648
+(defun buchberger-merge-pairs-use-smallest-degree 390,14422
+(defun buchberger-merge-pairs-use-smallest-length 400,14893
+(defun buchberger-merge-pairs-use-smallest-coefficient-length 410,15353
+(defun buchberger-set-pair-heuristic423,15932
+(defun Criterion-1 442,16800
+(defun Criterion-2 450,17126
+(defun normalize-poly 473,18102
+(defun normalize-basis 484,18516
+(defun reduction 489,18746
+(defun reduced-grobner 513,19421
+(defvar *vars* 523,19847
+(defun monom-depends-p 526,19957
+(defun term-depends-p 531,20107
+(defun poly-depends-p 536,20279
+(defun ring-intersection 540,20430
+(defun elimination-ideal 550,20831
+(defun ideal-intersection 577,21977
+(defun poly-contract 604,22921
+(defun poly-lcm 615,23530
+(defun grobner-gcd 638,24382
+(defun grobner-equal 648,24839
+(defun grobner-subsetp 654,25130
+(defun grobner-member 660,25459
+(defun ideal-equal 665,25744
+(defun ideal-subsetp 672,26030
+(defun ideal-member 680,26353
+(defun ideal-saturation-1 687,26654
+(defun add-variables 706,27375
+(defun extend-polynomials 717,27757
+(defun saturation-extension 735,28646
+(defun polysaturation-extension 753,29584
+(defun saturation-extension-1 769,30480
+(defun ideal-polysaturation-1 777,30848
+(defun ideal-saturation 787,31374
+(defun ideal-polysaturation 808,32255
+(defun buchberger-criterion 817,32711
+(defun grobner-test 828,33084
+(defun minimization 845,33657
+(defun add-minimized 863,34207
+(defun colon-ideal 872,34569
+(defun colon-ideal-1 894,35317
+(defun pseudo-divide 901,35628
+(defun gebauer-moeller 950,37701
+(defun update 988,39076
+(defun gebauer-moeller-merge-pairs-use-mock-spoly 1034,40708
+(defun gebauer-moeller-merge-pairs-smallest-lcm 1048,41274
+(defun gebauer-moeller-merge-pairs-use-smallest-degree 1059,41725
+(defun gebauer-moeller-merge-pairs-use-smallest-length 1071,42183
+(defun gebauer-moeller-merge-pairs-use-smallest-coefficient-length 1085,42674
+(defun gebauer-moeller-set-pair-heuristic1097,43232
+(defun spoly-sugar 1115,44072
+(defun spoly-with-sugar 1141,45426
+(defun normal-form-with-sugar 1158,46104
+(defun buchberger-with-sugar 1206,48312
+(defun buchberger-with-sugar-merge-pairs 1263,50670
+(defun buchberger-with-sugar-sort-pairs 1297,51929
+(defun Criterion-1-with-sugar 1301,52104
+(defun Criterion-2-with-sugar 1307,52404
+(defun gebauer-moeller-with-sugar 1329,53329
+(defun update-with-sugar 1375,55085
+(defun gebauer-moeller-with-sugar-merge-pairs 1426,57206
+(defun grobner-primitive-part-with-sugar 1449,58069
+(defun cached-normal-form 1457,58377
+(defun cached-grobner-op 1496,59912
+(defun cached-buchberger 1504,60285
+(defun cached-spoly 1552,62246
+(defun cached-monom-times-poly 1568,62832
+(defun cached-normal-form-with-sugar 1581,63327
+(defun cached-buchberger-with-sugar 1631,65617
+(defun cached-poly-with-sugar-op 1694,68276
+(defun cached-monom-times-poly-with-sugar 1697,68455
+
+
+infix.lisp,3615
+(defpackage "INFIX"265,12470
+(defparameter *infix-readtable* 308,14181
+(defparameter *normal-readtable* 309,14235
+(defmacro infix-error 311,14291
+(defun infix-reader 315,14422
+(defun string->prefix 335,15181
+(defun read-infix 344,15473
+(defun read-regular 351,15745
+(defun same-operator-p 360,15959
+(defun same-token-p 363,16011
+(defvar *peeked-token* 370,16159
+(defun read-token 371,16187
+(defun peek-token 375,16292
+(defun fancy-number-format-p 383,16532
+(defun valid-numberp 407,17354
+(defun gather-superiors 421,17735
+(defun get-first-token 442,18658
+(defun apply-token-prefix-operator 450,18882
+(defun get-next-token 456,19085
+(defun apply-token-infix-operator 460,19212
+(defun infix-read-delimited-list 469,19505
+(defparameter *operator-ordering* 489,20255
+(defun operator-lessp 512,20887
+(defparameter *right-associative-operators* 519,21084
+(defun operator-right-associative-p 520,21136
+(defvar *token-operators* 528,21347
+(defvar *token-prefix-operator-table* 529,21378
+(defvar *token-infix-operator-table* 530,21435
+(defun token-operator-p 531,21491
+(defun get-token-prefix-operator 533,21557
+(defun get-token-infix-operator 535,21647
+(define-token-operator and575,22941
+(define-token-operator or577,23026
+(define-token-operator not579,23108
+(define-token-operator if582,23188
+(define-token-operator then604,23868
+(define-token-operator else606,23952
+(define-character-tokenization #\+609,24037
+(define-token-operator +617,24249
+(define-token-operator +=620,24368
+(define-character-tokenization #\-623,24452
+(define-token-operator -631,24664
+(define-token-operator -=634,24789
+(define-character-tokenization #\*637,24873
+(define-token-operator *645,25085
+(define-token-operator *=647,25163
+(define-character-tokenization #\/654,25309
+(define-token-operator /662,25521
+(define-token-operator /=665,25646
+(define-character-tokenization #\^672,25792
+(define-token-operator ^680,26004
+(define-token-operator ^^682,26085
+(define-character-tokenization #\|685,26171
+(define-token-operator \|693,26384
+(define-character-tokenization #\&696,26470
+(define-token-operator \&704,26684
+(define-character-tokenization #\%707,26770
+(define-token-operator \%711,26872
+(define-character-tokenization #\~714,26955
+(define-token-operator \~718,27057
+(define-character-tokenization #\,721,27138
+(define-token-operator \,725,27240
+(define-character-tokenization #\=728,27325
+(define-token-operator ===736,27537
+(define-token-operator ==738,27617
+(define-character-tokenization #\:	745,27750
+(define-token-operator |:=753,28009
+(define-character-tokenization #\<760,28191
+(define-token-operator <771,28502
+(define-token-operator <=773,28580
+(define-token-operator <<775,28661
+(define-character-tokenization #\>778,28744
+(define-token-operator >789,29055
+(define-token-operator >=791,29133
+(define-token-operator >>793,29214
+(define-character-tokenization #\!796,29301
+(define-token-operator !=804,29513
+(define-token-operator !806,29599
+(define-character-tokenization #\[809,29660
+(define-token-operator \[813,29762
+(define-character-tokenization #\(821,30077
+(define-token-operator \(825,30179
+(define-character-tokenization #\]834,30506
+(define-token-operator \]838,30608
+(define-character-tokenization #\)841,30707
+(define-token-operator \)845,30809
+(define-character-tokenization #\$850,30979
+(define-token-operator %infix-end-token%854,31096
+(define-character-tokenization #\;859,31277
+(defun post-process-expression 887,32148
+(defparameter *test-cases*931,33513
+(defun test-infix 1087,40204
+(defun test-infix-case 1096,40476
+
+
+make-cgb.lisp,506
+(defpackage "MAKE-CGB"14,714
+(defvar *save-path* 19,787
+(defvar *cgb-version-string* 21,819
+(defvar *lisp-suffix* 24,972
+(defvar *cgb-packages*25,1045
+(defun package-file 92,3174
+(defun cgb-compile 95,3244
+(defun cgb-load 102,3435
+(defun cgb-load-lisp 112,3730
+(defun cgb-compile-and-load 120,3978
+(defun cgb-go 124,4040
+(defun start-cgb-lisp 128,4094
+(defun cgb-lisp-top-level-read-eval-print-loop 136,4261
+(defun cgb-lisp-banner 141,4410
+(defun cgb-save 148,4563
+(defun cgb-save 161,4916
+
+
+makelist.lisp,398
+(defpackage "MAKELIST"12,619
+(defmacro makelist-1 57,2296
+(defmacro makelist 64,2514
+(defmacro sum 73,2815
+(defmacro summation 76,2878
+(defmacro difference 79,2941
+(defmacro list-of 83,3060
+(defmacro list-of-1 91,3282
+(defmacro union-of 98,3485
+(defmacro union-of-1 106,3725
+(defmacro set-of 114,3944
+(defmacro set-of-1 122,4178
+(defun select 129,4392
+(defun standard-vector 134,4507
+
+
+modular.lisp,209
+(defpackage "MODULAR"13,689
+(defun modular-inverse 22,923
+(defun modular-division 29,1114
+(defvar *inverse-by-lookup-limit* 33,1220
+(defun make-inverse-table 37,1422
+(defun make-modular-division 43,1731
+
+
+modular-poly.lisp,128
+(defpackage "MODULAR-POLY"13,694
+(defun modular-trace 22,939
+(defun modular-trace-1 26,1103
+(defun frobenius-kernel 32,1294
+
+
+monom.lisp,278
+(defpackage "MONOM"11,615
+(defun monom/ 36,1447
+(defun monom* 40,1531
+(defun nmonom* 44,1617
+(defun monom-divides-p 49,1805
+(defun monom-divisible-by-p 53,1925
+(defun monom-rel-prime 57,2058
+(defun monom-equal 61,2216
+(defun monom-lcm 65,2318
+(defun monom-gcd 69,2426
+
+
+order.lisp,246
+(defpackage "ORDER"24,1190
+(defun lex> 41,1496
+(defun total-degree 53,1934
+(defun grlex> 58,2131
+(defun revlex> 70,2546
+(defun grevlex> 85,3169
+(defun invlex> 95,3563
+(defun elimination-order 114,4281
+(defun elimination-order-1 127,4828
+
+
+parse.lisp,608
+(defpackage "PARSE"12,688
+(defun convert-number 52,2312
+(defun $poly+ 60,2674
+(defun $poly- 66,2974
+(defun $minus-poly 72,3279
+(defun $poly* 78,3533
+(defun $poly/ 84,3838
+(defun $poly-expt 91,4086
+(defun parse 97,4350
+(defun alist-form 133,5496
+(defun alist-form-1 145,5921
+(defun powers 156,6254
+(defun parse-to-alist 170,6761
+(defun parse-string-to-alist 181,7217
+(defun parse-to-sorted-alist 194,7750
+(defun parse-string-to-sorted-alist 208,8336
+(defun sort-poly-1 214,8602
+(defun sort-poly 220,8846
+(defun poly-eval-1 233,9389
+(defun poly-eval 257,10410
+(defun monom-basis 274,11309
+
+
+poly-gcd.lisp,281
+(defpackage "POLY-GCD"11,618
+(defun poly-gcd 29,1243
+(defun poly-pseudo-divide 47,1758
+(defun poly-pseudo-remainder 63,2193
+(defun mdeg 67,2315
+(defun lcoeff 70,2412
+(defun lrest 73,2474
+(defun lpart 76,2536
+(defun poly-primitive-part 84,2755
+(defun poly-content 92,2899
+
+
+poly.lisp,509
+(defpackage "POLY"11,614
+(defun scalar-times-poly 45,2025
+(defun term-times-poly 52,2312
+(defun monom-times-poly 56,2510
+(defun minus-poly 60,2674
+(defun sort-poly 65,2916
+(defun poly+ 77,3335
+(defun poly- 101,4095
+(defun poly* 127,4967
+(defun poly-op 138,5487
+(defun poly-expt 144,5714
+(defun poly-mexpt 161,6432
+(defun poly-constant-p 172,6902
+(defun	poly-extend 178,7041
+(defun	poly-extend-end 185,7371
+(defun poly-zerop 189,7560
+(defun lt 193,7636
+(defun lm 198,7744
+(defun lc 203,7864
+
+
+poly-with-sugar.lisp,890
+(defpackage "POLY-WITH-SUGAR"11,625
+(defun poly-with-sugar-poly 48,1758
+(defun poly-with-sugar-sugar 49,1799
+(defun poly-with-sugar-tail 50,1841
+(defsetf poly-with-sugar-poly 52,1899
+(defsetf poly-with-sugar-sugar 55,1967
+(defsetf poly-with-sugar-tail 58,2038
+(defun monom-sugar 65,2301
+(defun coefficient-sugar 68,2345
+(defun term-sugar 71,2414
+(defun poly-add-sugar 78,2686
+(defun scalar-times-poly-with-sugar 83,2847
+(defun term-times-poly-with-sugar 88,3028
+(defun monom-times-poly-with-sugar 93,3241
+(defun minus-poly-with-sugar 99,3442
+(defun poly-with-sugar+ 105,3619
+(defun poly-with-sugar- 111,3856
+(defun poly-with-sugar-op 117,4061
+(defun poly-with-sugar-nreverse 122,4256
+(defun poly-with-sugar-append 128,4487
+(defun poly-with-sugar-zerop 132,4652
+(defun poly-with-sugar-lm 135,4727
+(defun poly-with-sugar-lc 138,4791
+(defun poly-with-sugar-lt 141,4855
+
+
+printer.lisp,168
+(defpackage "PRINTER"11,617
+(defun poly-print 20,838
+(defun poly-print-1 37,1575
+(defun poly-print-2 71,2721
+(defun print-term 79,3033
+(defun print-monom 93,3574
+
+
+prover.lisp,546
+(defpackage "PROVER"12,687
+(defvar *prover-order* 24,1117
+(defun csym 31,1356
+(defmacro real-identical-points 36,1558
+(defmacro identical-points 52,2216
+(defmacro perpendicular 69,2950
+(defmacro parallel 85,3406
+(defmacro collinear 102,3858
+(defmacro equidistant 117,4303
+(defmacro euclidean-distance 133,4814
+(defmacro midpoint 145,5187
+(defmacro translate-statements 159,5603
+(defmacro translate-assumptions 163,5775
+(defmacro translate-conclusions 169,5963
+(defmacro translate-theorem 172,6059
+(defmacro prove-theorem 187,6950
+
+
+rat.lisp,411
+(defpackage "RAT"22,1062
+(defun num 33,1415
+(defun denom 34,1452
+(defun rat-simplify-2 36,1493
+(defun rat-simplify 41,1638
+(defun rat+ 44,1699
+(defun rat- 51,1874
+(defun rat* 59,2120
+(defun rat/ 64,2217
+(defun scalar-times-rat 69,2314
+(defun scalar-div-rat 73,2428
+(defun rat-zerop 76,2517
+(defun rat-uminus 79,2557
+(defun rat-expt 82,2619
+(defun rat-constant 85,2696
+(defun rat-to-poly 90,2898
+
+
+ratpoly.lisp,974
+(defpackage "RATPOLY"25,1219
+(defun ratpoly+ 45,2011
+(defun ratpoly- 61,2463
+(defun ratpoly-uminus 77,2952
+(defun ratpoly* 82,3084
+(defun scalar-times-ratpoly 90,3420
+(defun rat-times-ratpoly 97,3644
+(defun ratpoly-divide 104,3861
+(defun ratpoly-remainder 113,4199
+(defun ratpoly-gcd 117,4344
+(defun ratpoly-diff 123,4483
+(defun ratpoly-square-free 130,4698
+(defun ratpoly-normalize 134,4836
+(defun ratpoly-resultant 139,5048
+(defun deg 157,5548
+(defun lead 164,5686
+(defun ratpoly-discriminant 166,5713
+(defun ratpoly-print 172,5929
+(defun poly-to-ratpoly 188,6493
+(defun poly-to-poly1 192,6621
+(defun poly1-to-ratpoly 204,7023
+(defun ratpoly-to-poly1 213,7230
+(defun poly1-to-poly 221,7447
+(defun ratpoly-to-poly 231,7755
+(defun poly-resultant 235,7826
+(defun poly-gcd 246,8241
+(defun content1 259,8630
+(defun content1-aux 268,8901
+(defun content 274,9096
+(defun primitive-part 278,9189
+(defun divide-coeffs 283,9351
+(defun euclid 299,9788
+
+
+string-grobner.lisp,534
+(defpackage "STRING-GROBNER"14,690
+(defun string-normal-form 35,1252
+(defun string-grobner 57,1850
+(defun string-elimination-ideal 85,2688
+(defun string-ideal-intersection 108,3327
+(defun string-poly-lcm 123,3855
+(defun string-ideal-saturation-1 137,4260
+(defun string-ideal-polysaturation-1 152,4797
+(defun string-ideal-saturation 172,5498
+(defun string-ideal-polysaturation 187,6018
+(defun string-colon-ideal 212,6793
+(defun string-read-poly 234,7548
+(defun poly-rational-to-integer 252,8124
+(defun read-vars 256,8319
+
+
+svpoly.lisp,652
+(defpackage "SVPOLY"11,616
+(defstruct (svpoly 19,775
+(defun make-svpoly 25,984
+(defun svpoly-sort 42,1539
+(defun make-order 46,1700
+(defun svpoly-add 62,2277
+(defun add-terms 69,2526
+(defun scalar-times-poly 107,3439
+(defun term-times-poly 114,3690
+(defun monom-times-poly 118,3888
+(defun minus-poly 122,4052
+(defun poly+ 128,4295
+(defun poly- 152,5097
+(defun poly* 178,5999
+(defun poly-op 189,6519
+(defun poly-expt 195,6746
+(defun poly-mexpt 212,7464
+(defun poly-constant-p 223,7934
+(defun	poly-extend 229,8073
+(defun	poly-extend-end 236,8403
+(defun poly-zerop 240,8592
+(defun lt 244,8668
+(defun lm 249,8776
+(defun lc 254,8896
+
+
+term.lisp,264
+(defpackage "TERM"12,615
+(defun term* 35,1431
+(defun term/ 41,1616
+(defun monom-times-term 47,1807
+(defun term-divides-p 51,1923
+(defmacro term-monom 55,2027
+(defmacro term-coefficient 56,2069
+(defsetf term-monom 59,2134
+(defsetf term-coefficient 62,2200
+
+
+trivial.lisp,29
+(defpackage "TRIVIAL"12,617
+
+
+xgcd.lisp,46
+(defpackage "XGCD"12,614
+(defun xgcd 20,796
Index: /trunk/src/TODO
===================================================================
--- /trunk/src/TODO	(revision 14)
+++ /trunk/src/TODO	(revision 14)
@@ -0,0 +1,13 @@
+#	$Id: TODO,v 1.4 1997/10/25 18:06:11 marek Exp $	
+-*- Mode: outline; fill-column: 50 -*-
+
+** Implement ordered polynomial lists
+
+Polynomial lists should be stored as ordered
+lists, ordered according to the increasing leading
+monomial; this should speed up operations like
+division etc. This is because if a monomial a
+divides b then a<b in any compatible order; thus
+in the division algorithm we may simply stop when
+we find the first leading monomial which is
+greater than the dividend;
Index: /trunk/src/cgb-lisp.lisp
===================================================================
--- /trunk/src/cgb-lisp.lisp	(revision 14)
+++ /trunk/src/cgb-lisp.lisp	(revision 14)
@@ -0,0 +1,118 @@
+#|
+	$Id: cgb-lisp.lisp,v 1.1 2009/01/19 07:44:57 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+;;----------------------------------------------------------------
+;; An example facility
+;;----------------------------------------------------------------
+;; It should be run from the CGB-LISP package and the symbols which appear in the variable
+;; otherwise it will not work because the variable names which appear in strings will not
+;; be in the same package as the variables appearing in the variable lists; well, this
+;; would not happen if variable lists were strings as well, but it is the price to pay for
+;; the convenience of being able to type variable lists quickly.
+;;----------------------------------------------------------------
+
+(defpackage "CGB-LISP"
+  (:use "INFIX" "MAKELIST" "ORDER" "MONOM" "COEFFICIENT-RING" "TERM" "POLY"
+    "MODULAR" "MODULAR-POLY" "DIVISION" "PARSE" "PRINTER"
+    "POLY-WITH-SUGAR" "GROBNER" "COLORED-POLY" "POLY-GCD" "RAT"
+    "RATPOLY" "STRING-GROBNER" "DYNAMICS" "PROVER" "COMMON-LISP"))
+
+(in-package "CGB-LISP")
+
+(defvar *examples*
+  '((string-grobner . ((string-grobner "[x^2+y,x-y]" '(x y))
+		       (string-grobner "[y-x^2,z-x^3]" '(x y z) :order #'grevlex>)))
+    (string-grobner-system . ((string-grobner-system "[u*x+y,x+y]" '(x y) '(u))
+			      (string-grobner-system "[u*x+y,x+y]" '(x y) '(u) :cover '(("[u-1]" "[]")))))
+    (string-read-poly . ((string-read-poly "[x^3+3*x^2+3*x+1]" '(x))))
+    (string-elimination-ideal . ((string-elimination-ideal "[x^2+y^2-2,x*y-1]" '(x y) 1)))
+    (string-ideal-saturation-1 . ((string-ideal-saturation-1 "[x^2*y,y^3]" "x" '(x y))))
+    (string-ideal-polysaturation-1 . ((string-ideal-polysaturation-1 "[x^2*y,y^3]" "[x,y]" '(x y))))
+    (string-cond . ((string-cond '("[u^2-v]" "[v-1]") '(u v) #'grevlex>)))
+    (string-cover . ((string-cover '(("[u^2-v]" "[u]") ("[u+v]" "[]")) '(u v) #'grevlex>)))
+    (string-determine . ((string-determine
+			  "[u*x+y,v*x^2+y^2]"
+			  '(x y)
+			  '(u v)
+			  :cond '("[u,v]" "[v-1]")
+			  :main-order #'lex>)))
+    (parse-string-to-sorted-alist . ((parse-string-to-sorted-alist "x^2+y^3" '(x y) #'grevlex>)
+				     (parse-string-to-sorted-alist "[x^2+y^3,x-y]" '(x y) #'grevlex>)))
+    (translate-statements . ((translate-statements (collinear a b c) (perpendicular a b a c))))
+    (translate-theorem . ((translate-theorem
+			   ((perpendicular A B C D)
+			    (perpendicular C D E F))
+			   ((parallel A B E F)
+			    (identical-points C D)))
+			  (translate-theorem
+			   ((perpendicular A B A C)
+			    (midpoint B C M)
+			    (midpoint A M O)
+			    (collinear B H C)
+			    (perpendicular A H B C))
+			   ((equidistant M O H O)
+			    (identical-points B C)
+			    ))))
+    (prove-theorem . ((prove-theorem
+		       ((perpendicular A B C D)
+			(perpendicular C D E F))
+		       ((parallel A B E F)
+			(identical-points C D)))
+		      (prove-theorem
+		       ((perpendicular A B A C)
+			(midpoint B C M)
+			(midpoint A M O)
+			(collinear B H C)
+			(perpendicular A H B C))
+		       ((equidistant M O H O)
+			(identical-points B C)))
+		      (prove-theorem
+		       ((perpendicular A B A C)
+			(identical-points B C))
+		       ((identical-points A B)
+			(identical-points A C)))
+		      (prove-theorem
+		       ((perpendicular A B A C)
+			(identical-points B C))
+		       ((identical-points A B)
+			(real-identical-points A C)))))
+    )
+  "A list of available examples.")
+
+
+(defun example (symbol &optional (stream t))
+    "Run short examples associated with a symbol, which typically is a function name."
+    (dolist (e (cdr (assoc symbol *examples*)))
+      (run-example e stream))
+    (values))
+
+(defun run-example (e stream)
+  "Evaluate a single form E and send output to stream STREAM."
+  (format stream "~%;;----------------------------------------------------------------")
+  (format stream "~%;;")
+  (format stream "~%;;~1T~S" e)
+  (format stream "~%;;")
+  (format stream "~%;;----------------------------------------------------------------~&")
+  (let ((counter 0))
+    (dolist (val (multiple-value-list (eval e)))
+      (format stream "[ RETURN VALUE ~d]-->> ~S~&" (incf counter) val)))
+  (values))
+
+(defun all-examples (&optional (stream t))
+  "Run all available examples and send output to STREAM."
+  (dolist (a *examples*)
+    (dolist (e (cdr a))
+      (run-example e stream)))
+  (values))
+  
+
+
+
Index: /trunk/src/cgb.asd
===================================================================
--- /trunk/src/cgb.asd	(revision 14)
+++ /trunk/src/cgb.asd	(revision 14)
@@ -0,0 +1,72 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
+(defpackage cgb-system
+  (:use :common-lisp :asdf))
+
+(in-package :cgb-system)
+
+;;----------------------------------------------------------------
+;; Various features which affect the functioning of the package
+;;----------------------------------------------------------------
+
+;;Use pseudodivision to keep the size of integer coefficients 
+;;as small as possible
+(pushnew :pseudodivide *features*)
+
+;;Use the grobner package within colored-poly package
+;;(pushnew :colored-poly-use-grobner *features*)
+
+;;colored-poly package
+;;Compute saturation of green lists with respect to
+;;red lists in order to eliminate cases early
+(pushnew :use-saturation *features*)
+
+;;Print tracing and debugging output
+(pushnew :debug *features*)
+
+;;Use gcd of integers to keep the size of integer coefficients
+;; of S-polynomials and normal forms down
+(pushnew :use-gcd *features*)
+
+;;grobner package
+;;Use the algorithm of Gebauer and Moeller (1988) to
+;;calculate Grobner bases
+(pushnew :use-gebauer-moeller *features*)
+
+;;Use pair reordering according to some heuristic in the
+;;Grobner algorithm
+(pushnew :reorder-pairs *features*)
+
+;; ----------------------------------------------------------------
+;; End of feature setup
+;; ----------------------------------------------------------------
+
+(defsystem "cgb"
+  :description "Comprehensive Grobner Basis Lisp system"
+  :version "1.0"
+  :author "Marek Rychlik <rychlik@u.arizona.edu>"
+  :licence "Custom"
+  :serial t
+  :components ((:file "infix")
+	       (:file "makelist")
+	       (:file "order")
+	       (:file "monom")
+	       (:file "xgcd")
+	       (:file "modular")
+	       (:file "coefficient-ring")
+	       (:file "term")
+	       (:file "poly")
+	       (:file "modular-poly")
+	       (:file "division")
+	       (:file "parse")
+	       (:file "printer")
+	       (:file "poly-with-sugar")
+	       (:file "grobner")
+	       (:file "colored-poly")
+	       (:file "poly-gcd")
+	       (:file "rat")
+	       (:file "ratpoly")
+	       (:file "string-grobner")
+	       (:file "dynamics")
+	       (:file "prover")
+	       (:file "cgb-lisp")))
+	    
Index: /trunk/src/coefficient-ring.lisp
===================================================================
--- /trunk/src/coefficient-ring.lisp	(revision 14)
+++ /trunk/src/coefficient-ring.lisp	(revision 14)
@@ -0,0 +1,113 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
+#|
+	$Id: coefficient-ring.lisp,v 1.4 2009/01/22 03:59:21 marek Exp $
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+(defpackage "COEFFICIENT-RING"
+  (:export ring
+	   ring-+
+	   ring--
+	   ring-*
+	   ring-/
+	   ring-gcd
+	   ring-lcm
+	   ring-signum
+	   ring-zerop
+	   ring-unit
+	   ring-length
+	   ring-numerator
+	   ring-denominator
+	   make-ring
+	   *coefficient-ring*
+	   *ring-of-integers*
+	   *field-of-rationals*
+	   field-modulo-prime
+	   )
+  (:use "MODULAR" "COMMON-LISP"))
+    
+(in-package "COEFFICIENT-RING")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(defstruct ring
+  "The structure whose slots are bound to functions
+performing usual ring operations. In addition to usual arithmetical
+operations, bindings for other common operations
+which increase efficiency of Grobner basis calculations are also
+included. They are as follows:
+	GCD	- greatest common divisor;
+	LCM	- least common multiple;
+	ZEROP	- test whether an element is zero;
+	SIGNUM  - the sign of a ring element (+1, -1 or zero);
+	UNIT	- the unit of the ring;
+	NUMERATOR - the numerator, if a ring of fractions
+	DENOMINATOR - the denominator, if a ring of fractions
+	LENGTH  - an integer giving the approximate length
+		of the representation; for example, for integers
+		its default binding is #'integer-length;
+"
+  + - * / gcd lcm zerop unit length signum numerator denominator)
+
+(defvar *ring-of-integers*
+  (make-ring :+ #'+
+	     :- #'-
+	     :* #'*
+	     :/ #'floor
+	     :gcd #'gcd
+	     :lcm #'lcm
+	     :zerop #'zerop
+	     :signum #'signum
+	     :unit 1
+	     :length #'integer-length
+	     :numerator #'numerator
+	     :denominator #'denominator)
+  "Operations in the ring of integers.")
+
+(defvar *field-of-rationals*
+  (make-ring
+   :+ #'+
+   :- #'-
+   :* #'*
+   :/ #'/
+   :gcd #'(lambda (&rest r) (declare (ignore r)) 1)
+   :lcm #'(lambda (&rest r) (apply #'* r))
+   :zerop #'zerop
+   :signum #'signum
+   :unit 1
+   :length #'(lambda (x) (+ (integer-length (numerator x))
+			    (integer-length (denominator x))))
+   :numerator #'numerator
+   :denominator #'denominator)
+  "Operations on the field of rational numbers.")
+
+(defun field-modulo-prime (modulus)
+  "Return a RING structure with operations bound
+to the arithmetical operations modulo MODULUS, which
+should be a prime."
+  (make-ring
+   :+ #'(lambda (&rest r) (mod (apply #'+ r) modulus))
+   :- #'(lambda (&rest r) (mod (apply #'- r) modulus))
+   :* #'(lambda (&rest r) (mod (apply #'* r) modulus))
+   :/ (make-modular-division modulus)
+   :gcd #'(lambda (&rest r) (declare (ignore r)) 1)
+   :lcm #'(lambda (&rest r) (mod (apply #'* r) modulus))
+   :zerop #'zerop
+   :signum #'(lambda (x) (if (zerop x) 0 1))
+   :unit 1
+   :length #'(lambda (x) (declare (ignore x)) 1)
+   :numerator #'identity
+   :denominator #'(lambda (x) (declare (ignore x)) 1)))
+
+
+(defvar *coefficient-ring* *ring-of-integers*
+  "The default RING structure, used in most operations
+on the coefficients of polynomials. It should be carefully
+set if rings other than the default ring is used.")
+
Index: /trunk/src/colored-poly.lisp
===================================================================
--- /trunk/src/colored-poly.lisp	(revision 14)
+++ /trunk/src/colored-poly.lisp	(revision 14)
@@ -0,0 +1,979 @@
+#|
+	$Id: colored-poly.lisp,v 1.12 2009/01/24 11:07:32 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+(defpackage "COLORED-POLY"
+  (:use "MONOM" "ORDER" "PARSE" "PRINTER" "MAKELIST"
+	"GROBNER"  "DIVISION" "POLY" "COEFFICIENT-RING" "COMMON-LISP")
+  (:export make-colored-poly colored-poly-print colored-poly-print-list
+	   colored-poly-to-poly
+	   cond-print cond-system-print determine string-determine
+	   color-poly color-poly-list
+	   grobner-system totally-green-p cond-hm cond-normal-form
+	   cond-spoly make-colored-poly-list
+	   string-grobner-system string-cond string-cover 
+	   *colored-poly-debug*
+	   parse-to-colored-poly-list
+	   ))
+(in-package "COLORED-POLY")
+	     
+(proclaim '(optimize (speed 0) (debug 3)))
+
+#+debug(defvar *colored-poly-debug* nil "If true debugging output is on.")
+#+debug
+(defmacro debug-cgb (&rest args)
+  `(when *colored-poly-debug* (format *trace-output* ,@args)))
+
+(defun make-colored-poly (poly k &key (key #'identity)
+				      (main-order #'lex>)
+				      (parameter-order #'lex>)
+			  &aux l)
+  "Colored poly is represented as a list
+	(TERM1 TERM2 ... TERMS)
+where each term is a triple
+	(MONOM . (POLY . COLOR))
+where monoms and polys have common number of variables while color is
+one of the three: :RED, :GREEN or :WHITE.  This function translates an
+ordinary polynomial into a colored one by dividing variables into K
+and N-K, where N is the total number of variables in the polynomial
+poly; the function KEY can be called to select variables in arbitrary
+order."
+  (when (endp poly) (return-from make-colored-poly))
+  (setf l (length (caar poly)))
+  (labels 
+      ((monom-split-variables (monom)
+	 (values
+	  (makelist (elt monom (funcall key i)) (i 0 (1- k)))
+	  (makelist (elt monom (funcall key i)) (i k (1- l)))))
+       (term-split-variables (term)
+	 (multiple-value-bind (main par)
+	     (monom-split-variables (car term))
+	   (cons main (cons par (cdr term)))))
+       (collect-terms (p)
+	 (do ((p p (rest p))
+	      (q (mapcar #'(lambda (x) (cons x nil))
+			 (remove-duplicates (mapcar #'car p)
+					    :test #'equal))))
+	     ((endp p) q)
+	   (push (cdar p) (cdr (assoc (caar p) q :test #'equal)))
+	   )))
+    (mapcar #'(lambda (term)
+		(cons (car term)
+		      (cons (sort (cdr term) parameter-order :key #'car)
+			    :white)))
+	    (collect-terms
+	     (sort (mapcar #'term-split-variables poly)
+		   main-order :key #'car)))))
+
+(defun make-colored-poly-list (plist &rest rest)
+  "Translate a list of polynomials PLIST into a list of colored polynomials
+by calling MAKE-COLORED-POLY. Returns the resulting list."
+  (mapcar #'(lambda (p) (apply #'make-colored-poly (cons p rest)))
+	  plist))
+
+(defun color-poly-list (flist &optional (cond (list nil nil)))
+  "Add colors to an ordinary list of polynomials FLIST, according to a
+condition COND. A condition is a pair of polynomial lists.  Each
+polynomial in COND is a polynomial in parameters only.  The list
+(FIRST COND) is called the ``green list'' and it consists of
+polynomials which vanish for the parameters associated with the
+condition. The list (SECOND COND) is called the ``red list'' and it
+consists of the polynomials which do not vanish for the parameters
+associated with the condition."
+  (mapcar #'(lambda (f) (color-poly f cond)) flist))
+
+(defun color-poly (f &optional (cond (list nil nil)))
+  "Add color to a single polynomial F, according to condition COND.
+See the documentation of COLOR-POLY-LIST."
+  (mapcar
+   #'(lambda (term) 
+       (cons (car term)
+	     (cons (cadr term)
+		   (cond
+		     ((member (cadr term) (car cond) 
+			      :test #'tree-equal) :green)
+		     ((member (cadr term) (cadr cond)
+			      :test #'tree-equal) :red)
+		     (t :white)))))
+   (cdr f)))
+
+;;Conversion to ordinary polynomial
+(defun colored-poly-to-poly (cpoly)
+  "For a given colored polynomial CPOLY, removes the colors and
+it returns the polynomial as an ordinary polynomial with
+coefficients which are polynomials in parameters."
+  (mapcan #'(lambda (term)
+	      (mapcar #'(lambda (x) (cons (append (car term) (car x)) (cdr x)))
+		      (cadr term)))
+	  (cdr cpoly)))
+		    
+(defun colored-poly-print (poly vars
+			   &key (stream t) (beg t)
+				(print-green-part nil)
+				(mark-coefficients nil))
+  "Print a colored polynomial POLY. Use variables VARS to represent
+the variables. Some of the variables are going to be used as
+parameters, according to the length of the monomials in the main
+monomial and coefficient part of each term in POLY. The key variable
+STREAM may be used to redirect the output. If parameter
+PRINT-GREEN-PART is set then the coefficients which have color :GREEN
+will be printed, otherwise they are discarded silently. If
+MARK-COEFFICIENTS is not NIL then every coefficient will be marked
+according to its color, for instance G(U-1) would mean that U-1 is
+in the green list. Returns P."
+  (when (null poly)
+    (when beg  (format stream "0") )
+    (return-from colored-poly-print))
+  (let* ((term (car poly))
+	 (color (cddr term))
+	 (n (length (car term))))
+    (unless (and (not print-green-part) (eq color :green))
+      (unless beg (format stream " + "))
+      (if mark-coefficients 
+	  (format stream "~c(" 
+		  (case color (:red #\R) (:green #\G) (:white #\W)))
+	(format stream "("))
+      (poly-print (cadr term) (subseq vars n))
+      (format stream ")")
+      (print-monom (car term) (subseq vars 0 n) stream)
+      (setf beg nil)))
+  (colored-poly-print (rest poly) vars :stream stream :beg beg
+		      :print-green-part print-green-part
+		      :mark-coefficients mark-coefficients))
+
+(defun colored-poly-print-list (poly-list vars
+					  &key (stream t)
+					  (beg t)
+					  (print-green-part nil)
+					  (mark-coefficients nil))
+  "Pring a list of colored polynomials via a call to
+COLORED-POLY-PRINT."
+  (when (endp poly-list)
+    (when beg (format stream "["))
+    (format stream " ]")
+    (return-from colored-poly-print-list))
+    (unless (or (endp (car poly-list))
+	      (and (not print-green-part) (endp (cond-part (car poly-list)))))
+    (when beg (format stream "[ "))
+    (unless beg (format stream ", "))
+    (colored-poly-print (car poly-list) vars 
+			:stream stream 
+			:print-green-part print-green-part
+			:mark-coefficients mark-coefficients)
+    (setf beg nil))
+  (colored-poly-print-list (rest poly-list) vars 
+			   :stream stream :beg beg
+			   :print-green-part print-green-part
+			   :mark-coefficients mark-coefficients))
+
+(defun determine (F &optional (cond (list nil nil)) (order #'lex>) (ring *coefficient-ring*))
+  "This function takes a list of colored polynomials F and a condition
+COND, and it returns a list of pairs (COND' F') such that COND' cover
+COND and F' is a ``determined'' version of the colored polynomial list
+F, i.e. every polynomial has its leading coefficient determined. This
+means that some of the initial coefficients in each polynomial in F'
+are in the green list of COND, and the first non-green coefficient is
+in the red list of COND. We note that F' differs from F only by
+different colors: some of the terms marked :WHITE are now marked
+either :GREEN or :RED. Coloring is done either by explicitly checking
+membership in red or green list of COND, or implicitly by performing
+Grobner basis calculations in the polynomial ring over the
+parameters. The admissible monomial order ORDER is used only in the
+parameter space. Also, the ring structure RING is used only for
+calculations on polynomials of the parameters only."
+  (cond 
+   ((endp F) (list (list cond nil)))
+   (t
+    (let ((gs (mapcan #'(lambda (p &aux (cond1 (car p)) (F1 (cadr p)))
+			  (determine-1 cond1 (car F) F1 nil order ring))
+		      (determine (rest F) cond order ring))))
+      #+debug(let ((l (length gs)))
+	       (when (> l 1) 
+		 (debug-cgb "~&Determined ~d new case~:p." (1- l))))
+      gs))))
+
+(defun determine-1 (cond P end GP order ring)
+  "Determine a single colored polynomial  P according to condition COND.
+Prepend green part GP to P. Cons the result with END, which should be
+a list of colored polynomials, and return the resulting list of polynomials.
+This is an auxillary function of DETERMINE."
+  (cond 
+    ((endp P) (list (list cond (append (list GP) end))))
+    ((eq (cddar P) :green)
+     (determine-1 cond (rest P) end (append GP (list (car P))) order ring))
+    ((eq (cddar P) :red)
+     (list (list cond (append (list (append GP P)) end))))
+    ;; white cases
+    (t (determine-white-term cond (car P) (rest P) end GP order ring))))
+
+#-use-saturation
+(defun determine-white-term (cond term restP end GP order ring)
+  "This is an auxillary function of DETERMINE.
+In this function the parameter COND is a condition.
+The parameters TERM, RESTP and GP are three parts of a polynomial being
+processed, where TERM is colored :WHITE. By testing membership
+in the red and green list of COND we try to determine whether the term
+is :RED or :GREEN. If we are successful, we simply change the color
+of the term and return the list ((COND P)) where P is obtained by
+appending GP, (LIST TERM) and RESTP. If we cannot determine whether 
+TERM is :RED or :GREEN, we return the list ((COND' P') (COND'' P ''))
+where COND' is obtained by adding the coefficient of TERM to
+the red list of COND and P' is obtained by appending
+GP, (LIST TERM) and RESTP. COND'' is obtained by putting
+the coefficient of TERM into the green list of COND and
+P'' is obtaind by a recursive call to DETERMINE-1 on 
+RESTP, together with GP and TERM which was marked :GREEN."
+  (cond 
+   ((member (cadr term) (car cond) :test #'tree-equal) ;green
+    (determine-1 cond restP end
+		 (append GP (list (list* (car term) (cadr term) :green))) 
+		 order ring))
+   ((or (member (cadr term) (cadr cond) :test #'tree-equal) ;red
+	(poly-constant-p (cadr term)))
+    (list
+     (list cond 
+	   (append (list
+		    (append GP			     ;green part
+			    (list (list* (car term) (cadr term) :red));red term
+			    restP))		     ;other terms
+		   end))))
+   (t						     ;white
+    (cons
+     (list (list (car cond) (cons (cadr term) (cadr cond)))
+	   (append
+	    (list
+	     (append 
+	      GP 
+	      (list (cons (car term) (cons (cadr term) :red)))
+	      restP))
+	    end))
+     (determine-1 
+      (list (cons (cadr term) (car cond)) (cadr cond))
+      restP
+      end
+      (append GP (list (cons (car term) (cons (cadr term) :green))))
+      order ring)))))
+
+;; In this version, push on red list literally and test membership
+;; But keep green list to be a Grobner basis
+#+use-saturation
+(defun determine-white-term (cond term restP end GP order ring)
+  "This is an auxillary function of DETERMINE.  In this function the
+parameter COND is a condition.  The parameters TERM, RESTP and GP are
+three parts of a polynomial being processed, where TERM is colored
+:WHITE. We test the membership in the red and green list of COND we
+try to determine whether the term is :RED or :GREEN. This is done by
+performing ideal membership tests in the polynomial ring. Let C be the
+coefficient of TERM.  Thus, C is a polynomial in parameters. We find
+whether C is in the green list by performing a plain ideal membership
+test. However, to test properly whether C is in the red list, one
+needs a different strategy.  In fact, we test whether adding C to the
+red list would produce a non-empty set of parameters in some algebraic
+extension. The test is whether 1 belongs to the saturation ideal of
+(FIRST COND) in (CONS C (SECOND COND)). Thus, we use POLY-SATURATION.
+If we are successful in determining the color of TERM, we simply
+change the color of the term and return the list ((COND P)) where P is
+obtained by appending GP, (LIST TERM) and RESTP. If we cannot
+determine whether TERM is :RED or :GREEN, we return the list ((COND'
+P') (COND'' P'')) where COND' is obtained by adding the coefficient of
+TERM to the red list of COND and P' is obtained by appending GP, (LIST
+TERM) and RESTP. COND'' is obtained by putting the coefficient of TERM
+into the green list of COND and P'' is obtaind by a recursive call to
+DETERMINE-1 on RESTP, together with GP and TERM which was marked
+:GREEN."
+  (if (member (cadr term) (cadr cond) :test #'tree-equal)
+      ;;Paint red and return  
+      (list
+       (list
+	cond
+	(append
+	 (list (append GP (list (list* (car term) (cadr term) :red)) restP))
+	 end)))
+    (let ((green-sat (ideal-saturation-1 
+		      (car cond)
+		      (cadr term) order (length (car cond))
+		      nil ring)))
+      (if (some #'poly-constant-p green-sat) ; in the radical of green
+	  ;; paint the term green and determine the rest
+	  (determine-1
+	   cond restP end 
+	   (append GP (list (list* (car term) (cadr term) :green))) ;green term
+	   order ring)
+	;; else it does not contradict green and thus may be added to red list
+	;; so it should be added to either red or green list
+	(cons
+	 ;; Add to red
+	 (list
+	  (list green-sat (append (cadr cond) (list (cadr term))))
+	  (append
+	   (list (append 
+		  GP 
+		  (list (list* (car term) (cadr term) :red))
+		  restP))
+	   end))
+	 ;; Add to green
+	 (let ((sat (ideal-polysaturation-1
+		     (append (car cond) (list (cadr term)))
+		     (cadr cond)
+		     order (length (car cond))
+		     nil ring)))
+	   (unless (some #'poly-constant-p sat)	;contradiction after all
+	     (determine-1 
+	      (list sat (cadr cond))
+	      restP end
+	      (append GP (list (list* (car term) (cadr term) :green)))
+	      order ring))))))))
+
+
+
+;; Print a conditional system, i.e. a list of pairs (gamma colored-poly-list)
+(defun cond-system-print (system vars params 
+			  &key (suppress-value t)
+			       (print-green-part nil)
+			       (mark-coefficients nil) 
+			  &aux (label 0))
+  "A conditional system SYSTEM is a list of pairs (COND PLIST), where COND
+is a condition (a pair (GREEN-LIST RED-LIST)) and PLIST is a list
+of colored polynomials. This function pretty-prints this list of
+pairs. A conditional system is the data structure returned by 
+GROBNER-SYSTEM. This function returns SYSTEM, if SUPPRESS-VALUE is non-NIL and 
+no value otherwise. If MARK-COEFFICIENTS is non-NIL coefficients will be marked
+as in G(u-1)*x+R(2)*y, which means that u-1 is :GREEN and 2 is :RED."
+  (dolist (pair system (if suppress-value (values) system))
+    (let ((cond (car pair))
+	  (basis (cadr pair)))
+      (format t "~&------------------- CASE ~d -------------------"
+	      (incf label))
+      (cond-print cond params)
+      (format t "~&~1TBasis: ")
+      (colored-poly-print-list basis (append vars params)
+			       :print-green-part print-green-part
+			       :mark-coefficients mark-coefficients))))
+	
+;; Print a condition
+(defun cond-print (cond params)
+  "Pretty-print a condition COND, using symbol list PARAMS as parameter names."
+  (format t "~&Condition:")
+  (format t "~&~2TGreen list: ")
+  (poly-print (cons '[ (first cond)) params)
+  (format t "~&~2TRed list: ")
+  (poly-print (cons '[ (second cond)) params))
+
+
+(defun add-pairs (gs pred)
+  "The parameter GS shoud be a Grobner system, i.e. a set of pairs
+(CONDITION POLY-LIST) This functions adds the third component: the
+list of initial critical pairs (I J), as in the ordinary Grobner basis
+algorithm. In addition, it adds the length of of the POLY-LIST, less
+1, as the fourth component. The resulting list of quadruples is
+returned."
+  #-reorder-pairs(declare (ignore pred))
+  (mapcar
+   #'(lambda (gb  &aux (n (length (cadr gb))))
+       (let ((B (makelist (list i j) (i 0 (- n 2)) (j (1+ i) (1- n)))))
+	 #+reorder-pairs
+	 (setf B (reorder-pairs B nil (cadr gb) pred t))
+	 (append gb (list B (1- n)))))
+   gs))
+
+(defun cond-part (p)
+  "Find the part of a colored polynomial P starting with the first
+  non-green term."
+  (member :green p :test-not #'eq :key #'cddr))
+
+(defun cond-hm (p)
+  "Return the conditional head monomial of a colored polynomial P."
+ (let ((cp (cond-part p)))
+   (cond
+     ((endp cp) (error "Zero conditional part."))
+     ((eq (cddar cp) :red) (car cp))
+     (t  (error "Head not determined.")))))
+
+(defun delete-green-polys (gamma)
+  "Delete totally green polynomials from in a grobner system GAMMA."
+  (dolist (gb gamma gamma)
+	  (setf (cadr gb) (delete-if-not #'cond-part (cadr gb)))))
+
+;; B is a cover (i.e. a list of conditions)
+;; flist is a list of colored polynomials
+(defun grobner-system (F &key
+			 (cover (list '(nil nil)))
+			 (main-order #'lex>)
+			 (parameter-order #'lex>)
+			 (reduce t)
+			 (green-reduce t)
+			 (top-reduction-only nil)
+			 (ring *coefficient-ring*)
+		       &aux 
+		       (cover	   #-use-saturation cover
+				   #+use-saturation
+				   (saturate-cover cover parameter-order ring))
+		       (gamma (delete-green-polys
+			       (mapcan #'(lambda (cond) 
+					   (determine F cond
+						      parameter-order ring))
+				       cover))))
+  "This function returns a grobner system, given a list of colored polynomials F,
+Other parameters are:
+A cover COVER, i.e. a list of conditions, i.e. pairs of the form (GREEN-LIST RED-LIST), where
+GREEN-LIST and RED-LIST are to lists of ordinary polynomials in parameters.
+A monomial order MAIN-ORDER used on main variables (not parameters).
+A monomial order PARAMETER-ORDER used in calculations with parameters only.
+REDUCE, a flag deciding whether COLORED-REDUCTION will be performed on the resulting
+grobner system.
+GREEN-REDUCE, a flag deciding whether the green list of each condition will be reduced in
+a form of a reduced Grobner basis.
+TOP-REDUCTION-ONLY, a flag deciding whether in the internal calculations in the space of parameters
+top reduction only will be used.
+RING, a structure as in the package COEFFICIENT-RING, used in operations on the coefficients
+of the polynomials in parameters."
+  #+debug(debug-cgb "~&Initially ~d open case~:p." (length gamma))
+  (do ((open  (add-pairs gamma main-order)) 
+       closed) 
+      ((endp open) 
+       ;; Post-process Grobner system
+       (tidy-grobner-system
+	(mapcar #'(lambda (gp) (butlast gp 2)) closed)
+	main-order parameter-order reduce green-reduce ring))
+    #+debug(debug-cgb "~&Currently ~d open case~:p." (length open))
+    (let*  ((gb (pop open))  (cond (car gb))  (G (cadr gb))  (B (caddr gb))
+	    (s (cadddr gb)))
+      (declare (fixnum s))
+      (assert (= (length G) (1+ s)))
+      #+debug(debug-cgb "~&Colored case of ~d polynomials and ~d pairs."
+			(1+ s) (length B))
+      (cond 
+       ((endp B)			;no more pairs in this tuple
+	(push gb closed))
+       ((let* ((pair (car B))
+	       (i (car pair))
+	       (j (cadr pair)))
+	  (declare (fixnum i j))
+	  (or
+	   ;;Buchberger criterion 1 or 2 succeeds
+	   (colored-Criterion-1 i j G) 
+	   (colored-Criterion-2 i j G (rest B) s)))
+	(push (list cond G (rest B) s) open))
+       (t				;Grobner step - S-polynomial
+	(do* ((pair (car B))
+	      (i (car pair))
+	      (j (cadr pair))
+	      (h (cond-spoly (elt G i) (elt G j) 
+			     main-order parameter-order ring))
+	      (SP (cond-normal-form h G main-order parameter-order top-reduction-only ring))
+	      (delta (determine (list SP) cond parameter-order ring)
+		     (rest delta))) 
+	    ((endp delta))
+	  (declare (fixnum i j))
+	  (let ((cond1 (caar delta))
+		(SP1 (caadar delta)))
+	    (cond
+	     ((cond-part SP1)		;SP1 is not green
+	      (let* ((G1 (append G (list SP1)))
+		     (s1 (1+ s))
+		     (Bnew (makelist (list k s1) (k 0 (1- s1))))
+		     B1)
+		(assert (= (length G1) (1+ s1)))
+		#+reorder-pairs
+		(setf B1 (reorder-pairs (rest B) Bnew G1 main-order nil))
+		#-reorder-pairs
+		(setf B1 (append (rest B) Bnew))
+		(push (list cond1 G1 B1 s1) open)))
+	     (t				;SP1 is totally green
+	      (assert (= (length G) (1+ s)))
+	      (push (list cond1 G (rest B) s) open))))))))))
+
+;; This is destructive to B and Bnew
+#+reorder-pairs
+(defun reorder-pairs (B Bnew G pred &optional (sort-first nil))
+  "Reorder pairs according to some heuristic. The heuristic at this time is ad hoc,
+in the future it should be replaced with sugar strategy and a mechanism for implementing
+new heuristic strategies, as in the GROBNER package."
+  (let ((order 
+	 #'(lambda (p1 p2)
+	     (let* ((m1 (monom-lcm (cond-lm (elt G (car p1)))
+				   (cond-lm (elt G (cadr p1)))))
+		    (m2 (monom-lcm (cond-lm (elt G (car p2)))
+				   (cond-lm (elt G (cadr p2)))))
+		    (d1 (total-degree m1))
+		    (d2 (total-degree m2)))
+	       (cond ((< d1 d2) t)
+		     ((= d1 d2) (funcall pred m2 m1))
+		     (t nil))))))
+    (when sort-first (setf B (sort (copy-list B) order)))
+    (if Bnew 
+	(setf B (merge 'list (sort Bnew order) (copy-list B) order))
+      B)))
+
+(defun colored-Criterion-1 (i j F)
+  "Buchberger criterion 1 for colored polynomials."
+  (declare (fixnum i j))
+  (let ((v (monom-rel-prime (cond-lm (elt F i))
+			    (cond-lm (elt F j)))))
+    #+debug(when v (debug-cgb "~&~2TColored Buchberger1 succeded."))
+    v))
+
+(defun colored-Criterion-2 (i j F B s)
+  "Buchberger criterion 2 for colored polynomials."
+  (declare (fixnum i j s))
+  (labels ((pair (i j)
+	     (declare (fixnum i j))
+	     (if (< i j) (list i j) (list j i))))
+    (do ((k 1 (1+ k)))
+	((>= k s))
+      (when (and (/= k i)
+		 (/= k j)
+		 (not (member (pair i k) B :test #'equal))
+		 (not (member (pair j k) B :test #'equal))
+		 (monom-divides-p (cond-lm (elt F k))
+				  (monom-lcm (cond-lm (elt F i))
+					     (cond-lm (elt F j)))))
+	#+debug(debug-cgb "~&~2TColored Buchberger2 succeded.")
+	(return-from colored-Criterion-2 t)))))
+	  
+
+(defun cond-normal-form (f fl main-order parameter-order top-reduction-only ring)
+  "Returns the conditional normal form of a colored polynomial F with respect to
+the list of colored polynomials FL. The list FL is assumed to consist of determined
+polynomials, i.e. such that the first term which is not marked :GREEN is
+:RED."
+  ;; Remove all zero (i.e totally green) polys from plist
+  ;; (setf fl (remove nil fl :key #'cond-part))
+  (do (r (division-count 0)
+	 (p f))
+      ((or (endp p) (and top-reduction-only r))
+       #+debug(debug-cgb "~&~3T~d conditional reductions" division-count)
+       #+debug(when (endp r) (debug-cgb " ---> 0"))
+       (values (reverse r) division-count))
+    (cond
+      ((eq (cddar p) :green)
+       (setf r (cons (car p) r)
+	     p (rest p)))
+      (t 
+       ;; Find a divisor
+       (do ((fl fl (rest fl)))		;scan list of divisors
+	   ((cond 
+	      ((endp fl)
+	       ;; no division occurred
+	       (setf r (cons (car p) r)	;move term to remainder
+		     p (rest p))	;remove car from p
+	       t)
+	      ((monom-divides-p (cond-lm (car fl))
+				(caar p))
+	       (incf division-count)
+	       (let* (#-colored-poly-use-grobner
+		      (c1 (cons (make-list (length (caar fl))
+					   :initial-element 0)
+				(cond-lc (car fl))))
+		      #+colored-poly-use-grobner
+		      (lcm (poly-lcm (car (cond-lc (car fl))) (cadar p)
+				     parameter-order ring))
+		      #+colored-poly-use-grobner
+		      (c1 (cons (make-list (length (cond-lm (car fl)))
+					   :initial-element 0)
+				(cons (poly-exact-divide lcm (cadar p) parameter-order ring) :red)))
+		      #+colored-poly-use-grobner
+		      (c2 (poly-exact-divide 
+			   lcm 
+			   (car (cond-lc (car fl)))
+			   parameter-order ring))
+		      #-colored-poly-use-grobner
+		      (c2 (cadar p))
+		      ;; This works for both
+		      (quot (cons (monom/ (caar p) (cond-lm (car fl)))
+				  (cons c2 (cddr p)))))
+		 ;; Multiply the equation c*f=sum ai*fi+r+p by c1.
+		 (setf r (colored-term-times-poly c1 r parameter-order ring)
+		       p (colored-poly- 
+			  (colored-term-times-poly c1 p parameter-order ring) 
+			  (colored-term-times-poly quot (car fl) parameter-order ring)
+			  main-order parameter-order ring)))
+	       t))))))))
+
+
+
+(defun cond-spoly (f g main-order parameter-order ring)
+  "Returns the conditional S-polynomial of two colored polynomials F and G.
+Both polynomials are assumed to be determined."
+  (let* ((lcm (monom-lcm (cond-lm f) (cond-lm g)))
+	 (m1 (monom/ lcm (cond-lm f)))
+	 (m2 (monom/ lcm (cond-lm g))))
+    #-colored-poly-use-grobner
+    (colored-poly-
+     (colored-term-times-poly (cons m1 (cond-lc g)) (rest f)
+			      parameter-order ring)
+     (colored-term-times-poly (cons m2 (cond-lc f)) (rest g)
+			      parameter-order ring)
+     main-order parameter-order ring)
+
+    #+colored-poly-use-grobner
+    (let* ((lcm-2 (poly-lcm (car (cond-lc f)) (car (cond-lc g))
+			    parameter-order ring))
+	   (lcf (cond-lc f))
+	   (lcg (cond-lc g))
+	   (cf (cons (poly-exact-divide lcm-2 (car lcf) parameter-order ring)
+		     :red))
+	   (cg (cons (poly-exact-divide lcm-2 (car lcg) parameter-order ring)
+		     :red)))
+      (colored-poly-
+       (colored-term-times-poly (cons m1 cf) f parameter-order ring)
+       (colored-term-times-poly (cons m2 cg) g parameter-order ring)
+       main-order parameter-order ring))
+    ))
+
+(defun cond-lm (f)
+  "Returns the conditional leading monomial of a colored polynomial F,
+which is assumed to be determined."
+  (car (cond-hm f)))
+
+;; Conditional leading coefficient; (poly . color)
+(defun cond-lc (f)
+  "Returns the conditional leading coefficient of a colored polynomial F,
+which is assumed to be determined."
+  (cdr (cond-hm f)))
+
+
+(defun colored-term-times-poly (term f order ring)
+  "Returns the product of a colored term TERM and a colored polynomial F."
+  (mapcar #'(lambda (x) (colored-term* term x order ring)) f))
+
+
+(defun colored-scalar-times-poly (c f ring)
+  "Returns the product of an element of the coefficient ring C a colored polynomial F."
+  (mapcar #'(lambda (x)
+	      (cons (car x)
+		    (cons (scalar-times-poly c (cadr x) ring)
+			  (cddr x))))
+	  f))
+
+(defun colored-term* (term1 term2 order ring)
+  "Returns the product of two colored terms TERM1 and TERM2."
+  (cons 
+   (monom* (car term1) (car term2))
+   (cons (poly* (cadr term1) (cadr term2) order ring)
+	 (color* (cddr term1) (cddr term2)))))
+
+(defun color* (c1 c2)
+  "Returns a product of two colores. Rules:
+:red * :red yields :red
+any * :green yields :green
+otherwise the result is :white."
+  (cond 
+    ((and (eq c1 :red) (eq c2 :red)) :red)
+    ((or (eq c1 :green) (eq c2 :green)) :green)
+    (t :white)))
+
+(defun color+ (c1 c2)
+  "Returns a sum of colors. Rules:
+:green + :green yields :green,
+:red + :green yields :red
+any other result is :white."
+  (cond 
+    ((and (eq c1 :green) (eq c2 :green)) :green)
+    ((and (eq c1 :red) (eq c2 :green)) :red)
+    ((and (eq c2 :red) (eq c1 :green)) :red)
+    (t :white)))
+
+(defun color- (c1 c2)
+  "Identical to COLOR+."
+  (color+ c1 c2))
+
+(defun colored-poly+ (p q main-order parameter-order ring)
+  "Returns the sum of colored polynomials P and Q."
+  (cond 
+    ((endp p) q)
+    ((endp q) p)
+    (t 
+     (multiple-value-bind 
+	   (mgreater mequal)
+	 (funcall main-order (caar p) (caar q))
+       (cond
+	 (mequal
+	  (let ((s (poly+ (cadar p) (cadar q) parameter-order ring)))
+	    (if (endp s)		;check for cancellation
+		(colored-poly+ (cdr p) (cdr q) main-order parameter-order ring)
+	      (cons (cons (caar p) (cons s (color+ (cddar p) (cddar q))))
+		    (colored-poly+ (cdr p) (cdr q) main-order
+				   parameter-order ring)))))
+	 (mgreater
+	  (cons (car p)
+		(colored-poly+ (cdr p) q main-order parameter-order ring)))
+	 (t (cons (cons (caar q) (cons (cadar q) (cddar q)))
+		  (colored-poly+ p (cdr q) main-order parameter-order ring))))))))
+
+(defun colored-poly- (p q main-order parameter-order ring)
+  "Returns the difference of colored polynomials P and Q."
+  (do (r)
+      (nil)
+    (cond 
+      ((endp p) (return (nreconc r (colored-minus-poly q ring))))
+      ((endp q) (return (nreconc r p)))
+      (t 
+       (multiple-value-bind 
+	     (mgreater mequal)
+	   (funcall main-order (caar p) (caar q))
+	 (cond
+	   (mequal
+	    (let ((s (poly- (cadar p) (cadar q) parameter-order ring)))
+	      (unless (endp s)		;check for cancellation
+		(setf r (cons (cons (caar p) (cons s (color- (cddar p) (cddar q)))) r)))
+	      (setf p (cdr p) q (cdr q))))
+	   (mgreater
+	    (setf r (cons (car p) r)
+		  p (cdr p)))
+	   (t (setf r (cons (cons (caar q) (cons (minus-poly (cadar q) ring) (cddar q))) r)
+		    q (cdr q)))))))))
+
+(defun colored-term-uminus (term ring)
+  "Returns the negation of a colored term TERM."
+  (cons (car term) (cons (minus-poly (cadr term) ring) (cddr term))))
+
+(defun colored-minus-poly (p ring)
+  "Returns the negation of a colored polynomial P."
+  (mapcar #'(lambda (x) (colored-term-uminus x ring)) p))
+
+(defun string-grobner-system (F vars params
+			      &key (cover (list (list "[]" "[]")))
+				   (main-order #'lex>)
+				   (parameter-order #'lex>)
+				   (ring *coefficient-ring*)
+				   (suppress-value t)
+				   (suppress-printing nil)
+				   (mark-coefficients nil)
+				   (reduce t)
+				   (green-reduce t)
+			      &aux
+			      (F (parse-to-colored-poly-list
+				  F vars params main-order parameter-order))
+			      (cover (string-cover cover params parameter-order)))
+  "An interface to GROBNER-SYSTEM in which polynomials can be specified in infix notations
+as strings. Lists of polynomials are comma-separated list marked by a matchfix operators []"
+  (let ((gs (grobner-system F :cover cover :main-order main-order
+			    :parameter-order parameter-order
+			    :ring ring
+			    :green-reduce green-reduce
+			    :reduce reduce)))
+    (unless suppress-printing
+      (cond-system-print gs vars params :mark-coefficients mark-coefficients))
+    (if suppress-value (values) gs)))
+
+
+(defun string-cond (cond params &optional (order #'lex>))
+  "Return the internal representation of a condition COND, specified
+as pairs of strings (GREEN-LIST RED-LIST). GREEN-LIST and RED-LIST in
+the input are assumed to be strings which parse to two lists of
+polynomials with respect to variables whose names are in the list of
+symbols PARAMS. ORDER is the predicate used to sort the terms of
+the polynomials."
+  (list
+   (rest (parse-string-to-sorted-alist (car cond) params order))
+   (rest (parse-string-to-sorted-alist (cadr cond) params order))))
+
+(defun string-cover (cover params &optional (order #'lex>))
+  "Returns the internal representation of COVER, given in the form of
+a list of conditions. See STRING-COND for description of a condition." 
+  (cond 
+   ((endp cover) nil)
+   (t (cons (string-cond (car cover) params order)
+	    (string-cover (cdr cover) params order)))))
+
+(defun saturate-cover (cover order ring)
+  "Brings every condition of a list of conditions COVER to the form (G R)
+where G is saturated with respect to R and G is a Grobner basis
+We could reduce R so that the elements of R are relatively prime,
+but this is not currently done."
+  (remove nil (mapcar #'(lambda (cond) (saturate-cond cond order ring)) cover)))
+
+(defun saturate-cond (cond order ring)
+  "Saturate a single condition COND. An auxillary function of SATURATE-COVER."
+  (let* ((green-sat (ideal-polysaturation-1 (car cond) (cadr cond) order 0 nil ring)))
+    (if (some #'poly-constant-p green-sat)
+	nil
+      (list green-sat (cadr cond)))))
+		       
+(defun string-determine (F vars params
+			 &key (cond '("[]" "[]"))
+			      (main-order #'lex>)
+			      (parameter-order #'lex>)
+			      (suppress-value t)
+			      (suppress-printing nil)
+			      (mark-coefficients nil)
+			      (ring *coefficient-ring*)
+			 &aux 
+			 (F (parse-to-colored-poly-list
+			     F vars params main-order parameter-order))
+			 (cond (string-cond cond params parameter-order)))
+  "A string interface to DETERMINE. See the documentation of STRING-GROBNER-SYSTEM."
+  (let ((gs (determine F cond parameter-order ring)))
+    (unless suppress-printing
+      (cond-system-print gs vars params :mark-coefficients mark-coefficients))
+    (if suppress-value (values) gs)))
+
+(defun tidy-grobner-system (gs main-order parameter-order
+			       reduce green-reduce ring)
+  "Apply TIDY-PAIR to every pair of a Grobner system."
+  (mapcan #'(lambda (p) (tidy-pair p main-order parameter-order reduce green-reduce
+				   ring))
+	  gs))
+
+
+(defun tidy-pair (pair main-order parameter-order
+		       reduce green-reduce ring
+		       &aux gs)
+  "Make the output of Grobner system more readable by performing
+certain simplifications on an element of a Grobner system.
+If REDUCE is non-NIL then COLORED-reduction will be performed.
+In addition TIDY-COND is called on the condition part of the pair PAIR."
+  (if reduce
+      (setf gs (colored-reduction (car pair) (cadr pair)
+				  main-order parameter-order ring))
+    (setf gs (list pair)))
+  (setf gs 
+	(mapcar #'(lambda (pair) 
+		    (list (tidy-cond (car pair) parameter-order
+				     ring)
+			  (cadr pair)))
+		gs))
+  (when green-reduce
+    (setf gs (cond-system-green-reduce gs parameter-order ring)))
+  gs)
+
+(defun tidy-cond (cond order ring)
+  "Currently saturates condition COND and does RED-REDUCTION on the red list."
+  (let ((cond1 (saturate-cond cond order ring)))
+    (list (reduction (car cond1) order ring)
+	  (red-reduction (cadr cond1) order ring))))
+
+(defun colored-reduction (cond P main-order parameter-order ring
+			  &aux (open (list (list cond nil P))) closed)
+  "Reduce a list of colored polynomials P.  The difficulty as compared
+to the usual Buchberger algorithm is that the polys may have the same
+leading monomial which may result in cancellations and polynomials
+which may not be determined. Thus, when we find those, we will have to
+split the condition by calling determine. Returns a list of pairs
+(COND' P') where P' is a reduced grobner basis with respect to any
+parameter choice compatible with condition COND'. Moreover, COND' form
+a cover of COND."
+  ;;We form a list of tripples (CONDITION G U) where G is reduced and U
+  ;;is the unreduced part of the basis and operate on these
+  (do ()
+      ((endp open) closed)
+    (let* ((tuple (pop open))
+	   (cond1 (car tuple))
+	   (G  (cadr tuple))
+	   (U (caddr tuple)))
+      (cond
+       ((endp U)			;no-more undetermined
+	(push (list cond1 G)
+	      closed))
+       (t
+	(let ((f (car U)))
+	  (multiple-value-bind (k div-count)
+	      (cond-normal-form f (append G (cdr U))
+				main-order parameter-order nil ring)
+	    (cond
+	     ((zerop div-count)
+	      (push (list cond1 (append G (list f)) (cdr U)) open))
+	     (t
+	      (do ((delta (determine (list k) cond1 parameter-order ring)
+			  (rest delta)))
+		  ((endp delta))
+		(let* ((eps   (caar delta))
+		       (k1    (caadar delta)))
+		  (cond
+		   ((cond-part k1)	;does not reduce to 0
+		    ;; Replace f with k1 and start all over
+		    (push (list eps nil (append G (list k1) (cdr U)))
+			  open))
+		   (t 
+		    ;; f reduces to 0 so just drop f
+		    (push (list eps G (cdr U)) 
+			  open))))))))))))))
+
+
+(defun green-reduce-colored-poly (cond f parameter-order ring)
+  "It takes a colored polynomial F and it returns a modified
+polynomial obtained by reducing coefficient of F modulo green list of
+the condition COND."
+  (dotimes (i (length f) f)
+    (multiple-value-bind (nf division-count c)
+      (normal-form (cadr (nth i f)) (car cond) parameter-order nil ring)
+      (declare (ignore division-count))
+      (unless (endp nf)
+	(setf f (colored-scalar-times-poly c f ring)))
+      (setf (cadr (nth i f)) nf))))
+    
+					
+(defun green-reduce-colored-list (cond fl parameter-order ring)
+  "Apply GREEN-REDUCE-COLORED-POLY to a list of polynomials FL."
+  (remove-if 
+   #'endp
+   (cond
+     ((endp fl) nil) 
+     (t
+      (cons 
+       (green-reduce-colored-poly cond (car fl) parameter-order ring)
+       (green-reduce-colored-list cond (rest fl) parameter-order ring))))))
+
+(defun cond-system-green-reduce (gs parameter-order ring)
+  "Apply GREEN-REDUCE-COLORED-LIST to every pair of
+a grobner system GS."
+  (cond 
+    ((endp  gs) nil)
+    (t (cons
+	(list (caar gs) (green-reduce-colored-list 
+			 (caar gs) (cadar gs) parameter-order ring))
+	(cond-system-green-reduce (rest gs) parameter-order ring)))))
+
+
+(defun parse-to-colored-poly-list (F vars params main-order parameter-order
+				     &aux (k (length vars))
+				     (vars-params (append vars params)))
+  "Parse a list of polynomials F, given as a string, with respect to
+a list of variables VARS, given as a list of symbols, to the internal
+representation of a colored polynomial. The polynomials will be properly
+sorted by MAIN-ORDER, with the coefficients, which are polynomials in
+parameters, sorted by PARAMETER-ORDER. Both orders must be admissible
+monomial orders. This form is suitable for parsing polynomials with integer
+coefficients."
+  (make-colored-poly-list 
+   (rest (parse-string-to-alist F vars-params))
+   k :main-order main-order :parameter-order parameter-order))
+(defun red-reduction (P pred ring
+		      &aux
+		      (P (remove-if #'poly-constant-p P)))
+  "Takes a family of polynomials and produce a list whose prime factors 
+are the same but they are relatively prime
+Repetitively used the following procedure: it finds two elements f, g of
+P which are not relatively prime; it replaces f and g with f/GCD(f,g),
+ g/ GCD(f,f) and GCD(f,g)."
+  (when (endp P) (return-from red-reduction))
+  (do ((found t))
+      ((or (endp (cdr P)) (not found))
+       (mapcar #'(lambda (x) (grobner-primitive-part x ring)) P))
+    (setf found nil)
+    (tagbody
+      (do ((Q1 P (rest Q1)))
+	  ((endp Q1))
+	(do ((Q2 (rest Q1) (rest Q2)))
+	    ((endp Q2))
+	  (let* ((f (car Q1))
+		 (g (car Q2))
+		 (h (grobner-gcd f g pred ring)))
+	    (unless (poly-constant-p h)
+	      (setf found t
+		    P (remove f P)
+		    P (remove G P)
+		    P (cons h P))
+	      (let ((f1 (poly-exact-divide f h pred ring))
+		    (g1 (poly-exact-divide g h pred ring)))
+		(unless (poly-constant-p f1) (push f1 P))
+		(unless (poly-constant-p g1) (push g1 P)))
+	      (go found)))))
+     found)))
Index: /trunk/src/division.lisp
===================================================================
--- /trunk/src/division.lisp	(revision 14)
+++ /trunk/src/division.lisp	(revision 14)
@@ -0,0 +1,52 @@
+#|
+	$Id: division.lisp,v 1.4 2009/01/22 04:00:56 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+(defpackage "DIVISION"
+  (:use "MONOM" "ORDER" "TERM" "POLY" "COEFFICIENT-RING" "COMMON-LISP")
+  (:export divide poly-exact-divide))
+
+(in-package  "DIVISION")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(defun divide (f fl &optional
+		    (pred #'lex>)
+		    (ring *coefficient-ring*)
+		 &aux (s (length fl)))
+  "Divide polynomial F by a list of polynomials FL; use predicate PRED
+to sort monomials; assumes that the polynomials have initially been
+sorted according to PRED. It returnes multiple values. The first value
+is a list of quotients A.  The second value is the remainder R. These
+object satisfy the quation F = SUM A[J]*FL[I] + R."
+  (do ((a (make-list s))
+       r 
+       (p f)
+       (division-occurred nil nil))
+      ((endp p) (values (mapcar #'reverse a) (reverse r)))
+    (declare (list a r p))
+    (do ((fl fl (rest fl))
+	 (a a (rest a)))
+	((or (endp fl) division-occurred))
+      (when (term-divides-p (car (first fl)) (first p))
+	(let ((quot (term/ (first p) (car (first fl)) ring)))
+	  (push quot (car a))
+	  (setf p (poly-op (rest p) quot (rest (first fl)) pred ring)
+		division-occurred t))))
+    (when (not division-occurred)
+      (setf r (cons (first p) r)
+	    p (rest p))))) 
+	
+(defun poly-exact-divide (f g  &optional (order #'lex>) (ring *coefficient-ring*))
+  "Divide a polynomial F by another polynomial G. Assume that exact division
+with no remainder is possible. Returns the quotient."
+  (multiple-value-bind (q r)
+      (divide f (list g) order ring)
+    (unless (endp r) (error "Exact division failed."))
+    (car q)))
Index: /trunk/src/dynamics.lisp
===================================================================
--- /trunk/src/dynamics.lisp	(revision 14)
+++ /trunk/src/dynamics.lisp	(revision 14)
@@ -0,0 +1,249 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
+#|
+	$Id: dynamics.lisp,v 1.7 2009/01/23 10:49:32 marek Exp $
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+(defpackage "DYNAMICS"
+  (:use "ORDER" "MONOM" "COEFFICIENT-RING" "GROBNER" "MAKELIST" "PRINTER" "TERM" "POLY" "COMMON-LISP")
+  (:export poly-composition poly-scalar-composition poly-dynamic-power
+	   poly-evaluate poly-scalar-evaluate factorial
+	   poly-scalar-diff poly-diff standard-vector
+	   scalar-partial partial drop-elt drop-row drop-column
+	   determinant minor matrix- poly-list-
+	   characteristic-combination
+	   characteristic-matrix
+	   characteristic-polynomial
+	   identity-matrix
+	   print-matrix
+	   jacobi-matrix
+	   jacobian))
+
+(in-package "DYNAMICS")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(defun poly-scalar-composition (f G &optional (order #'lex>))
+  "Returns a polynomial obtained by substituting a list of polynomials G=(G1,G2,...,GN)
+ into a polynomial F(X1,X2,...,XN). All polynomials are assumed to be in the internal form,
+so variables do not explicitly apprear in the calculation."
+  (reduce #'(lambda (x y) (poly+ x y order))
+	  (mapcar #'(lambda (x)
+		      (scalar-times-poly
+		       (cdr x)
+		       (poly-mexpt G (car x) order)))
+		  f)))
+
+(defun poly-composition (F G &optional (order #'lex>))
+  "Return the composition of a polynomial map F with a polynomial map
+G. Both maps are represented as lists of polynomials, and each polynomial
+is in the internal alist representation. The restriction is that the length
+of the list G must be the number of variables in the list F."
+  (mapcar #'(lambda (x) (poly-scalar-composition x G order)) F))
+
+
+(defun poly-dynamic-power (F n &optional (order #'lex>))
+  "Calculate the composition FoFo...oF (n times), where
+F is a polynomial map represented as a list of polynomials."
+  (reduce #'(lambda (x y) (poly-composition x y order))
+	  (make-list n :initial-element F)))
+
+(defun poly-scalar-evaluate (f x &optional (order #'lex>))
+  "Evaluate a polynomial F at a point X. This operation is implemented
+through POLY-SCALAR-COMPOSITION."
+  (if (endp f)
+      0
+    (let ((p (poly-scalar-composition
+	      f
+	      (mapcar #'(lambda (u)
+			  (if (zerop u)
+			      nil
+			    (list (cons (make-list (length (caar f)) :initial-element 0)
+					u))))
+		      x)
+	      order)))
+      (if (endp p) 0
+	(cdar p)))))
+			
+(defun poly-evaluate (F x &optional (order #'lex>))
+  "Evaluate a polynomial map F, represented as list of polynomials, at a point X."
+  (mapcar #'(lambda (h) (poly-scalar-evaluate h x order)) F))
+
+(defun factorial (n &optional (k n) &aux (result 1))
+  "Return N!/(N-K)!=N(N-1)(N-K+1)."
+  (dotimes (j k result)
+    (setf result (* result (- n j)))))
+
+(defun poly-scalar-diff (f m)
+  "Return the partial derivative of a polynomial F over multiple
+  variables according to multiindex M."
+  (setf f (remove-if #'(lambda (x) (some #'< (car x) m)) f))
+  (mapcar #'(lambda (x) (cons (monom/ (car x) m)
+			      (* (cdr x) (apply #'* (mapcar #'factorial (car x) m)))))
+	  f))
+  
+(defun poly-diff (F m)
+  "Return the partial derivative of a polynomial map F, represented as a list of polynomials,
+with respect to several variables, according to multi-index M."
+  (mapcar #'(lambda (h) (poly-scalar-diff h m)) F))
+
+
+(defun scalar-partial (f k &optional (l 1))
+  "Returns the L-th partial derivative of a polynomial F over the K-th variable."
+  (when f
+    (poly-scalar-diff f (standard-vector (length (caar f)) k l))))
+
+(defun partial (F k &optional (l 1))
+  "Returns the L-th partial derivative over the K-th variable, of a polynomial
+map F, represented as a list of polynomials."
+  (when (and F (car F) (caar F))
+    (poly-diff F (standard-vector (length (caaar F)) k l))))
+
+
+(defun determinant (F &optional (order #'lex>) &aux (result nil))
+  "Returns the determinant of a polynomial matrix F, which is a list of
+rows of the matrix, each row is a list of polynomials.  The algorithm
+is recursive expansion along columns."
+  (cond 
+   ((= (length F) 1) (setf result (caar F)))
+   (t
+    (dotimes (i (length F) result)
+      (setf result (poly+ result
+			  (scalar-times-poly
+			   (expt -1 i)
+			   (poly* (car (elt F i)) (minor F i 0 order) order))
+			  order))))))
+
+
+(defun minor (F i j &optional (order #'lex>))
+  "Calculate the minor of a polynomial matrix F with respect to entry (I,J)."
+  (determinant (drop-row (drop-column F j) i) order))
+
+(defun drop-row (F i)
+  "Discards the I-th row from a polynomial matrix F."
+  (drop-elt F i))
+
+(defun drop-column (F j)
+  "Discards the J-th column from a polynomial matrix F."
+  (mapcar #'(lambda (x) (drop-elt x j)) F))
+
+(defun drop-elt (lst j)
+  "Discards the J-th element from a list LST."
+  (append (subseq lst 0 j) (subseq lst (1+ j))))
+
+;; Matrix operations
+
+(defun matrix- (F G &optional (order #'lex>))
+  "Returns difference of two polynomial matrices F and G."
+  (mapcar #'(lambda (x y) (poly-list- x y order)) F G))
+
+(defun scalar-times-matrix (s F)
+  "Returns a product of a polynomial S by a polynomial matrix F."
+  (mapcar #'(lambda (x) (scalar-times-poly-list s x)) F))
+
+(defun monom-times-matrix (m F)
+  "Returns a product of a monomial M by a polynomial matrix F."  
+  (mapcar #'(lambda (x) (monom-times-poly-list m x)) F))
+
+(defun term-times-matrix (term F)
+  "Returns a product of a term TERM by a polynomial matrix F."  
+  (mapcar #'(lambda (x) (term-times-poly-list term x)) F))
+
+
+;; Polynomial list operations
+(defun poly-list- (F G &optional (order #'lex>))
+  "Returns the list of differences of two lists of polynomials
+F and G (polynomial maps)."
+  (mapcar #'(lambda (x y) (poly- x y order)) F G))
+
+(defun scalar-times-poly-list (s F)
+  "Returns the list of products of a polynomial S by the
+list of polynomials F."
+  (mapcar #'(lambda (x) (scalar-times-poly s x)) F))
+
+(defun monom-times-poly-list (m f)
+  "Returns the list of products of a monomial M by the
+list of polynomials F."
+  (mapcar #'(lambda (x) (monom-times-poly m x)) F))
+       
+(defun term-times-poly-list (term f)
+  "Returns the list of products of a term TERM by the
+list of polynomials F."
+  (mapcar #'(lambda (x) (term-times-poly term x)) F))
+       
+;; Generalized Characteristic polynomial operations
+;; det(A - u1*B1-u2*B2-...-um*Bm)
+
+(defun characteristic-combination (A B &optional (order #'lex>)
+						 &aux (n (length B)))
+  "Returns A - U1 * B1 - U2 * B2 - ... - UM * BM where A is a polynomial
+and B=(B1,B2,...,BM) is a polynomial list, where U1, U2, ... , UM are
+new variables. These variables will be added to every polynomial
+A and BI as the last M variables."
+  (setf A (poly-extend-end A (make-list n :initial-element 0)))
+  (dotimes (i (length B) A)
+    (setf A (poly- A  (poly-extend-end (elt B i) (standard-vector n i)) order))))
+						 
+;; A is a list of polynomials; B is a list of lists of polynomials
+(defun characteristic-combination-poly-list (A B &optional (order #'lex>))
+  "Returns A - U1 * B1 - U2 * B2 - ... - UM * BM where A is a polynomial list
+and B=(B1, B2, ... , BM) is a list of polynomial lists, where U1, U2, ... ,UM are
+new variables. These variables will be added to every polynomial
+A and BI as the last M variables. Se also CHARACTERISTIC-COMBINATION."
+  (apply #'mapcar 
+	 (cons #'(lambda (&rest x)
+		   (funcall #'characteristic-combination (car x) (rest x) order))
+	       (cons A B))))
+  
+;; Finally, the case of matrices
+(defun characteristic-matrix (A &optional
+				(order #'lex>)
+				(B (list (identity-matrix (length A) (length (caaaar A))))))
+  "Returns A - U1*B1 - U2*B2 - ... - UM * BM where A is a polynomial matrix
+and B=(B1,B2,...,BM) is a list of polynomial matrices, where U1, U2, .., UM are
+new variables. These variables will be added to every polynomial
+A and BI as the last M variables. Se also CHARACTERISTIC-COMBINATION."
+  (apply #'mapcar 
+	 (cons #'(lambda (&rest x)
+		   (funcall #'characteristic-combination-poly-list (car x) (rest x) order))
+	       (cons A B))))
+
+;; Characteristic polynomial
+(defun characteristic-polynomial (A &optional
+				    (order #'lex>)
+				    (B (list (identity-matrix (length A) (length (caaaar A))))))
+  "Returns the generalized characteristic polynomial, i.e. the determinant
+DET(A - U1 * B1 - U2 * B2 - ... - UM * BM), where A and BI are square polynomial matrices in
+N variables. The resulting polynomial will have N+M variables, with U1, U2, ..., UM added
+as the last M variables."
+  (determinant (characteristic-matrix A order B) order))
+
+(defun identity-matrix (dim nvars)
+  "Return the polynomial matrix which is the identity matrix. DIM is the requested
+dimension and NVARS is the number of variables of each entry."
+  (labels ((zero-monom () (make-list nvars :initial-element 0))
+	   (entry (i j) (if (= i j)
+			    (list (cons (zero-monom) 1))
+			  nil)))
+    (makelist (makelist (entry i j) (i 1 dim)) (j 1 dim))))
+
+(defun print-matrix (F vars)
+  "Prints a polynomial matrix F, using a list of symbols VARS as variable names."
+  (mapcar #'(lambda (x) (poly-print (cons '[ x) vars) (terpri)) F)
+  F)
+
+(defun jacobi-matrix (F &optional (m (length F)) (n (length (caaaar F))))
+  "Returns the Jacobi matrix of a polynomial list F over the first N variables."
+  (makelist (makelist (scalar-partial (elt F i) j)
+		      (j 0 (1- n)))
+	    (i 0 (1- m))))
+
+(defun jacobian (F &optional (order #'lex>) (m (length F)) (n (length (caaaar F))))
+  "Returns the Jacobian (determinant) of a polynomial list F over the first N variables."
+  (determinant (jacobi-matrix F m n) order))
Index: /trunk/src/example.lisp
===================================================================
--- /trunk/src/example.lisp	(revision 14)
+++ /trunk/src/example.lisp	(revision 14)
@@ -0,0 +1,57 @@
+#|
+	$Id: example.lisp,v 1.2 2009/01/22 04:01:51 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+(defpackage "CGB-LISP"
+  (:use "MAKELIST" "ORDER" "MONOM" "COEFFICIENT-RING"
+    "TERM" "POLY" "DIVISION" "PARSE" "PRINTER" "POLY-WITH-SUGAR"
+    "GROBNER" "COLORED-POLY" "POLY-GCD" "RAT" "RATPOLY"
+    "STRING-GROBNER" "DYNAMICS" 
+    "INFIX" "COMMON-LISP"))
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(defun example (symbol &optional (stream t))
+    "Run short examples associated with a symbol, which typically is a function name."
+    (dolist (e (cdr (assoc symbol *examples*)))
+      (run-example e stream))
+    (values))
+
+(defun run-example (e stream)
+  "Evaluate a single form E and send output to stream STREAM."
+  (format stream "~%;;----------------------------------------------------------------")
+  (format stream "~%;;")
+  (format stream "~%;;~1T~S" e)
+  (format stream "~%;;")
+  (format stream "~%;;----------------------------------------------------------------~&")
+  (dolist (val (multiple-value-list (eval e)))
+    (format stream "[ RETURN VALUE ]-->> ~S~&" val))
+  (values))
+
+(defun all-examples (&optional (stream t))
+  "Run all available examples and send output to STREAM."
+  (dolist (a *examples*)
+    (dolist (e (cdr a))
+      (run-example e stream)))
+  (values))
+  
+
+(defvar *examples*
+    '((string-grobner . ((string-grobner "[x^2+y,x-y]" '(x y))
+			(string-grobner "[y-x^2,z-x^3]" '(x y z) :order #'grevlex>)))
+      (string-grobner-system . ((string-grobner-system "[u*x+y,x+y]" '(x y) '(u))
+				(string-grobner-system "[u*x+y,x+y]" '(x y) '(u) :cover '(("[u-1]" "[]")))))
+      (string-read-poly . ((string-read-poly "[x^3+3*x^2+3*x+1]" '(x))))
+      (string-elimination-ideal . ((string-elimination-ideal "[x^2+y^2-2,x*y-1]" '(x y) 1)))
+      (string-ideal-saturation . ((string-ideal-saturation "[x^2*y,y^3]" "x" '(x y))))
+      (string-ideal-polysaturation . ((string-ideal-polysaturation "[x^2*y,y^3]" "[x,y]" '(x y)))))
+  "A list of available examples.")
+
+
Index: /trunk/src/grobner.lisp
===================================================================
--- /trunk/src/grobner.lisp	(revision 14)
+++ /trunk/src/grobner.lisp	(revision 14)
@@ -0,0 +1,1699 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
+#|
+	$Id: grobner.lisp,v 1.8 2009/01/23 10:40:26 marek Exp $
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+(defpackage "GROBNER"
+  (:use "ORDER" "PARSE" "PRINTER" "DIVISION" "MONOM"
+	"MAKELIST" "COEFFICIENT-RING" "TERM" "POLY"
+	"POLY-WITH-SUGAR" "COMMON-LISP")
+  (:export
+   spoly
+   grobner
+   reduction
+   normal-form
+   reduced-grobner
+   normalize-poly
+   normalize-basis
+   elimination-ideal
+   ring-intersection
+   poly-contract
+   ideal-intersection
+   poly-lcm
+   grobner-gcd
+   pseudo-divide
+   buchberger-criterion
+   grobner-test
+   grobner-equal
+   grobner-subsetp
+   grobner-member
+   ideal-equal
+   ideal-subsetp
+   ideal-member
+   ideal-saturation
+   ideal-polysaturation
+   ideal-saturation-1
+   ideal-polysaturation-1
+   grobner-primitive-part
+   grobner-content
+   colon-ideal
+   *grobner-debug*
+   buchberger-set-pair-heuristic
+   gebauer-moeller-set-pair-heuristic
+   select-grobner-algorithm
+   spoly-with-sugar
+   normal-form-with-sugar
+   grobner-with-sugar
+   ))
+
+(in-package "GROBNER")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+#+debug
+(defvar *grobner-debug* nil
+  "If T, produce debugging and tracing output.")
+
+(defvar *buchberger-merge-pairs* 'buchberger-merge-pairs-smallest-lcm
+  "A variable holding the predicate used to sort critical pairs
+in the order of decreasing priority for the Buchberger algorithm.")
+
+(defvar *gebauer-moeller-merge-pairs* 'gebauer-moeller-merge-pairs-use-mock-spoly
+  "A variable holding the predicate used to sort critical pairs
+in the order of decreasing priority for the Gebauer-Moeller algorithm")
+
+(defvar *grobner-function* 'buchberger
+  "The name of the function used to calculate Grobner basis")
+
+(defun select-grobner-algorithm (algorithm)
+  "Select one of the several implementations of the Grobner basis
+algorithm."
+  (setf *grobner-function*
+    (ecase algorithm
+      (:buchberger 'buchberger)
+      (:cached-buchberger 'cached-buchberger)
+      (:gebauer-moeller 'gebauer-moeller)
+      (:sugar 'buchberger-with-sugar)
+      (:cached-sugar 'cached-buchberger-with-sugar)
+      (:gebauer-moeller-with-sugar 'gebauer-moeller-with-sugar))))
+
+(defun grobner (F &optional (pred #'lex>)
+			    (start 0)
+			    (top-reduction-only nil)
+			    (ring *coefficient-ring*))
+  "Return Grobner basis of an ideal generated by polynomial list F.
+Assume that the monomials of each polynomial are ordered according to
+the admissible monomial order PRED. The result will be a list of
+polynomials ordered as well according to PRED. The polynomials from 0
+to START-1 in the list F are assumed to be a Grobner basis, and thus
+certain critical pairs do not have to be calculated. If
+TOP-REDUCTION-ONLY is not NIL then only top reductions will be
+performed, instead of full division, and thus the returned Grobner
+basis will have its polynomials only top-reduced with respect to the
+preceding polynomials. RING should be set to the RING structure (see
+COEFFICIENT-RING package) corresponding to the coefficients of the
+polynomials in the list F. This function is currently just an
+interface to several algorithms which fine Grobner bases. Use
+SELECT-GROBNER-ALGORITHM in order to change the algorithm."
+  (funcall *grobner-function* F pred start top-reduction-only ring))
+
+
+#+debug
+(defmacro debug-cgb (&rest args)
+  "This macro is used in printing debugging and tracing messages
+and its arguments are analogous to the FORMAT function, except
+that the stream argument is omitted. By default, the output is
+sent to *trace-output*, which can be set to produce output 
+in a file."
+  `(when *grobner-debug* (format *trace-output* ,@args)))
+
+(defun spoly (f g pred ring)
+  "Return the S-polynomial of F and G, which should
+be two polynomials with terms ordered by PRED and
+coefficients in a ring whose operations are the slots
+of the RING structure."
+  (declare (optimize (speed 3) (safety 0)))
+  (let* ((lcm (monom-lcm (lm f) (lm g)))
+	 (m1 (monom/ lcm (lm f)))
+	 (m2 (monom/ lcm (lm g))))
+    (let* ((c (funcall (ring-lcm ring) (lc f) (lc g)))
+	   (cf (funcall (ring-/ ring) c (lc f)))
+	   (cg (funcall (ring-/ ring) c (lc g))))
+      (poly-
+       (term-times-poly (cons m1 cf) (rest f) ring)
+       (term-times-poly (cons m2 cg) (rest g) ring)
+       pred
+       ring))))
+
+
+(defun grobner-primitive-part (p ring)
+  "Divide polynomial P with integer coefficients by gcd of its
+coefficients and return the result. Use the RING structure from the
+COEFFICIENT-RING package to perform the operations on the
+coefficients."
+  (if (poly-zerop p)
+      (values p 1)
+    (let ((c (grobner-content p ring)))
+      (values (mapcar
+	       #'(lambda (x)
+		   (cons (car x)
+			 (funcall
+			  (ring-/ ring)
+			  (cdr x) c)))
+	       p)
+	      c))))
+
+
+(defun grobner-content (p ring)
+  "Greatest common divisor of the coefficients of the polynomial P. Use the RING structure
+to compute the greatest common divisor."
+  (let ((c (apply (ring-gcd ring) (mapcar #'cdr p))))
+    (when (/= (funcall (ring-signum ring) (cdar p))
+	      (funcall (ring-signum ring) c))
+      (setf c (funcall (ring-- ring) c)))
+    c))
+
+(defun normal-form (f fl pred  top-reduction-only ring)
+  "Calculate the normal form of the polynomial F with respect to
+the polynomial list FL. Destructive to F; thus, copy-tree should be used
+where F needs to be preserved. It returns multiple values.
+The first value is the polynomial R which is reduced (or top-reduced
+if TOP-REDUCTION-ONLY is not NIL). The second value is an integer
+which is the number of reductions actually performed. The third value
+is the coefficient by which F needs to be multiplied in order to be
+able to perform the division without actually having to divide in the
+coefficient ring (a form of pseudo-division is used). All operations
+on the coefficients are performed using the RING structure from the
+COEFFICIENT-RING package."
+  (declare (optimize (speed 3) (safety 0)))
+  ;; Loop invariant: c*f=sum ai*fi+r+p
+  (do (r (c (ring-unit ring))
+       (division-count 0)
+       (p f))
+      ((or (endp p)
+	   (endp fl)
+	   (and top-reduction-only r))
+       #+debug(progn
+		(debug-cgb "~&~3T~d reduction~:p" division-count)
+		(when (endp r)
+		  (debug-cgb " ---> 0")))
+       (values (append (nreverse r) p)
+	       division-count c))
+    (declare (fixnum division-count) (integer c))
+    (let ((g (find (lm p) fl :test #'monom-divisible-by-p :key #'lm)))
+      (cond 
+       (g				;division possible
+	(incf division-count)
+	(let* ((gcd (funcall (ring-gcd ring) (lc g) (lc p)))
+	       (c1 (funcall (ring-/ ring) (lc g) gcd))
+	       (c2 (funcall (ring-/ ring) (lc p) gcd))
+	       (m (monom/ (lm p) (lm g))))
+	  ;; Multiply the equation c*f=sum ai*fi+r+p by c1.
+	  (setf r (scalar-times-poly c1 r ring)
+		c (funcall (ring-* ring) c c1)
+		p (grobner-op c2 c1 m (rest p) (rest g) pred ring))))
+       (t				;no division possible
+	(setf r (cons (lt p) r)		;move lt(p) to remainder
+	      p (rest p)))))))		;remove lt(p) from p	
+
+(defun buchberger (F pred start top-reduction-only ring 
+		   &aux (s (1- (length F))) B M)
+  "An implementation of the Buchberger algorithm. Return Grobner
+basis of the ideal generated by the polynomial list F.
+The terms of each polynomial are ordered by the admissible
+monomial order PRED. Polynomials 0 to START-1 are assumed to
+be a Grobner basis already, so that certain critical pairs
+will not be examined. If TOP-REDUCTION-ONLY set, top reduction
+will be preformed. The RING structure is used to perform operations
+on coefficents (see COEFFICIENT-RING package)."
+  (declare (fixnum s))
+  (unless (plusp s) (return-from buchberger F)) ;cut startup costs
+  #+debug (debug-cgb "~&GROBNER BASIS - BUCHBERGER ALGORITHM")
+  #+debug (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
+  #+grobner-check  (when (plusp start)
+		     (grobner-test (subseq F 0 start) (subseq F 0 start) pred ring))
+  (setf B (nconc (makelist (list i j) (i 0 (1- start)) (j start s))
+		 (makelist (list i j) (i start (1- s)) (j (1+ i) s)))
+	M (make-hash-table :test #'equal)
+	B (buchberger-sort-pairs B F pred ring))
+  ;;Initialize treated pairs
+  (dotimes (i (1- start))
+    (do ((j (1+ i) (1+ j))) ((>= j start))
+      (setf (gethash (list i j) M) t)))
+  (do ((G F))
+      ((endp B)
+       #+grobner-check(grobner-test G F pred ring)
+       #+debug(debug-cgb "~&GROBNER END")
+       G)
+    (let ((pair (pop B)))
+      (unless (or (Criterion-1 pair G)
+		  (Criterion-2 pair G M))
+	(let ((SP (normal-form (spoly (elt G (first pair))
+				      (elt G (second pair))
+				      pred
+				      ring)
+			       G pred top-reduction-only ring)))
+	  (unless (poly-zerop SP)	;S-polynomial ---> 0;
+	    (setf s (1+ s)
+		  SP (grobner-primitive-part SP ring)
+		  G (nconc G (list SP))
+		  B (funcall *buchberger-merge-pairs* B (makelist (list i s)
+							       (i 0 (1- s)))
+			     G pred ring))
+	    #+debug (debug-cgb "~&Polynomials: ~d; Pairs left: ~d; Treated pairs: ~d"
+			       (length G) (length B)
+			       (hash-table-count M)))))
+      (setf (gethash pair M) t))))
+
+(defun grobner-op (c1 c2 m A B pred ring &aux n A1 A2)
+  "Perform a calculation equivalent to
+(POLY- (SCALAR-TIMES-POLY C2 A)
+	 (SCALAR-TIMES-POLY C1 (MONOM-TIMES-POLY M B))
+	 PRED)
+but more efficiently; it destructively modifies A and stores the 
+result in it; A is returned."
+  (dolist (x A) (setf (cdr x) (funcall (ring-* ring) c2 (cdr x))))
+  (unless B
+    (return-from grobner-op A))
+  (unless A
+    (return-from grobner-op
+      (mapcar 
+       #'(lambda (x) (cons (monom* m (car x))
+			   (funcall (ring-- ring)
+				    (funcall (ring-* ring)
+					     c1 (cdr x)))))
+       B)))
+  (setf A1 (cons nil A)	A2 A1)
+  (tagbody
+   begin-outer-loop
+    (unless B
+      (return-from grobner-op (cdr A2)))
+    (setf n (monom* m (caar B)))
+    (tagbody
+     begin-inner-loop
+      (unless (cdr A1)
+	(setf (cdr A1) 
+	  (mapcar #'(lambda (x) (cons (monom* m (car x))
+				      (funcall (ring-- ring)
+					       (funcall (ring-* ring)
+							c1 (cdr x))))) B))
+	(return-from grobner-op (cdr A2)))
+      (multiple-value-bind (lm-greater lm-equal)
+	  (funcall pred (caadr A1) n)
+	(cond
+	 (lm-equal
+	  (let ((s (funcall (ring-- ring)
+			    (cdadr A1)
+			    (funcall (ring-* ring) c1 (cdar B)))))
+	    (if (funcall (ring-zerop ring) s) ;check for cancellation
+		(setf (cdr A1) (cddr A1))
+	      (setf (cdadr A1) s))
+	    (setf B (cdr B))
+	    (go begin-outer-loop)))
+	 (lm-greater
+	  (setf A1 (cdr A1))
+	  (go begin-inner-loop))
+	 (t				;(lm B) is greater than (lm A)
+	  (setf (cdr A1)
+		(cons
+		 (cons
+		  n
+		  (funcall (ring-- ring)
+			   (funcall (ring-* ring) c1 (cdar B))))
+		 (cdr A1))
+		B (cdr B)
+		A1 (cdr A1))
+	  (go begin-outer-loop)))))))
+
+;;----------------------------------------------------------------
+;; Pairs
+;;----------------------------------------------------------------
+
+(defun buchberger-sort-pairs (B G pred ring)
+  "Sort critical pairs B by the function which is
+the value of the vairable *buchberger-merge-pairs*.
+G is the list of polynomials which the elemnts
+of B point into. PRED is the admissible monomial order.
+The RING structure holds operations on the coefficients
+as described in the COEFFICIENT-RING package."
+  (funcall *buchberger-merge-pairs* nil B G pred ring))
+
+
+(defun mock-spoly (f g pred)
+  "Returns an upper-bound on the leading
+monomial of the S-polynomial of F and G, which are two polynomials
+sorted by the admissible monomial order PRED."
+  (let* ((lcm (monom-lcm (lm f) (lm g)))
+	 (m1 (monom/ lcm (lm f)))
+	 (m2 (monom/ lcm (lm g))))
+    (cond 
+     ((endp (second f))
+      (monom* m2 (car (second g))))
+     ((endp (second g))
+      (monom* m1 (car (second f))))
+     (t (let ((n1 (monom* m2 (car (second g))))
+	      (n2 (monom* m1 (car (second f)))))
+	  (if (funcall pred n1 n2)
+	      n1
+	    n2))))))
+
+;;----------------------------------------------------------------
+;; A stragegy based on a predicted approximate S-polynomials
+;;----------------------------------------------------------------
+(defun buchberger-merge-pairs-use-mock-spoly (B C G pred ring)
+  "Merges lists of critical pairs B and C into one list. 
+The pairs are assumed to be ordered according to the
+increasing value of MOCK-SPOLY, as determined by the admissible
+monomial order PRED. G is the list of polynomials which the pairs
+of integers in B and C point into, and RING is the ring structure
+defined in the COEFFICIENT-RING package."
+  (declare (ignore ring))
+  ;; Delete pairs consisting of two single monomials
+  (setf C (delete-if
+	   #'(lambda (p) (and (endp (cdr (elt G (first p))))
+			      (endp (cdr (elt G (second p))))))
+	   C))
+  (labels ((pair-key (p) (mock-spoly (elt G (first p))
+				     (elt G (second p)) pred))
+	   (pair-order (x y) (funcall pred y x)))
+    (merge 'list B (sort C #'pair-order :key #'pair-key)
+	   #'pair-order :key #'pair-key)))
+
+
+;;----------------------------------------------------------------
+;; A strategy based on the smallest lcm of the leading
+;; monomials of the two polynomials - so called normal strategy
+;;----------------------------------------------------------------
+(defun buchberger-merge-pairs-smallest-lcm (B C G pred ring)
+  "Merges lists of critical pairs B and C into a single ordered
+list. Implements a strategy of ordering pairs according to the
+smallest lcm of the leading monomials of the two polynomials - so
+called normal strategy."
+  (declare (ignore ring))
+  (labels ((pair-key (p) (monom-lcm (lm (elt G (first p)))
+				    (lm (elt G (second p)))))
+	   (pair-order (x y) (funcall pred y x)))
+    (merge 'list B (sort C #'pair-order :key #'pair-key)
+	   #'pair-order :key #'pair-key)))
+
+;;----------------------------------------------------------------
+;; A strategy based on the smallest degree of the lcm of the leading
+;; monomials of the two polynomials
+;;----------------------------------------------------------------
+(defun buchberger-merge-pairs-use-smallest-degree (B C G pred ring)
+  "Mergest lists B and C of critical pairs. This strategy is based on
+ ordering the pairs according to the smallest degree of the lcm of the
+ leading monomials of the two polynomials."
+  (declare (ignore pred ring))
+  (labels ((pair-key (p) (total-degree
+			  (monom-lcm (lm (elt G (first p)))
+				     (lm (elt G (second p)))))))
+    (merge 'list B (sort C #'< :key #'pair-key) #'< :key #'pair-key)))
+
+(defun buchberger-merge-pairs-use-smallest-length (B C G pred ring)
+  "Mergest lists B and C of critical pairs. This strategy is based on
+ ordering the pairs according to the smallest total length of the 
+ two polynomials, where length is the number of terms."
+  (declare (ignore pred ring))
+  (labels ((pair-key (p) (+
+			  (length (elt G (first p)))
+			  (length (elt G (second p))))))
+    (merge 'list B (sort C #'< :key #'pair-key) #'< :key #'pair-key)))
+
+(defun buchberger-merge-pairs-use-smallest-coefficient-length (B C G pred ring)
+  "Mergest lists B and C of critical pairs. This strategy is based on
+ ordering the pairs according to the smallest combined length of the 
+ coefficients of the two polynomials."
+  (declare (ignore pred))
+  (labels ((coefficient-length (poly)
+	     (apply #'+ (mapcar (ring-length ring)
+				(mapcar #'cdr poly))))
+	   (pair-key (p) (+
+			  (coefficient-length (elt G (first p)))
+			  (coefficient-length (elt G (second p))))))
+    (merge 'list B (sort C #'< :key #'pair-key) #'< :key #'pair-key)))
+
+(defun buchberger-set-pair-heuristic
+    (method
+     &aux
+     (strategy-fn
+      (ecase method
+	(:minimal-mock-spoly #'buchberger-merge-pairs-use-mock-spoly)
+	(:minimal-lcm #'buchberger-merge-pairs-smallest-lcm)
+	(:minimal-total-degree #'buchberger-merge-pairs-use-smallest-degree)
+	(:minimal-length #'buchberger-merge-pairs-use-smallest-length)
+	(:minimal-coefficient-length #'buchberger-merge-pairs-use-smallest-coefficient-length))))
+  "Simply sets the variable *buchberger-merge-pairs* to the heuristic
+function STRATEGY-FN implementing one of several strategies introduces
+before of selecting the most promising. METHOD should be one of the
+listed keywords."
+  (setf *buchberger-merge-pairs* strategy-fn))
+
+;;----------------------------------------------------------------
+;; Grobner Criteria
+;;----------------------------------------------------------------
+(defun Criterion-1 (pair G &aux (i (first pair)) (j (second pair)))
+  "Returns T if the leading monomials of the two polynomials
+in G pointed to by the integers in PAIR have disjoint (relatively prime)
+monomials. This test is known as the first Buchberger criterion."
+  (monom-rel-prime (lm (elt G i))
+		   (lm (elt G j))))
+
+
+(defun Criterion-2 (pair G M &aux (i (first pair)) (j (second pair)))
+  "Returns T if the leading monomial of some element P of G divides
+the LCM of the leading monomials of the two polynomials in the
+polynomial list G, pointed to by the two integers in PAIR, and P
+paired with each of the polynomials pointed to by the the PAIR has
+already been treated, as indicated by the hash table M, which stores
+value T for every treated pair so far."
+  (labels ((make-pair (u v) (if (< u v) (list u v) (list v u))))
+    (dotimes (k (length G) nil)
+      (when (and (/= k i)
+		 (/= k j)
+		 (monom-divides-p
+		  (lm (elt G k))
+		  (monom-lcm (lm (elt G i)) (lm (elt G j))))
+		 (gethash (make-pair i k) M)
+		 (gethash (make-pair k j) M))
+	#+debug(when *grobner-debug* (format t ":B2"))
+	(return-from Criterion-2 t)))))
+
+;;----------------------------------------------------------------
+;; End of GROBNER implementation
+;;----------------------------------------------------------------
+
+(defun normalize-poly (p ring)
+  "Divide a polynomial by its leading coefficient. It assumes
+that the division is possible, which may not always be the
+case in rings which are not fields. The exact division operator
+is assumed to be provided by the RING structure of the
+COEFFICIENT-RING package."
+  (mapcar #'(lambda (term)
+	      (cons
+	       (car term)
+	       (funcall (ring-/ ring) (cdr term) (lc p)))) p))
+
+(defun normalize-basis (plist ring)
+  "Divide every polynomial in a list PLIST by its leading coefficient.
+Use RING structure to perform the division of the coefficients."
+  (mapcar #'(lambda (x) (normalize-poly x ring)) plist))
+
+(defun reduction (P pred ring)
+  "Reduce a list of polynomials P, so that non of the terms in any of the
+polynomials is divisible by a leading monomial of another polynomial.
+Return the reduced list."
+  (do ((Q P)
+       (found t))
+      ((not found)
+       (mapcar #'(lambda (x) (grobner-primitive-part x ring)) Q))
+    ;;Find p in Q such that p is reducible mod Q\{p}
+    (setf found nil)
+    (dolist (x Q)
+      (let ((Q1 (remove x Q)))
+	(multiple-value-bind (h div-count)
+	    (normal-form x Q1
+			 pred
+			 nil		;not a top reduction
+			 ring)
+	  (unless (zerop div-count)
+	    (setf found t Q Q1)
+	    (when h
+	      (setf Q (nconc Q1 (list  h))))
+	    (return)))))))
+
+
+(defun reduced-grobner (F &optional (pred #'lex>)
+				    (start 0)
+				    (top-reduction-only nil)
+				    (ring *coefficient-ring*))
+  "Return the reduced Grobner basis of the ideal generated by a polynomial
+list F. This combines calls to two functions: GROBNER and REDUCTION.
+The parameters have the same meaning as in GROBNER or BUCHBERGER."
+  (reduction (grobner F pred start top-reduction-only ring) pred ring))
+
+#+kcl
+(defvar *vars* nil "Keep track of variables for tracing SPOLY.")
+
+;; Does the monomial P depend on variable K
+(defun monom-depends-p (m k)
+  "Return T if the monomial M depends on variable number K."
+  (plusp (elt m k)))
+
+;; Does the term depend on variable K
+(defun term-depends-p (term k)
+  "Return T if the term TERM depends on variable number K."
+  (monom-depends-p (car term) k))
+
+;; Does the polynomial P depend on variable K
+(defun poly-depends-p (p k)
+  "Return T if the term polynomial P depends on variable number K."
+  (some #'(lambda (term) (term-depends-p term k)) p))
+
+(defun ring-intersection (plist k &key (key #'identity))
+  "This function assumes that polynomial list PLIST is a Grobner basis
+and it calculates the intersection with the ring R[x[k+1],...,x[n]], i.e.
+it discards polynomials which depend on variables x[0], x[1], ..., x[k]."
+  (dotimes (i k plist)
+    (setf plist
+	  (remove-if #'(lambda (p)
+			 (poly-depends-p p (funcall key i)))
+		     plist))))
+
+(defun elimination-ideal (flist k
+				&key
+				(primary-order #'lex>)
+				(secondary-order #'lex>)
+				(start 0)
+				(order (elimination-order
+					k
+					:primary-order primary-order
+					:secondary-order secondary-order
+					))
+				(top-reduction-only nil)
+				(ring *coefficient-ring*))
+  "Returns the K-th elimination ideal of the ideal generated by polynomial list FLIST.
+Thus, a Grobner basis of the ideal generated by FLIST is calculated and
+polynomials depending on variables 0-K are discarded. The monomial order in the
+calculation is an elimination order formed by combining two orders: PRIMARY-ORDER
+used on variables 0-K and SECONDARY-ORDER used on variables starting from variable K+1.
+Thus, if both orders are set to the lexicographic order #'LEX> then the resulting
+order is simply equivalent to #'LEX>. But one could use arbitrary two orders in this
+function, for instance, two copies of #'GREVLEX> (see ORDER package). When doing so,
+the caller must ensure that the same order has been used to sort the terms of
+the polynomials FLIST."
+  (ring-intersection
+   (reduced-grobner flist order start top-reduction-only ring)
+   k))
+
+
+(defun ideal-intersection (F G pred top-reduction-only ring)
+  "Return the Grobner basis of the intersection of the ideals
+generated by the polynomial lists F and G. PRED is an admissible
+monomial order with respect to which the terms of F and G have been
+sorted. This order is going to be used in the Grobner basis
+calculation. If TOP-REDUCTION-ONLY is not NIL, internally the Grobner
+basis algorithm will perform top reduction only.  The RING parameter,
+as usual, should be set to a structure defined in the package
+COEFFICIENT-RING, and it will be used to perform all operations on
+coefficients."
+  (mapcar
+   #'poly-contract
+   (ring-intersection
+    (reduced-grobner
+     (append
+      (mapcar #'(lambda (p) (poly-extend p (list 1))) F)
+      (mapcar #'(lambda (p)
+		  (append (poly-extend (minus-poly p ring) (list 1))
+			  (poly-extend p)))
+	      G))
+     (elimination-order-1 pred)
+     0
+     top-reduction-only
+     ring)
+    1)))
+
+
+(defun poly-contract (f &optional (k 1))
+  "Return a polynomial obtained from polynomial F by dropping the
+first K variables, if F does not depend on them.  Note that this
+operation makes the polynomial incompatible for certain arithmetical
+operations with the original polynomial F. Calling this function on a polynomial F
+which does depend on variables 0-K will result in error."
+  (when (some #'(lambda (term) (find-if-not #'zerop (car term) :end k)) f)
+    (error "Contracting a polynomial which depends on contracted variables"))
+  (mapcar #'(lambda (term) (cons (nthcdr k (car term)) (cdr term))) f))
+
+
+(defun poly-lcm (f g &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Return LCM (least common multiple) of two polynomials F and G.
+The polynomials must be ordered according to monomial order PRED
+and their coefficients must be compatible with the RING structure
+defined in the COEFFICIENT-RING package."
+  (cond
+    ((endp f) nil)
+    ((endp g) nil)
+    ((and (endp (cdr f)) (endp (cdr g)))
+     (list (cons (monom-lcm (caar f) (caar g))
+		 (lcm (cdar f) (cdar g)))))
+    (t
+     (multiple-value-bind (f f-cont)
+	 (grobner-primitive-part f ring)
+       (multiple-value-bind (g g-cont)
+	   (grobner-primitive-part g ring)
+	 (scalar-times-poly
+	  (funcall (ring-lcm ring) f-cont g-cont)
+	  (grobner-primitive-part (car (ideal-intersection (list f) (list g) pred nil ring))
+				  ring)
+	  ring))))))
+
+;; GCD of two polynomials, using Grobner bases
+(defun grobner-gcd (f g &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Return GCD (greatest common divisor) of two polynomials F and G.
+The polynomials must be ordered according to monomial order PRED
+and their coefficients must be compatible with the RING structure
+defined in the COEFFICIENT-RING package."
+  (poly-exact-divide (poly* f g pred ring)
+		     (poly-lcm f g pred ring)
+		     pred ring))
+
+;; Do two Grobner bases yield the same ideal?
+(defun grobner-equal (g1 g2 &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Returns T if two lists of polynomials G1 and G2, assumed to be Grobner bases,
+generate  the same ideal, and NIL otherwise."
+  (and (grobner-subsetp g1 g2 pred ring)
+       (grobner-subsetp g2 g1 pred ring)))
+
+(defun grobner-subsetp (g1 g2 &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Returns T if a list of polynomials G1 generates
+an ideal contained in the ideal generated by a polynomial list G2,
+both G1 and G2 assumed to be Grobner bases. Returns NIL otherwise."
+  (every #'(lambda (p) (grobner-member p g2 pred ring)) g1))
+
+(defun grobner-member (p g &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Returns T if a polynomial P belongs to the ideal generated by the
+polynomial list G, which is assumed to be a Grobner basis. Returns NIL otherwise."
+  (endp (normal-form (copy-tree p) g pred nil ring)))
+
+(defun ideal-equal (f1 f2 pred top-reduction-only ring)
+  "Returns T if two ideals generated by polynomial lists F1 and F2 are identical.
+Returns NIL otherwise."
+  (grobner-equal (grobner f1 pred 0 top-reduction-only ring)
+		 (grobner f2 pred 0 top-reduction-only ring)
+		 pred ring))
+
+(defun ideal-subsetp (f1 f2 &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Returns T if the ideal spanned by the polynomial list F1 is contained
+in the ideal spanned by the polynomial list F2. Returns NIL otherwise."
+  (grobner-subsetp
+   (grobner f1 pred 0 nil ring)
+   (grobner f2 pred 0 nil ring)
+   pred ring))
+
+(defun ideal-member (p plist pred top-reduction-only ring)
+  "Returns T if the polynomial P belongs to the ideal spanned by the polynomial
+list PLIST, and NIL otherwise."
+  (endp (normal-form (copy-tree p) (grobner plist pred 0 top-reduction-only ring)
+		     pred nil ring)))
+
+;; Calculate F : p^inf
+(defun ideal-saturation-1 (F p pred start top-reduction-only ring
+			   &aux (pred (elimination-order-1 pred)))
+  "Returns the reduced Grobner basis of the saturation of the ideal
+generated by a polynomial list F in the ideal generated by a single
+polynomial P. The saturation ideal is defined as the set of
+polynomials H such for some natural number n (* (EXPT P N) H) is in the ideal
+F. Geometrically, over an algebraically closed field, this is the set
+of polynomials in the ideal generated by F which do not identically
+vanish on the variety of P."
+  (mapcar
+   #'poly-contract
+   (ring-intersection
+    (reduced-grobner
+     (saturation-extension-1 F p ring)
+     pred
+     start top-reduction-only ring)
+    1)))
+
+
+(defun add-variables (plist n)
+  "Add N new variables, adn the first N variables, to every polynomial in polynomial list PLIST.
+The resulting polynomial will not depend on these N variables."
+  (mapcar
+   #'(lambda (g)
+       (mapcar #'(lambda (q) (cons (append (make-list n :initial-element 0)
+					   (car q))
+				   (cdr q))) g))
+   plist))
+
+;; Calculate <u1*p1,u2*p2,...,uk*pk>
+(defun extend-polynomials (plist &aux (k (length plist)))
+  "Returns polynomial list {U1*P1', U2*P2', ... , UK*PK'}
+where Ui are new variables and PLIST={P1, P2, ... , PK} is a polynomial
+list. PI' is obtained from PI by adding new variables U1, U2, ..., UN
+UK as the first K variables. Thus, the resulting list is consists of polynomials whose
+terms are ordered by the lexicographic order on variables UI, with
+ties resolved by the monomial order which was used to order the terms
+of the polynomials in PLIST. We note that the monomial order does not
+explicitly participate in this calculation, and neither do the
+variable names."
+  (labels ((incf-power (g i)
+	     (dolist (x g g)
+	       (incf (nth i (car x))))))
+    (setf plist (add-variables plist k))
+    (dotimes (i k plist)
+      (setf (nth i plist) (incf-power (nth i plist) i)))))
+
+;; Calculate <F, u1*p1-1,u2*p2-1,...,uk*pk-1>
+(defun saturation-extension (F plist ring &aux (k (length plist))
+					  (d (+ k (length (caaar plist)))))
+  "Returns F' union {U1*P1-1,U2*P2-1,...,UK*PK-1} where Ui are new variables
+and F' is a polynomial list  obtained from F by adding variables U1, U2, ..., Uk
+as the first K variables to each polynomial in F. Thus, the resulting list is
+consists of polynomials whose terms are ordered by the lexicographic order on
+variables Ui, with ties resolved by the monomial order which was used to order the
+terms of the polynomials in F. We note that the monomial order does not explicitly
+participate in this calculation, and neither do the variable names."
+  (setf F (add-variables F k)
+	plist (mapcar #'(lambda (x)
+			  (nconc x (list (cons (make-list d :initial-element 0)
+					       (funcall (ring-- ring)
+							(ring-unit ring))))))
+		      (extend-polynomials plist)))
+  (append F plist))
+
+;; Calculate <F, u1*p1+u2*p2+...+uk*pk-1>
+(defun polysaturation-extension (F plist ring &aux (k (length plist))
+					      (d (+ k (length (caaar plist)))))
+  "Returns F' union {U1*P1+U2*P2+UK*PK-1} where Ui are new variables
+and F' is a polynomial list  obtained from F by adding variables U1, U2, ..., Uk
+as the first K variables to each polynomial in F. Thus, the resulting list is
+consists of polynomials whose terms are ordered by the lexicographic order on
+variables Ui, with ties resolved by the monomial order which was used to order the
+terms of the polynomials in F. We note that the monomial order does not explicitly
+participate in this calculation, and neither do the variable names."
+    (setf F (add-variables F k)
+	  plist (apply #'append (extend-polynomials plist))
+	  (cdr (last plist)) (list (cons (make-list d :initial-element 0)
+					 (funcall (ring-- ring)
+						  (ring-unit ring)))))
+    (append F (list plist)))
+
+(defun saturation-extension-1 (F p ring)
+  "Return the list F' union {U*P-1} where U is a new variable,
+where F' is obtained from the polynomial list F by adding U as the first variable.
+The variable U will be added as the first variable, so that it can be easily
+eliminated."
+  (saturation-extension F (list p) ring))
+
+;; Calculate F : p1^inf : p2^inf : ... : ps^inf
+(defun ideal-polysaturation-1 (F plist pred start top-reduction-only ring)
+  "Returns the reduced Grobner basis of the ideal obtained by a
+sequence of successive saturations in the polynomials
+of the polynomial list PLIST of the ideal generated by the
+polynomial list F."
+  (cond
+   ((endp plist) (reduced-grobner F pred start top-reduction-only ring))
+   (t (let ((G (ideal-saturation-1 F (car plist) pred start top-reduction-only ring)))
+	(ideal-polysaturation-1 G (rest plist) pred (length G) top-reduction-only ring)))))
+
+(defun ideal-saturation (F G pred start top-reduction-only ring
+			 &aux (k (length G))
+			      (pred (elimination-order k
+						       :primary-order #'lex>
+						       :secondary-order pred)))
+  "Returns the reduced Grobner basis of the saturation of the ideal
+generated by a polynomial list F in the ideal generated a polynomial
+list G The saturation ideal is defined as the set of polynomials H
+such for some natural number n and some P in the ideal generated by G
+the polynomial P**N * H is in the ideal spanned by F.  Geometrically,
+over an algebraically closed field, this is the set of polynomials in
+the ideal generated by F which do not identically vanish on the
+variety of G."
+  (mapcar
+   #'(lambda (q) (poly-contract q k))
+   (ring-intersection
+    (reduced-grobner  (polysaturation-extension  F G ring)
+		      pred start
+		      top-reduction-only ring)
+    k)))
+
+(defun ideal-polysaturation (F ideal-list pred start top-reduction-only ring)
+    "Returns the reduced Grobner basis of the ideal obtained by a
+successive applications of IDEAL-SATURATIONS to F and
+lists of polynomials in the list IDEAL-LIST."
+  (cond
+   ((endp ideal-list) F)
+   (t (let ((H (ideal-saturation F (car ideal-list) pred start top-reduction-only ring)))
+	(ideal-polysaturation H (rest ideal-list) pred (length H) top-reduction-only ring)))))
+
+(defun buchberger-criterion (G pred ring)
+  "Returns T if G is a Grobner basis, by using the Buchberger
+criterion: for every two polynomials h1 and h2 in G the S-polynomial
+S(h1,h2) reduces to 0 modulo G."
+  (every
+   #'endp
+   (makelist (normal-form (spoly (elt G i) (elt G j) pred ring) G pred nil ring)
+	     (i 0 (- (length G) 2))
+	     (j (1+ i) (1- (length G))))))
+
+
+(defun grobner-test (G F pred ring)
+  "Test whether G is a Grobner basis and F is contained in G. Return T
+upon success and NIL otherwise."
+  #+debug(debug-cgb "~&GROBNER CHECK: ")
+  (let ((*grobner-debug* nil)
+	(stat1 (buchberger-criterion G pred ring))
+	(stat2
+	  (every #'endp
+		 (makelist (normal-form (copy-tree (elt F i)) G pred nil ring)
+			   (i 0 (1- (length F)))))))
+    (unless stat1 (error "~&Buchberger criterion failed."))
+    (unless stat2
+      (error "~&Original polys not in ideal spanned by Grobner.")))
+  #+debug(debug-cgb "~&GROBNER CHECK END")
+  T)
+
+
+(defun minimization (P pred)
+  "Returns a sublist of the polynomial list P spanning the same
+monomial ideal as P but minimal, i.e. no leading monomial
+of a polynomial in the sublist divides the leading monomial
+of another polynomial."
+  (declare (ignore pred))
+  (do ((Q P)
+       (found t))
+      ((not found) Q)
+    ;;Find p in Q such that lm(p) is in LM(Q\{p})
+    (setf found nil
+	  Q (dolist (x Q Q)
+	      (let ((Q1 (remove x Q)))
+		(when (member-if #'(lambda (p) (monom-divides-p (lm x) (lm p))) Q1)
+		  (setf found t)
+		  (return Q1)))))))
+
+
+(defun add-minimized (f Gred pred)
+  "Adds a polynomial f to GRED, reduced Grobner basis, preserving the
+property described in the documentation for MINIMIZATION."
+  (if (member-if #'(lambda (p) (monom-divides-p (lm p) (lm f))) Gred)
+      Gred
+    (merge 'list (list f)
+	   (delete-if #'(lambda (p) (monom-divides-p (lm f) (lm p))) Gred)
+	   pred :key #'lm)))
+
+(defun colon-ideal (F G pred top-reduction-only ring)
+  "Returns the reduced Grobner basis of the colon ideal Id(F):Id(G), where
+F and G are two lists of polynomials. The colon ideal I:J is defined as the
+set of polynomials H such that there is a polynomial W in J for which
+W*H belongs to I."
+  (cond
+    ((endp G)
+     (if (every #'endp F) nil
+       (list (list
+	      (cons
+	       (make-list (length (caar (find-if-not #'endp F)))
+			  :initial-element 0)
+	       1)))))
+    ((endp (cdr G))
+     (colon-ideal-1 F (car G) pred top-reduction-only ring))
+    (t
+     (ideal-intersection (colon-ideal-1 F (car G) pred top-reduction-only ring)
+			 (colon-ideal F (rest G) pred top-reduction-only ring)
+			 pred
+			 top-reduction-only
+			 ring))))
+
+(defun colon-ideal-1 (F g pred top-reduction-only ring)
+  "Returns the reduced Grobner basis of the colon ideal Id(F):Id({G}), where
+F is a list of polynomials and G is a polynomial."
+  (mapcar #'(lambda (x) (poly-exact-divide x g pred ring))
+	  (ideal-intersection F (list g) pred top-reduction-only ring)))
+
+
+(defun pseudo-divide (f fl pred ring)
+  "Pseudo-divide a polynomial F by the list of polynomials FL. Return
+multiple values. The first value is a list of quotients A.
+The second value is the remainder R. The third value is an integer
+count of the number of reductions performed. Finally, the fourth
+argument is a scalar coefficient C, such that C*F can be divided by FL
+within the ring of coefficients, which is not necessarily a field.
+The resulting objects satisfy the equation:
+  C*F= sum A[i]*FL[i] + R
+"
+  (declare (optimize (speed 3) (safety 0)))
+  (do (r
+       (c (ring-unit ring))
+       (a (make-list (length fl)))
+       (division-count 0)
+       (p f))
+      ((endp p)
+       #+debug(debug-cgb "~&~3T~d reduction~:p" division-count)
+       #+debug(when (endp r) (debug-cgb " ---> 0"))
+       (values a (nreverse r) division-count c))
+    (declare (fixnum division-count) (integer c))
+    (do ((fl fl (rest fl))		;scan list of divisors
+	 (b a (rest b)))
+	((cond
+	   ((endp fl)			;no division occurred
+	    (setf r (cons (lt p) r) ;move lt(p) to remainder
+		  p (rest p))		;remove lt(p) from p
+	    t)
+	   ((monom-divides-p (lm (car fl)) (lm p)) ;division occurred
+	    (incf division-count)
+	    (let* ((gcd (funcall (ring-gcd ring) (lc (car fl)) (lc p)))
+		   (c1 (funcall (ring-/ ring) (lc (car fl)) gcd))
+		   (c2 (funcall (ring-/ ring) (lc p) gcd))
+		   (quot (cons (monom/ (lm p) (lm (car fl))) c2)))
+	      ;; Multiply the equation c*f=sum ai*fi+r+p by c1.
+	      (mapl #'(lambda (x)
+			(setf (car x) (scalar-times-poly c1 (car x) ring)))
+		    a)
+	      (setf p (scalar-times-poly c1 (rest p) ring) ;drop first term
+		    r (scalar-times-poly c1 r ring)
+		    c (funcall (ring-* ring) c c1)
+		    p (poly-op p quot (rest (car fl)) pred ring)
+		    (car b) (nconc (car b) (list quot))))
+	    t))))))
+
+;;----------------------------------------------------------------
+;; An implementation of the algorithm of Gebauer and Moeller,
+;; as described in the book of Becker-Weispfenning, p. 232
+;;----------------------------------------------------------------
+(defun gebauer-moeller (F pred start top-reduction-only ring
+			&aux B G F1)
+  "Compute Grobner basis by using the algorithm of Gebauer and Moeller.
+This algorithm is described as BUCHBERGERNEW2 in the book by
+Becker-Weispfenning entitled ``Grobner Bases''"
+  ;;cut startup costs if (length F)<=1
+  (cond
+   ((endp F) (return-from gebauer-moeller nil))
+   ((endp (cdr F))
+    (return-from gebauer-moeller (list (grobner-primitive-part (car F) ring)))))
+  #+debug (debug-cgb "~&GROBNER BASIS - GEBAUER MOELLER ALGORITHM")
+  #+debug (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
+  #+grobner-check  (when (plusp start)
+		     (grobner-test (subseq F 0 start) (subseq F 0 start)
+				   pred ring))
+  (setf B nil
+	G (subseq F 0 start)
+	F1 (subseq F start))
+  (do () ((endp F1))
+    (multiple-value-setq (G B)
+      (update G B (grobner-primitive-part (pop F1) ring) pred ring)))
+  (do () ((endp B))
+    (let* ((pair (pop B))
+	   (g1 (first pair))
+	   (g2 (second pair))
+	   (h (normal-form (spoly g1 g2 pred ring)
+			   G pred top-reduction-only ring)))
+      (unless (poly-zerop h)
+	(setf h (grobner-primitive-part h ring))
+	(multiple-value-setq (G B)
+	  (update G B h pred ring))
+	#+debug (debug-cgb "~&Polynomials: ~d; Pairs left: ~d~%"
+			   (length G) (length B))
+	)))
+  #+grobner-check(grobner-test G F pred ring)
+  #+debug(debug-cgb "~&GROBNER END")
+  G)
+
+(defun update (G B h pred ring &aux C D E B-new G-new pair)
+  "An implementation of the auxillary UPDATE algorithm used by the
+Gebauer-Moeller algorithm. G is a list of polynomials, B is a list of
+critical pairs and H is a new polynomial which possibly will be added
+to G. The naming conventions used are very close to the one used in
+the book of Becker-Weispfenning."
+  (setf C G D nil) 
+  (do (g1) ((endp C))
+    (setf g1 (pop C))
+    (when (or (monom-rel-prime (lm h) (lm g1))
+	      (and
+	       (not (some
+		     #'(lambda (g2) (monom-divides-p (monom-lcm (lm h) (lm g2))
+						     (monom-lcm (lm h) (lm g1))))
+		     C))
+	       (not (some
+		     #'(lambda (g2) (monom-divides-p (monom-lcm (lm h) (lm g2))
+						     (monom-lcm (lm h) (lm g1))))
+		     D))))
+      (push g1 D)))
+  (setf E nil)
+  (do (g1) ((endp D))
+    (setf g1 (pop D))
+    (unless (monom-rel-prime (lm h) (lm g1))
+      (push g1 E)))
+  (setf B-new nil)
+  (do (g1 g2) ((endp B))
+    (setf pair (pop B)
+	  g1 (first pair)
+	  g2 (second pair))
+    (when (or (not (monom-divides-p (lm h) (monom-lcm (lm g1) (lm g2))))
+	      (equal (monom-lcm (lm g1) (lm h))
+		     (monom-lcm (lm g1) (lm g2)))
+	      (equal (monom-lcm (lm h) (lm g2))
+		     (monom-lcm (lm g1) (lm g2))))
+      (setf B-new (funcall *gebauer-moeller-merge-pairs* B-new (list (list g1 g2)) pred ring))))
+  (dolist (g3 E)
+    (setf B-new (funcall *gebauer-moeller-merge-pairs* B-new (list (list h g3)) pred ring)))
+  (setf G-new nil)
+  (do (g1) ((endp G))
+    (setf g1 (pop G))
+    (unless (monom-divides-p (lm h) (lm g1))
+      (push g1 G-new)))
+  (push h G-new)
+  (values G-new B-new))
+      
+(defun gebauer-moeller-merge-pairs-use-mock-spoly (B C pred ring)
+  "The merging strategy used by the Gebauer-Moeller algorithm, based
+on MOCK-SPOLY; see the documentation of
+BUCHBERGER-MERGE-PAIRS-USE-MOCK-SPOLY."
+  (declare (ignore ring))
+  ;; Delete pairs consisting of two single monomials
+  (setf C (delete-if
+	   #'(lambda (p) (and (endp (cdr (first p)))
+			      (endp (cdr (second p)))))
+	   C))
+  (labels ((pair-key (p) (mock-spoly (first p) (second p) pred))
+	   (pair-order (x y) (funcall pred y x)))
+    (merge 'list B C #'pair-order :key #'pair-key)))
+
+(defun gebauer-moeller-merge-pairs-smallest-lcm (B C pred ring)
+  "The merging strategy based on the smallest-lcm (normal strategy); see 
+the documentation of BUCHBERGER-MERGE-PAIRS-SMALLEST-LCM."
+  (declare (ignore ring))
+  ;; Delete pairs consisting of two single monomials
+  (labels ((pair-key (p) (monom-lcm (lm (first p))
+				    (lm (second p))))
+	   (pair-order (x y) (funcall pred y x)))
+    (merge 'list B C #'pair-order :key #'pair-key)))
+
+
+(defun gebauer-moeller-merge-pairs-use-smallest-degree (B C pred ring)
+  "The merging strategy based on the smallest-lcm (normal strategy); see 
+the documentation of BUCHBERGER-MERGE-PAIRS-USE-SMALLEST-DEGREE."
+  (declare (ignore ring))
+  (declare (ignore pred))
+  (labels ((pair-key (p) (total-degree
+			  (monom-lcm (lm (first p))
+				     (lm (second p)))))
+	   (pair-order (x y) (funcall #'< x y)))
+    (merge 'list B C #'pair-order :key #'pair-key)))
+
+
+(defun gebauer-moeller-merge-pairs-use-smallest-length (B C pred ring)
+  (declare (ignore ring))
+  "The merging strategy based on the smallest-lcm (normal strategy); see 
+the documentation of BUCHBERGER-MERGE-PAIRS-USE-SMALLEST-LENGTH."
+  (declare (ignore pred))
+  (labels ((pair-key (p) (+
+			  (length (first p))
+			  (length (second p))))
+	   (pair-order (x y) (funcall #'< x y)))
+    (if B
+	(merge 'list B C #'pair-order :key #'pair-key)
+      (sort C #'pair-order :key #'pair-key))))
+
+
+(defun gebauer-moeller-merge-pairs-use-smallest-coefficient-length (B C pred ring)
+  "The merging strategy based on the smallest-lcm (normal strategy); see 
+the documentation of BUCHBERGER-MERGE-PAIRS-USE-SMALLEST-COEFFICIENT-LENGTH."
+  (declare (ignore pred))
+  (labels ((coefficient-length (poly)
+	     (apply #'+ (mapcar (ring-length ring) (mapcar #'cdr poly))))
+	   (pair-key (p) (+
+			  (coefficient-length (first p))
+			  (coefficient-length (second p))))
+	   (pair-order (x y) (funcall #'< x y)))
+    (merge 'list B C #'pair-order :key #'pair-key)))
+
+(defun gebauer-moeller-set-pair-heuristic
+    (method
+     &aux (strategy-fn
+	(ecase method
+	      (:minimal-mock-spoly #'gebauer-moeller-merge-pairs-use-mock-spoly)
+	      (:minimal-lcm #'gebauer-moeller-merge-pairs-smallest-lcm)
+	      (:minimal-total-degree #'gebauer-moeller-merge-pairs-use-smallest-degree)
+	      (:minimal-length #'gebauer-moeller-merge-pairs-use-smallest-length)
+	      (:minimal-coefficient-length #'gebauer-moeller-merge-pairs-use-smallest-coefficient-length))))
+  (setf *gebauer-moeller-merge-pairs* strategy-fn))
+
+;;------------------------------------------------------------------------------------------------
+;;
+;; An implementation of the sugar strategy
+;;
+;;------------------------------------------------------------------------------------------------
+
+;; Calculate sugar of the S-polynomial of f and g
+(defun spoly-sugar (f-with-sugar g-with-sugar ring)
+  "Calculate the ``sugar'' of the S-polynomial of two polynomials with
+sugar. A polynomial with sugar is simply a pair (P . SUGAR) where
+SUGAR is an integer constant defined according to the following
+algorighm: the sugar of sum or difference of two polynomials with
+sugar is the MAX of the sugars of those two polynomials. The sugar of
+a product of a term and a polynomial is the sum of the degree of the
+term and the sugar of the polynomial.  The idea is to accumulate sugar
+as we perform the arithmetic operations, and that polynomials with
+small (little) sugar should be given priority in the calculations.
+Thus, the ``sugar strategy'' of the critical pair selection is to
+select a pair with the smallest value of sugar of the resulting
+S-polynomial."
+  (let* ((f (poly-with-sugar-poly f-with-sugar))
+	 (g (poly-with-sugar-poly g-with-sugar))
+	 (lcm (monom-lcm (lm f) (lm g)))
+	 (m1 (monom/ lcm (lm f)))
+	 (m2 (monom/ lcm (lm g))))
+    (let* ((c (funcall (ring-lcm ring) (lc f) (lc g)))
+	   (cf (funcall (ring-/ ring) c (lc f)))
+	   (cg (funcall (ring-/ ring) c (lc g))))
+      (max
+       (+ (term-sugar (cons m1 cf) ring) (poly-with-sugar-sugar f-with-sugar))
+       (+ (term-sugar (cons m2 cg) ring) (poly-with-sugar-sugar g-with-sugar))))))
+
+;; Calculate the S-polynomial of f and g with sugar
+(defun spoly-with-sugar (f-with-sugar g-with-sugar pred ring)
+  "The S-polynomials of two polynomials with SUGAR strategy."
+  (let* ((f (poly-with-sugar-poly f-with-sugar))
+	 (g (poly-with-sugar-poly g-with-sugar))
+	 (lcm (monom-lcm (lm f) (lm g)))
+	 (m1 (monom/ lcm (lm f)))
+	 (m2 (monom/ lcm (lm g))))
+    (let* ((c (funcall (ring-lcm ring) (lc f) (lc g)))
+	   (cf (funcall (ring-/ ring) c (lc f)))
+	   (cg (funcall (ring-/ ring) c (lc g))))
+      (poly-with-sugar-
+       (term-times-poly-with-sugar (cons m1 cf) (poly-with-sugar-tail f-with-sugar) ring)
+       (term-times-poly-with-sugar (cons m2 cg) (poly-with-sugar-tail g-with-sugar) ring)
+       pred
+       ring))))
+
+
+(defun normal-form-with-sugar (f fl pred top-reduction-only ring)
+  "Normal form of the polynomial with sugar F with respect to
+a list of polynomials with sugar FL. Assumes that FL is not empty.
+Parameters PRED, TOP-REDUCTION-ONLY and RING have the same meaning as in NORMAL-FORM.
+The parameter SUGAR-LIMIT should be set to a positive integer. If the sugar limit of
+the partial remainder exceeds SUGAR-LIMIT then the calculation is stopped and the partial
+remainder is returned, although it is not fully reduced with respect to FL."
+  (declare (optimize (speed 3) (safety 0)))
+  ;; Loop invariant: c*f=sum ai*fi+r+p
+  (do ((r (cons nil 0))
+       (c (ring-unit ring))
+       (division-count 0)
+       (p f))
+      ((or (poly-with-sugar-zerop p)
+	   (and top-reduction-only (not (poly-with-sugar-zerop r))))
+       #+debug
+       (progn
+	 (debug-cgb "~&~3T~d reduction~:p" division-count)
+	 (cond
+	  ((poly-with-sugar-zerop r)
+	   (debug-cgb " ---> 0"))))
+       (values (poly-with-sugar-append (poly-with-sugar-nreverse r) p)
+	       division-count c))
+    (declare (fixnum division-count) (integer c))
+    (let ((g (find (poly-with-sugar-lm p) fl
+		   :test #'monom-divisible-by-p
+		   :key #'poly-with-sugar-lm)))
+      (cond 
+       (g				;division possible
+	(incf division-count)
+	(let* ((gcd (funcall (ring-gcd ring) (poly-with-sugar-lc g) (poly-with-sugar-lc p)))
+	       (c1 (funcall (ring-/ ring) (poly-with-sugar-lc g) gcd))
+	       (c2 (funcall (ring-/ ring) (poly-with-sugar-lc p) gcd))
+	       (m (monom/ (poly-with-sugar-lm p) (poly-with-sugar-lm g))))
+	  ;; Multiply the equation c*f=sum ai*fi+r+p by c1.
+	  (setf r (scalar-times-poly-with-sugar c1 r ring)
+		c (funcall (ring-* ring) c c1)
+		p (scalar-times-poly-with-sugar c1 p ring)
+		p (poly-with-sugar-op p (cons m c2) g pred ring))))
+       (t				;no division possible
+	;;move lt(p) to remainder
+	(setf r (cons (cons (poly-with-sugar-lt p) (poly-with-sugar-poly r))
+		      (poly-with-sugar-sugar r))
+	      p (poly-with-sugar-tail p)))))))
+
+;; Parameter START is used when Grobner basis is calculated incrementally
+;; and it signals that the elements of F from 0 to START-1 form a Grobner
+;; basis already, so their pairs are not formed.
+(defun buchberger-with-sugar (F-no-sugar pred start top-reduction-only ring
+			      &aux (s (1- (length F-no-sugar))) B M F)
+  "Returns a Grobner basis of an ideal generated by a list of ordinary
+polynomials F-NO-SUGAR. Adds initial sugar to the polynomials and
+performs the Buchberger algorithm with ``sugar strategy''. It returns
+an ordinary list of polynomials with no sugar. One of the most
+effective algorithms for Grobner basis calculation."
+  (declare (fixnum s))
+  (unless (plusp s) (return-from buchberger-with-sugar F-no-sugar)) ;cut startup costs
+  #+debug (debug-cgb "~&GROBNER BASIS - BUCHBERGER WITH SUGER STRATEGY ALGORITHM")
+  #+debug (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
+  #+grobner-check  (when (plusp start)
+		     (grobner-test (subseq F-no-sugar 0 start)
+				   (subseq F-no-sugar 0 start) pred ring))
+  (setf F (mapcar #'(lambda (x) (poly-add-sugar x ring)) F-no-sugar)
+	B (nconc (makelist (list i j) (i 0 (1- start)) (j start s))
+		 (makelist (list i j) (i start (1- s)) (j (1+ i) s)))
+	M (make-hash-table :test #'equal))
+  ;;Initialize treated pairs
+  (dotimes (i (1- start))
+    (do ((j (1+ i) (1+ j))) ((>= j start))
+      (setf (gethash (list i j) M) t)))
+  (setf B (buchberger-with-sugar-sort-pairs B F M pred ring))
+  (do ((G F))
+      ((endp B)
+       (setf G (mapcar #'poly-with-sugar-poly G))
+       ;;#+grobner-check(grobner-test G F-no-sugar pred ring)
+       #+debug(debug-cgb "~&GROBNER END")
+       G)
+    (let ((pair (pop B)))
+      (cond
+       ((Criterion-1-with-sugar pair G))
+       ((Criterion-2-with-sugar pair G M))
+       (t
+	(let ((SP (normal-form-with-sugar
+		   (cons (spoly (poly-with-sugar-poly (elt G (first pair)))
+				(poly-with-sugar-poly (elt G (second pair))) pred ring)
+			 (third pair))
+		   G pred top-reduction-only ring)))
+	  (cond
+	   ((poly-with-sugar-zerop SP))
+	   (t
+	    (setf s (1+ s)
+		  (poly-with-sugar-poly SP) (grobner-primitive-part
+					     (poly-with-sugar-poly SP) ring)
+		  (cdr (last G)) (list SP)
+		  B (buchberger-with-sugar-merge-pairs B (makelist (list i s)
+								   (i 0 (1- s)))
+						       G M pred ring))
+	    #+debug (debug-cgb "~&[~d] Polynomials: ~d; Pairs left: ~d; Treated pairs: ~d"
+			       (third pair)
+			       (length G) (length B)
+			       (hash-table-count M)))))))
+      (setf (cddr pair) nil
+	    (gethash pair M) t))))
+
+
+(defun buchberger-with-sugar-merge-pairs (B C G M pred ring)
+  "Merges lists of critical pairs. It orders pairs according to
+increasing sugar, with ties broken by smaller MOCK-SPOLY value of the
+two polynomials. In this function B must already be sorted."
+  ;;Remove pairs consisting of two monomials
+  ;;These pairs produce zero S-polynomial
+  (setf C (delete-if
+	   #'(lambda (p)
+	       (when (and (endp (cdr (poly-with-sugar-poly (elt G (first p)))))
+			  (endp (cdr (poly-with-sugar-poly (elt G (second p))))))
+		 ;;Record the pair as treated
+		 (setf (gethash p M) t)
+		 t))
+	   C))
+  (labels ((pair-sugar (p)
+	     (spoly-sugar (elt G (first p)) (elt G (second p)) ring))
+	   (pair-mock-spoly (p)
+	     (mock-spoly (poly-with-sugar-poly (elt G (first p)))
+			 (poly-with-sugar-poly (elt G (second p))) pred))
+	   (pair-order (p q)
+	     (let ((sugar-p (third p))
+		   (sugar-q (third q)))
+	       (cond
+		((< sugar-p sugar-q) t)
+		((> sugar-p sugar-q) nil)
+		(t
+		 (funcall pred (fourth q) (fourth p)))))))
+    ;;Add sugar and mock S-polynomial as the third and fourth element
+    ;;of new pair in C
+    (dolist (p C)
+      (setf (cdr (last p))
+	    (list (pair-sugar p) (pair-mock-spoly p))))
+    (merge 'list B (sort C #'pair-order) #'pair-order)))
+
+(defun buchberger-with-sugar-sort-pairs (C G M pred ring) 
+  "Sorts critical pairs C according to sugar strategy."
+  (buchberger-with-sugar-merge-pairs nil C G M pred ring))
+
+(defun Criterion-1-with-sugar (pair G &aux (i (first pair)) (j (second pair)))
+  "An implementation of Buchberger's first criterion for polynomials 
+with sugar. See the documentation of BUCHBERGER-CRITERION-1."
+  (monom-rel-prime (poly-with-sugar-lm (elt G i))
+		   (poly-with-sugar-lm (elt G j))))
+
+(defun Criterion-2-with-sugar (pair G M &aux (i (first pair)) (j (second pair)))
+  "An implementation of Buchberger's first criterion for polynomials 
+with sugar. See the documentation of BUCHBERGER-CRITERION-2."
+  (labels ((make-pair (u v) (if (< u v) (list u v) (list v u))))
+    (dotimes (k (length G) nil)
+      (when (and (/= k i)
+		 (/= k j)
+		 (monom-divides-p
+		  (poly-with-sugar-lm (elt G k))
+		  (monom-lcm (poly-with-sugar-lm (elt G i))
+			     (poly-with-sugar-lm (elt G j))))
+		 (gethash (make-pair i k) M)
+		 (gethash (make-pair k j) M))
+	#+debug(when *grobner-debug* (format t ":B2"))
+	(return-from Criterion-2-with-sugar t)))))
+
+
+;;----------------------------------------------------------------
+;; An implementation of the algorithm of Gebauer and Moeller,
+;; as described in the book of Becker-Weispfenning, p. 232
+;; with sugar strategy
+;;----------------------------------------------------------------
+(defun gebauer-moeller-with-sugar (F pred start top-reduction-only ring
+			&aux B G F1)
+  "Compute Grobner basis by using the algorithm of Gebauer and Moeller.
+This algorithm is described as BUCHBERGERNEW2 in the book by
+Becker-Weispfenning entitled ``Grobner Bases''"
+  ;;cut startup costs if (length F)<=1
+  (cond
+   ((endp F) (return-from gebauer-moeller-with-sugar nil))
+   ((endp (cdr F))
+    (return-from gebauer-moeller-with-sugar (list (grobner-primitive-part (car F) ring)))))
+  #+debug (debug-cgb "~&GROBNER BASIS - GEBAUER MOELLER ALGORITHM WITH SUGAR STRATEGY")
+  #+debug (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
+  #+grobner-check  (when (plusp start)
+		     (grobner-test (subseq F 0 start) (subseq F 0 start)
+				   pred ring))
+  (setf B nil
+	G (subseq F 0 start)
+	F1 (subseq F start))
+  ;;Initialize sugar
+  (setf G (mapcar #'(lambda (x) (poly-add-sugar x ring)) G)
+	F1 (mapcar #'(lambda (x) (poly-add-sugar x ring)) F1))
+  (do () ((endp F1))
+    (multiple-value-setq (G B)
+      (update-with-sugar G B (grobner-primitive-part-with-sugar (pop F1) ring) pred ring)))
+  (do ()
+      ((endp B))
+    (let* ((pair (pop B))
+	   (g1 (first pair))
+	   (g2 (second pair))
+	   (h (normal-form-with-sugar (spoly-with-sugar g1 g2 pred ring)
+				      G pred top-reduction-only ring)))
+      (cond
+       ((poly-with-sugar-zerop h))
+       (t
+	(setf h (grobner-primitive-part-with-sugar h ring))
+	(multiple-value-setq (G B)
+	  (update-with-sugar G B h pred ring))
+	#+debug (debug-cgb "~&[[~d]] Polynomials: ~d; Pairs left: ~d~%"
+			   (poly-with-sugar-sugar h)
+			   (length G) (length B))
+	))))
+  (setf G (mapcar #'poly-with-sugar-poly G))
+  ;;#+grobner-check(grobner-test G F pred ring)
+  #+debug(debug-cgb "~&GROBNER END")
+  G)
+
+(defun update-with-sugar (G B h pred ring &aux C D E B-new G-new pair)
+  "An implementation of the auxillary UPDATE algorithm used by the
+Gebauer-Moeller algorithm. G is a list of polynomials, B is a list of
+critical pairs and H is a new polynomial which possibly will be added
+to G. The naming conventions used are very close to the one used in
+the book of Becker-Weispfenning. Operates on polynomials with sugar."
+  (setf C G D nil) 
+  (do (g1) ((endp C))
+    (setf g1 (pop C))
+    (when (or (monom-rel-prime (poly-with-sugar-lm h) (poly-with-sugar-lm g1))
+	      (and
+	       (not (some
+		     #'(lambda (g2) (monom-divides-p (monom-lcm (poly-with-sugar-lm h)
+								(poly-with-sugar-lm g2))
+						     (monom-lcm (poly-with-sugar-lm h)
+								(poly-with-sugar-lm g1))))
+		     C))
+	       (not (some
+		     #'(lambda (g2) (monom-divides-p (monom-lcm (poly-with-sugar-lm h)
+								(poly-with-sugar-lm g2))
+						     (monom-lcm (poly-with-sugar-lm h)
+								(poly-with-sugar-lm g1))))
+		     D))))
+      (push g1 D)))
+  (setf E nil)
+  (do (g1) ((endp D))
+    (setf g1 (pop D))
+    (unless (monom-rel-prime (poly-with-sugar-lm h) (poly-with-sugar-lm g1))
+      (push g1 E)))
+  (setf B-new nil)
+  (do (g1 g2) ((endp B))
+    (setf pair (pop B)
+	  g1 (first pair)
+	  g2 (second pair))
+    (when (or (not (monom-divides-p (poly-with-sugar-lm h) (monom-lcm (poly-with-sugar-lm g1)
+								      (poly-with-sugar-lm g2))))
+	      (equal (monom-lcm (poly-with-sugar-lm g1) (poly-with-sugar-lm h))
+		     (monom-lcm (poly-with-sugar-lm g1) (poly-with-sugar-lm g2)))
+	      (equal (monom-lcm (poly-with-sugar-lm h) (poly-with-sugar-lm g2))
+		     (monom-lcm (poly-with-sugar-lm g1) (poly-with-sugar-lm g2))))
+      (setf B-new (gebauer-moeller-with-sugar-merge-pairs B-new (list (list g1 g2)) pred ring))))
+  (dolist (g3 E)
+    (setf B-new (gebauer-moeller-with-sugar-merge-pairs B-new (list (list h g3)) pred ring)))
+  (setf G-new nil)
+  (do (g1) ((endp G))
+    (setf g1 (pop G))
+    (unless (monom-divides-p (poly-with-sugar-lm h) (poly-with-sugar-lm g1))
+      (push g1 G-new)))
+  (push h G-new)
+  (values G-new B-new))
+
+(defun gebauer-moeller-with-sugar-merge-pairs (B C pred ring)
+  "Merges lists of critical pairs. It orders pairs according to
+increasing sugar, with ties broken by smaller lcm of head monomials In
+this function B must already be sorted. Operates on polynomials with sugar."
+  (setf C (delete-if
+	   #'(lambda (p) (and (endp (cdr (first p)))
+			      (endp (cdr (second p)))))
+	   C))
+  (labels ((pair-sugar (p)
+	     (spoly-sugar (first p) (second p) ring))
+	   (pair-mock-spoly (p)
+	     (mock-spoly (poly-with-sugar-poly (first p))
+			 (poly-with-sugar-poly (second p)) pred))
+	   (pair-order (p q)
+	     (let ((sugar-p (pair-sugar p))
+		   (sugar-q (pair-sugar q)))
+	       (cond
+		((< sugar-p sugar-q) t)
+		((> sugar-p sugar-q) nil)
+		(t
+		 (funcall pred (pair-mock-spoly q) (pair-mock-spoly p)))))))
+    (merge 'list B (sort C #'pair-order) #'pair-order)))
+
+(defun grobner-primitive-part-with-sugar (h ring)
+  (cons (grobner-primitive-part (car h) ring) (cdr h)))
+
+;;----------------------------------------------------------------
+;;
+;; An implementation of the algorithms using product caching
+;;
+;;----------------------------------------------------------------
+(defun cached-normal-form (f fl pred  top-reduction-only ring cache)
+  "This version of NORMAL-FORM uses a cache which stores products of monomials
+and polynomials found in FL. The cache is a hash table storing pairs (G . G-HASH-TABLE)
+where G is a polynomial in FL serving as a key. The hash table G-HASH-TABLE is a list
+of pairs (MONOMIAL . PRODUCT-POLY) where PRODUCT-POLY is (POLY* MONOMIAL G)."
+
+  (declare (optimize (speed 3) (safety 0)))
+  ;; Loop invariant: c*f=sum ai*fi+r+p
+  (do (r (c (ring-unit ring))
+       (division-count 0)
+       (p f))
+      ((or (endp p)
+	   (endp fl)
+	   (and top-reduction-only r))
+       #+debug(progn
+		(debug-cgb "~&~3T~d reduction~:p" division-count)
+		(when (endp r)
+		  (debug-cgb " ---> 0")))
+       (values (append (nreverse r) p)
+	       division-count c))
+    (declare (fixnum division-count) (integer c))
+    (let ((i (position (lm p) fl :test #'monom-divisible-by-p :key #'lm)))
+      (cond 
+       (i				;division possible
+	(incf division-count)
+	(let* ((g (nth i fl))
+	       (hash-tab (nth i cache))
+	       (gcd (funcall (ring-gcd ring) (lc g) (lc p)))
+	       (c1 (funcall (ring-/ ring) (lc g) gcd))
+	       (c2 (funcall (ring-/ ring) (lc p) gcd))
+	       (m (monom/ (lm p) (lm g))))
+	  ;; Multiply the equation c*f=sum ai*fi+r+p by c1.
+	  (setf r (scalar-times-poly c1 r ring)
+		c (funcall (ring-* ring) c c1)
+		p (cached-grobner-op c2 c1 m p g pred ring hash-tab))))
+       (t				;no division possible
+	(setf r (cons (lt p) r)		;move lt(p) to remainder
+	      p (rest p)))))))
+
+(defun cached-grobner-op (c1 c2 m A B pred ring cache)
+  "Returns the same result as (GROBNER-OP C1 C2 M A B PRED RING) but
+it used variable CACHE which is described in CACHED-NORMAL-FORM for
+efficient calculation of products of monomials with polynomials."
+  (poly- (scalar-times-poly c2 A)
+	 (scalar-times-poly c1 (cached-monom-times-poly m B cache) ring)
+	 pred ring))
+
+(defun cached-buchberger (F pred start top-reduction-only ring 
+			    &aux (s (1- (length F))) B M CACHE)
+  "It returns the same result as BUCHBERGER but it uses caching
+of products of monomials with polynomials."
+  (declare (fixnum s))
+  (unless (plusp s) (return-from cached-buchberger F)) ;cut startup costs
+  #+debug (debug-cgb "~&GROBNER BASIS - CACHED BUCHBERGER ALGORITHM")
+  #+debug (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
+  #+grobner-check  (when (plusp start)
+		     (grobner-test (subseq F 0 start) (subseq F 0 start) pred ring))
+  (setf B (nconc (makelist (list i j) (i 0 (1- start)) (j start s))
+		 (makelist (list i j) (i start (1- s)) (j (1+ i) s)))
+	M (make-hash-table :test #'equal)
+	B (buchberger-sort-pairs B F pred ring))
+  ;;Initialize cache 
+  (dotimes (k (1+ s)) (push (make-hash-table :test #'equal) CACHE))
+  ;;Initialize treated pairs
+  (dotimes (i (1- start))
+    (do ((j (1+ i) (1+ j))) ((>= j start))
+      (setf (gethash (list i j) M) t)))
+  (do ((G F))
+      ((endp B)
+       #+grobner-check(grobner-test G F pred ring)
+       #+debug(debug-cgb "~&GROBNER END")
+       G)
+    (let ((pair (pop B)))
+      (unless (or (Criterion-1 pair G)
+		  (Criterion-2 pair G M))
+	(let ((SP (cached-normal-form (cached-spoly (elt G (first pair))
+						    (elt G (second pair))
+						    pred
+						    ring
+						    (elt CACHE (first pair))
+						    (elt CACHE (second pair)))
+				      G pred top-reduction-only ring CACHE)))
+	  (unless (poly-zerop SP)	;S-polynomial ---> 0;
+	    (setf s (1+ s)
+		  SP (grobner-primitive-part SP ring)
+		  (cdr (last G)) (list SP)
+		  (cdr (last Cache)) (list (make-hash-table :test #'equal))
+		  B (funcall *buchberger-merge-pairs* B (makelist (list i s)
+								  (i 0 (1- s)))
+			     G pred ring))
+	    #+debug (debug-cgb "~&Polynomials: ~d; Pairs left: ~d; Treated pairs: ~d"
+			       (length G) (length B)
+			       (hash-table-count M)))))
+      (setf (gethash pair M) t))))
+
+(defun cached-spoly (f g pred ring cache-f cache-g)
+  "Uses CACHE to fetch products of monomials and polynomials."
+  (declare (optimize (speed 3) (safety 0)))
+  (let* ((lcm (monom-lcm (lm f) (lm g)))
+	 (m1 (monom/ lcm (lm f)))
+	 (m2 (monom/ lcm (lm g))))
+    (let* ((c (funcall (ring-lcm ring) (lc f) (lc g)))
+	   (cf (funcall (ring-/ ring) c (lc f)))
+	   (cg (funcall (ring-/ ring) c (lc g))))
+      (poly-
+       (scalar-times-poly cf (cached-monom-times-poly m1 f cache-f) ring)
+       (scalar-times-poly cg (cached-monom-times-poly m2 g cache-g) ring)
+       pred
+       ring))))
+
+
+(defun cached-monom-times-poly (m f cache)
+  (let ((prod (gethash m cache)))
+    (cond
+     (prod #+debug(debug-cgb "c") prod)
+     (t
+      #+debug(debug-cgb ".")
+      (setf (gethash m cache) (monom-times-poly m f))))))
+    
+;;------------------------------------------------------------------------------------------------
+;;
+;; An implementation of the sugar strategy with product caching
+;;
+;;------------------------------------------------------------------------------------------------
+(defun cached-normal-form-with-sugar (f fl pred top-reduction-only ring cache)
+  "Normal form of the polynomial with sugar F with respect to
+a list of polynomials with sugar FL. Assumes that FL is not empty.
+Parameters PRED, TOP-REDUCTION-ONLY and RING have the same meaning as in NORMAL-FORM.
+The parameter SUGAR-LIMIT should be set to a positive integer. If the sugar limit of
+the partial remainder exceeds SUGAR-LIMIT then the calculation is stopped and the partial
+remainder is returned, although it is not fully reduced with respect to FL."
+  (declare (optimize (speed 3) (safety 0)))
+  ;; Loop invariant: c*f=sum ai*fi+r+p
+  (do ((r (cons nil 0))
+       (c (ring-unit ring))
+       (division-count 0)
+       (p f))
+      ((or (poly-with-sugar-zerop p)
+	   (and top-reduction-only (not (poly-with-sugar-zerop r))))
+       #+debug
+       (progn
+	 (debug-cgb "~&~3T~d reduction~:p" division-count)
+	 (cond
+	  ((poly-with-sugar-zerop r)
+	   (debug-cgb " ---> 0"))))
+       (values (poly-with-sugar-append (poly-with-sugar-nreverse r) p)
+	       division-count c))
+    (declare (fixnum division-count) (integer c))
+    (let ((i (position (poly-with-sugar-lm p) fl
+		   :test #'monom-divisible-by-p
+		   :key #'poly-with-sugar-lm)))
+      (cond 
+       (i				;division possible
+	(incf division-count)
+	(let* ((g (nth i fl))
+	       (hash-tab (nth i cache))
+	       (gcd (funcall (ring-gcd ring) (poly-with-sugar-lc g) (poly-with-sugar-lc p)))
+	       (c1 (funcall (ring-/ ring) (poly-with-sugar-lc g) gcd))
+	       (c2 (funcall (ring-/ ring) (poly-with-sugar-lc p) gcd))
+	       (m (monom/ (poly-with-sugar-lm p) (poly-with-sugar-lm g))))
+	  ;; Multiply the equation c*f=sum ai*fi+r+p by c1.
+	  (setf r (scalar-times-poly-with-sugar c1 r ring)
+		c (funcall (ring-* ring) c c1)
+		p (scalar-times-poly-with-sugar c1 p ring)
+		p (cached-poly-with-sugar-op p c2 m g pred ring hash-tab))))
+       (t				;no division possible
+	;;move lt(p) to remainder
+	(setf r (cons (cons (poly-with-sugar-lt p) (poly-with-sugar-poly r))
+		      (poly-with-sugar-sugar r))
+	      p (poly-with-sugar-tail p)))))))
+
+;; Parameter START is used when Grobner basis is calculated incrementally
+;; and it signals that the elements of F from 0 to START-1 form a Grobner
+;; basis already, so their pairs are not formed.
+(defun cached-buchberger-with-sugar (F-no-sugar pred start top-reduction-only ring
+						&aux (s (1- (length F-no-sugar))) B M F Cache)
+  "Returns a Grobner basis of an ideal generated by a list of ordinary
+polynomials F-NO-SUGAR. Adds initial sugar to the polynomials and
+performs the Buchberger algorithm with ``sugar strategy''. It returns
+an ordinary list of polynomials with no sugar. One of the most
+effective algorithms for Grobner basis calculation."
+  (declare (fixnum s))
+  (unless (plusp s) (return-from cached-buchberger-with-sugar F-no-sugar)) ;cut startup costs
+  #+debug (debug-cgb "~&GROBNER BASIS - BUCHBERGER WITH SUGER STRATEGY ALGORITHM")
+  #+debug (when (plusp start) (debug-cgb "~&INCREMENTAL:~d done" start))
+  #+grobner-check  (when (plusp start)
+		     (grobner-test (subseq F-no-sugar 0 start)
+				   (subseq F-no-sugar 0 start) pred ring))
+  (setf F (mapcar #'(lambda (x) (poly-add-sugar x ring)) F-no-sugar)
+	B (nconc (makelist (list i j) (i 0 (1- start)) (j start s))
+		 (makelist (list i j) (i start (1- s)) (j (1+ i) s)))
+	M (make-hash-table :test #'equal))
+  ;;Initialize cache 
+  (dotimes (k (1+ s)) (push (make-hash-table :test #'equal) Cache))
+  ;;Initialize treated pairs
+  (dotimes (i (1- start))
+    (do ((j (1+ i) (1+ j))) ((>= j start))
+      (setf (gethash (list i j) M) t)))
+  (setf B (buchberger-with-sugar-sort-pairs B F M pred ring))
+  (do ((G F))
+      ((endp B)
+       (setf G (mapcar #'poly-with-sugar-poly G))
+       ;;#+grobner-check(grobner-test G F-no-sugar pred ring)
+       #+debug(debug-cgb "~&GROBNER END")
+       G)
+    (let ((pair (pop B)))
+      (cond
+       ((Criterion-1-with-sugar pair G))
+       ((Criterion-2-with-sugar pair G M))
+       (t
+	(let ((SP (cached-normal-form-with-sugar
+		   (cons (cached-spoly (poly-with-sugar-poly (elt G (first pair)))
+				       (poly-with-sugar-poly (elt G (second pair)))
+				       pred ring
+				       (elt Cache (first pair))
+				       (elt Cache (second pair)))
+			 (third pair))
+		   G pred top-reduction-only ring Cache)))
+	  (cond
+	   ((poly-with-sugar-zerop SP))
+	   (t
+	    (setf s (1+ s)
+		  (poly-with-sugar-poly SP) (grobner-primitive-part
+					     (poly-with-sugar-poly SP) ring)
+		  (cdr (last G)) (list SP)
+		  (cdr (last Cache)) (list (make-hash-table :test #'equal))
+		  B (buchberger-with-sugar-merge-pairs B (makelist (list i s)
+								   (i 0 (1- s)))
+						       G M pred ring))
+	    #+debug (debug-cgb "~&[~d] Polynomials: ~d; Pairs left: ~d; Treated pairs: ~d"
+			       (third pair)
+			       (length G) (length B)
+			       (hash-table-count M)))))))
+      (setf (cddr pair) nil
+	    (gethash pair M) t))))
+
+;; Implement f-term*g
+(defun cached-poly-with-sugar-op (f c m g pred ring Cache)
+  (poly-with-sugar- f (scalar-times-poly-with-sugar c (cached-monom-times-poly-with-sugar m g Cache) ring) pred ring))
+
+(defun cached-monom-times-poly-with-sugar (m f Cache)
+  (cons
+   (cached-monom-times-poly m (poly-with-sugar-poly f) Cache)
+   (+ (poly-with-sugar-sugar f) (monom-sugar m))))
Index: /trunk/src/infix.lisp
===================================================================
--- /trunk/src/infix.lisp	(revision 14)
+++ /trunk/src/infix.lisp	(revision 14)
@@ -0,0 +1,1133 @@
+;;; -*- Mode: Lisp -*-
+;;; $Id: infix.lisp,v 1.4 2009/01/22 04:02:59 marek Exp $	
+;;; ****************************************************************
+;;; CHANGE LOG:
+;;; * (1997/12/6) Fixed code for valid-numberp, so that "" is no longer
+;;;   recognized as valid number
+;;; * (1997/11/29) Modified by M. Rychlik(rychlik@math.arizona.edu):
+;;;   The role of operators  ^^ (exponentiation) and ^ (logxior)
+;;;   of the original version was reversed
+;;; ****************************************************************
+;;;
+
+;;; Wed Jan 18 13:13:59 1995 by Mark Kantrowitz <mkant@FLATHEAD.OZ.CS.CMU.EDU>
+;;; infix.cl -- 40545 bytes
+
+;;; **************************************************************************
+;;; Infix ********************************************************************
+;;; **************************************************************************
+;;;
+;;; This is an implementation of an infix reader macro. It should run in any
+;;; valid Common Lisp and has been tested in Allegro CL 4.1, Lucid CL 4.0.1,
+;;; MCL 2.0 and CMU CL. It allows the user to type arithmetic expressions in
+;;; the traditional way (e.g., 1+2) when writing Lisp programs instead of
+;;; using the normal Lisp syntax (e.g., (+ 1 2)).  It is not intended to be a
+;;; full replacement for the normal Lisp syntax. If you want a more complete
+;;; alternate syntax for Lisp, get a copy Apple's MLisp or Pratt's CGOL.
+;;;
+;;; Although similar in concept to the Symbolics infix reader (#<DIAMOND>), 
+;;; no real effort has been made to ensure compatibility beyond coverage 
+;;; of at least the same set of basic arithmetic operators. There are several 
+;;; differences in the syntax beyond just the choice of #I as the macro 
+;;; character. (Our syntax is a little bit more C-like than the Symbolics 
+;;; macro in addition to some more subtle differences.) 
+;;;
+;;; We initially chose $ as a macro character because of its association
+;;; with mathematics in LaTeX, but unfortunately that character is already
+;;; used in MCL. We switched to #I() because it was one of the few options
+;;; remaining.
+;;;
+;;; Written by Mark Kantrowitz, School of Computer Science,
+;;; Carnegie Mellon University, March 1993.
+;;;
+;;; Copyright (c) 1993 by Mark Kantrowitz. All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted, so long as the following
+;;; conditions are met:
+;;;      o no fees or compensation are charged for use, copies, 
+;;;        distribution or access to this software
+;;;      o this copyright notice is included intact.
+;;; This software is made available AS IS, and no warranty is made about
+;;; the software or its performance.
+;;;
+;;; In no event will the author(s) or their institutions be liable to you for
+;;; damages, including lost profits, lost monies, or other special, incidental
+;;; or consequential damages, arising out of or in connection with the use or
+;;; inability to use (including but not limited to loss of data or data being
+;;; rendered inaccurate or losses sustained by third parties or a failure of
+;;; the program to operate as documented) the program, or for any claim by
+;;; any other party, whether in an action of contract, negligence, or 
+;;; other tortious action.
+;;;
+;;; Please send bug reports, comments and suggestions to mkant@cs.cmu.edu.
+;;;
+;;; The current version of this software and a variety of related utilities
+;;; may be obtained from the Lisp Repository by anonymous ftp
+;;; from ftp.cs.cmu.edu [128.2.206.173] in the directory
+;;;     user/ai/lang/lisp/code/syntax/infix/
+;;; If your site runs the Andrew File System, you can cd to the AFS directory
+;;;     /afs/cs.cmu.edu/project/ai-repository/ai/lang/lisp/code/syntax/infix/
+;;;
+;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list,
+;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email
+;;; address, and affiliation. This mailing list is primarily for
+;;; notification about major updates, bug fixes, and additions to the Lisp
+;;; Utilities Repository. The mailing list is intended to have low traffic.
+;;;
+
+
+;;; ********************************
+;;; Documentation ******************
+;;; ********************************
+;;;
+;;; Syntax:
+;;;
+;;;   Begin the reader macro with #I( and end it with ). For example,
+;;;      #I( x^2 + y^2 )
+;;;   is equivalent to the Lisp form
+;;;      (+ (expt x 2) (expt y 2))
+;;;   but much easier to read according to some folks.
+;;;
+;;;   If you want to see the expansion, type a quote before the #I form
+;;;   at the Lisp prompt:
+;;;     > '#I(if x<y<=z then f(x)=x^2+y^2 else f(x)=x^2-y^2)
+;;;     (IF (AND (< X Y) (<= Y Z))
+;;;         (SETF (F X) (+ (EXPT X 2) (EXPT Y 2)))
+;;;         (SETF (F X) (- (EXPT X 2) (EXPT Y 2))))
+;;;
+;;;
+;;; Operators:
+;;;
+;;;    NOTE: == is equality, = is assignment (C-style).
+;;;
+;;;     \                   quoting character:  x\-y  -->  x-y
+;;;     !                   lisp escape    !(foo bar) -->  (foo bar)
+;;;     ;                   comment
+;;;     x = y               assignment                     (setf x y)
+;;;     x += y              increment                      (incf x y)
+;;;     x -= y              decrement                      (decf x y)
+;;;     x *= y              multiply and store             (setf x (* x y))
+;;;     x /= y              divide and store               (setf x (/ x y))
+;;;     x|y                 bitwise logical inclusive or   (logior x y)
+;;;     x^^y                bitwise logical exclusive or   (logxor x y)
+;;;     x&y                 bitwise logical and            (logand x y)
+;;;     x<<y                left shift                     (ash x y)
+;;;     x>>y                right shift                    (ash x (- y))
+;;;     ~x                  ones complement (unary)        (lognot x)
+;;;     x and y             conjunction                    (and x y)
+;;;     x && y              conjunction                    (and x y)
+;;;     x or y              disjunction                    (or x y)
+;;;     x || y              disjunction                    (or x y)
+;;;     not x               negation                       (not x)
+;;;     x^y                 exponentiation                 (expt x y)
+;;;     x,y                 sequence                       (progn x y)
+;;;     (x,y)               sequence                       (progn x y)
+;;;                         also parenthesis (x+y)/z -->   (/ (+ x y) z)
+;;;     f(x,y)              functions                      (f x y)
+;;;     a[i,j]              array reference                (aref a i j)
+;;;     x+y x*y             arithmetic                     (+ x y) (* x y) 
+;;;     x-y x/y             arithmetic                     (- x y) (/ x y) 
+;;;     -y                  value negation                 (- y)
+;;;     x % y               remainder                      (mod x y)
+;;;     x<y x>y             inequalities                   (< x y) (> x y)
+;;;     x <= y  x >= y      inequalities                   (<= x y) (>= x y)
+;;;     x == y              equality                       (= x y) 
+;;;     x != y              equality                       (not (= x y))
+;;;     if p then q         conditional                    (when p q)
+;;;     if p then q else r  conditional                    (if p q r) 
+;;;
+
+
+;;; Precedence:
+;;;
+;;;    The following precedence conventions are obeyed by the infix operators:
+;;;      [ ( !
+;;;      ^
+;;;      ~
+;;;      * / %
+;;;      + -
+;;;      << >>
+;;;      < == > <= != >=
+;;;      &
+;;;      ^^
+;;;      |
+;;;      not
+;;;      and
+;;;      or
+;;;      = += -= *= /=
+;;;      , 
+;;;      if
+;;;      then else
+;;;      ] )
+;;;
+;;;    Note that logical negation has lower precedence than numeric comparison
+;;;    so that "not a<b" becomes (not (< a b)), which is different from the
+;;;    C precedence conventions. You can change the precedence conventions by
+;;;    modifying the value of the variable *operator-ordering*.
+;;;
+
+
+;;; ********************************
+;;; To Do **************************
+;;; ********************************
+;;;
+;;;    Write some more test cases.
+;;;    Write some more syntactic optimizations.
+;;;    Would really like ~x to be (not x), but need it for (lognot x). 
+;;;    Support for multiple languages, such as a Prolog parser, a 
+;;;    strictly C compatible parser, etc.
+
+;;; Create a more declarative format, where there is one big table of 
+;;; operators with all the info on them, and also NOT have the list of
+;;; operators in the comment, where they are likely to become wrong when
+;;; changes are made to the code. For example, something like:
+#|
+(define-infix-operators
+  ([  30                           :matchfix aref :end ])
+  (*  20 :infix *                                       )
+  (+  10 :infix +        :prefix +                      )
+  (&  10 :infix and                                     )
+  (+= 10 :infix #'+=-operator                           )
+  ...)
+|#
+
+;;; ********************************
+;;; Change Log *********************
+;;; ********************************
+;;;
+;;;  9-MAR-93 mk     Created
+;;; 12-MAR-93 mk     Fixed defpackage form for Lucid.
+;;; 1.1:
+;;; 14-OCT-93 mk     Changed macro character from #$ to #I(). Suggested by
+;;;                  Scott McKay.
+;;; 1.2:
+;;; 18-JAN-95 norvig Added *print-infix-copyright*, string->prefix, support
+;;;                  for #I"..." in addition to #i(...) which lets one
+;;;                  type #i"a|b" which doesn't confuse editors that aren't
+;;;                  |-aware. Also added := as a synonym for =, so that
+;;;                  '#i"car(a) := b" yields (SETF (CAR A) B).
+;;;
+;;; 1.3:
+;;; 28-JUN-96 mk    Modified infix reader to allow whitespace between the #I
+;;;                 and the start of the expression.
+
+
+
+
+;;; ********************************
+;;; Implementation Notes ***********
+;;; ********************************
+;;;
+;;; Initially we tried implementing everything within the Lisp reader,
+;;; but found this to not be workable. Parameters had to be passed in
+;;; global variables, and some of the processing turned out to be 
+;;; indelible, so it wasn't possible to use any kind of lookahead.
+;;; Center-embedded constructions were also a problem, due to the lack
+;;; of an explicit stack.
+;;;
+;;; So we took another tack, that used below. The #I macro binds the
+;;; *readtable* to a special readtable, which is used solely for tokenization
+;;; of the input. Then the problem is how to correctly parenthesize the input.
+;;; We do that with what is essentially a recursive-descent parser. An 
+;;; expression is either a prefix operator followed by an expression, or an 
+;;; expression followed by an infix operator followed by an expression. When 
+;;; the latter expression is complex, the problem becomes a little tricky. 
+;;; For example, suppose we have
+;;;      exp1 op1 exp2 op2
+;;; We need to know whether to parenthesize it as
+;;;      (exp1 op1 exp2) op2
+;;; or as
+;;;      exp1 op1 (exp2 op2 ...)
+;;; The second case occurs either when op2 has precedence over op1 (e.g.,
+;;; * has precedence over +) or op2 and op1 are the same right-associative
+;;; operator (e.g., exponentiation). Thus the algorithm is as follows:
+;;; When we see op1, we want to gobble up exp2 op2 exp3 op3 ... opn expn+1
+;;; into an expression where op2 through opn all have higher precedence
+;;; than op1 (or are the same right-associative operator), and opn+1 doesn't.
+;;; This algorithm is implemented by the GATHER-SUPERIORS function. 
+;;; 
+;;; Because + and - are implemented in the infix readtable as terminating
+;;; macro cahracters, the exponentiation version of Lisp number syntax
+;;;    1e-3 == 0.001
+;;; doesn't work correctly -- it parses it as (- 1e 3). So we add a little
+;;; cleverness to GATHER-SUPERIORS to detect when the tokenizer goofed. 
+;;; Since this requires the ability to lookahead two tokens, we use a
+;;; stack to implement the lookahead in PEEK-TOKEN and READ-TOKEN.
+;;;
+;;; Finally, the expression returned by GATHER-SUPERIORS sometimes needs to
+;;; be cleaned up a bit. For example, parsing a<b<c would normally return
+;;; (< (< a b) c), which obviously isn't correct. So POST-PROCESS-EXPRESSION
+;;; detects this and similar cases, replacing the expression with (< a b c).
+;;; For cases like a<b<=c, it replaces it with (and (< a b) (<= b c)).
+;;; 
+
+
+;;; ********************************
+;;; Package Cruft ******************
+;;; ********************************
+
+(defpackage "INFIX"
+  (:use #-:lucid "COMMON-LISP" 
+	#+:lucid "LISP" #+:lucid "LUCID-COMMON-LISP")
+  (:export test-infix string->prefix))
+
+(in-package "INFIX")
+
+(pushnew :infix *features*)
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *version* "1.3  28-JUN-96")
+  (defparameter *print-infix-copyright* t
+    "If non-NIL, prints a copyright notice upon loading this file.")
+
+  (defun infix-copyright (&optional (stream *standard-output*))
+    "Prints an INFIX copyright notice and header upon startup."
+    (format stream "~%;;; ~V,,,'*A" 73 "*")
+    (format stream "~%;;;   Infix notation for Common Lisp.")
+    (format stream "~%;;;   Version ~A." *version*)
+    (format stream "~%;;;   Written by Mark Kantrowitz, ~
+                            CMU School of Computer Science.")
+    (format stream "~%;;;   Copyright (c) 1993-95. All rights reserved.")
+    (format stream "~%;;;   May be freely redistributed, provided this ~
+                            notice is left intact.")
+    (format stream "~%;;;   This software is made available AS IS, without ~
+                            any warranty.")
+    (format stream "~%;;; ~V,,,'*A~%" 73 "*")
+    (force-output stream))
+
+  ;; What this means is you can either turn off the copyright notice
+  ;; by setting the parameter, or you can turn it off by including
+  ;; (setf (get :infix :dont-print-copyright) t) in your lisp init file.
+  (when (and *print-infix-copyright* 
+	     (not (get :infix :dont-print-copyright)))
+    (infix-copyright)))
+
+;;; ********************************
+;;; Readtable **********************
+;;; ********************************
+
+(defparameter *infix-readtable* (copy-readtable nil))
+(defparameter *normal-readtable* (copy-readtable nil))
+
+(defmacro infix-error (format-string &rest args)
+  `(let ((*readtable* *normal-readtable*)) 
+     (error ,format-string ,@args)))
+
+(defun infix-reader (stream subchar arg)
+  ;; Read either #I(...) or #I"..."
+  (declare (ignore arg subchar))
+  (let ((first-char (peek-char nil stream t nil t)))
+    (cond ((char= first-char #\space)
+	   (read-char stream)		; skip over whitespace
+	   (infix-reader stream nil nil))
+	  ((char= first-char #\")
+	   ;; Read double-quote-delimited infix expressions.
+	   (string->prefix (read stream t nil t)))
+	  ((char= first-char #\()
+	   (read-char stream)		; get rid of opening left parenthesis
+	   (let ((*readtable* *infix-readtable*)
+		 (*normal-readtable* *readtable*))
+	     (read-infix stream)))
+	  (t
+	   (infix-error "Infix expression starts with ~A" first-char)))))
+
+(set-dispatch-macro-character #\# #\I #'infix-reader *readtable*) ; was #\# #\$
+
+(defun string->prefix (string)
+  "Convert a string to a prefix s-expression using the infix reader.
+  If the argument is not a string, just return it as is."
+  (if (stringp string)
+      (with-input-from-string (stream (concatenate 'string "#I(" string ")"))
+	(read stream))
+      string))
+
+
+(defun read-infix (stream)
+  (let* ((result (gather-superiors '\) stream)) ; %infix-end-token%
+	 (next-token (read-token stream)))
+    (unless (same-token-p next-token '\)) ; %infix-end-token%
+      (infix-error "Infix expression ends with ~A." next-token))
+    result))
+
+(defun read-regular (stream)
+  (let ((*readtable* *normal-readtable*))
+    (read stream t nil t)))
+
+
+
+;;; ********************************
+;;; Reader Code ********************
+;;; ********************************
+
+(defun same-operator-p (x y)
+  (same-token-p x y))
+
+(defun same-token-p (x y)
+  (and (symbolp x)
+       (symbolp y) 
+       (string-equal (symbol-name x) (symbol-name y))))
+
+;;; Peeking Token Reader
+
+(defvar *peeked-token* nil)
+(defun read-token (stream)
+  (if *peeked-token*
+      (pop *peeked-token*)
+      (read stream t nil t)))
+(defun peek-token (stream)
+  (unless *peeked-token*
+    (push (read stream t nil t) *peeked-token*))
+  (car *peeked-token*))
+
+;;; Hack to work around + and - being terminating macro characters,
+;;; so 1e-3 doesn't normally work correctly.
+
+(defun fancy-number-format-p (left operator stream)
+  (when (and (symbolp left)
+	     (find operator '(+ -) :test #'same-operator-p))
+    (let* ((name (symbol-name left))
+	   (length (length name)))
+      (when (and (valid-numberp (subseq name 0 (1- length)))
+		 ;; Exponent, Single, Double, Float, or Long
+		 (find (subseq name (1- length))
+		       '("e" "s" "d" "f" "l")
+		       :test #'string-equal))
+	(read-token stream)
+	(let ((right (peek-token stream)))
+	  (cond ((integerp right)
+		 ;; it is one of the fancy numbers, so return it
+		 (read-token stream)
+		 (let ((*readtable* *normal-readtable*))
+		   (read-from-string (format nil "~A~A~A" 
+					     left operator right))))
+		(t
+		 ;; it isn't one of the fancy numbers, so unread the token
+		 (push operator *peeked-token*)
+		 ;; and return nil
+		 nil)))))))
+
+(defun valid-numberp (string)
+  (let ((saw-dot nil)
+	(char-list (coerce string 'list)))
+    (unless char-list (return-from valid-numberp nil))
+    (dolist (char char-list t)
+      (cond ((char= char #\.)
+	     (if saw-dot
+		 (return nil)
+		 (setq saw-dot t)))
+	    ((not (find char "01234567890" :test #'char=))
+	     (return nil))))))
+
+;;; Gobbles an expression from the stream.
+
+(defun gather-superiors (previous-operator stream)
+  "Gathers an expression whose operators all exceed the precedence of
+   the operator to the left."
+  (let ((left (get-first-token stream)))
+    (loop
+      (setq left (post-process-expression left))
+      (let ((peeked-token (peek-token stream)))
+	(let ((fancy-p (fancy-number-format-p left peeked-token stream)))
+	  (when fancy-p
+	    ;; i.e., we've got a number like 1e-3 or 1e+3 or 1f-1
+	    (setq left fancy-p
+		  peeked-token (peek-token stream))))
+	(unless (or (operator-lessp previous-operator peeked-token)
+		    (and (same-operator-p peeked-token previous-operator)
+			 (operator-right-associative-p previous-operator)))
+	  ;; The loop should continue when the peeked operator is
+	  ;; either superior in precedence to the previous operator,
+	  ;; or the same operator and right-associative.
+	  (return left)))
+      (setq left (get-next-token stream left)))))
+
+(defun get-first-token (stream)
+  (let ((token (read-token stream)))
+    (if (token-operator-p token)
+	;; It's an operator in a prefix context.
+	(apply-token-prefix-operator token stream)
+	;; It's a regular token
+	token)))
+
+(defun apply-token-prefix-operator (token stream)
+  (let ((operator (get-token-prefix-operator token)))
+    (if operator
+	(funcall operator stream)
+	(infix-error "~A is not a prefix operator" token))))
+
+(defun get-next-token (stream left)
+  (let ((token (read-token stream)))
+    (apply-token-infix-operator token left stream)))
+
+(defun apply-token-infix-operator (token left stream)
+  (let ((operator (get-token-infix-operator token)))
+    (if operator
+	(funcall operator stream left)
+	(infix-error "~A is not an infix operator" token))))
+
+;;; Fix to read-delimited-list so that it works with tokens, not
+;;; characters.
+
+(defun infix-read-delimited-list (end-token delimiter-token stream)
+  (do ((next-token (peek-token stream) (peek-token stream))
+       (list nil))
+      ((same-token-p next-token end-token)
+       ;; We've hit the end. Remove the end-token from the stream.
+       (read-token stream)
+       ;; and return the list of tokens.
+       ;; Note that this does the right thing with [] and ().
+       (nreverse list))
+    ;; Ignore the delimiters.
+    (when (same-token-p next-token delimiter-token)
+      (read-token stream))
+    ;; Gather the expression until the next delimiter.
+    (push (gather-superiors delimiter-token stream) list)))
+
+
+
+;;; ********************************
+;;; Precedence *********************
+;;; ********************************
+
+(defparameter *operator-ordering* 
+    '(( \[ \( \! )			; \[ is array reference
+      ( ^ )				; exponentiation
+      ( ~ )				; lognot 
+      ( * /  % )			; % is mod
+      ( + - )
+      ( << >> )
+      ( < == > <= != >= )
+      ( & )				; logand
+      ( ^^ )				; logxor
+      ( \| )				; logior
+      ( not )
+      ( and )
+      ( or )
+      ;; Where should setf and friends go in the precedence?
+      ( = |:=| += -= *= /= )
+      ( \, )				; progn (statement delimiter)
+      ( if )
+      ( then else )
+      ( \] \) )
+      ( %infix-end-token% ))		; end of infix expression
+  "Ordered list of operators of equal precedence.")
+
+(defun operator-lessp (op1 op2)
+  (dolist (ops *operator-ordering* nil)
+    (cond ((find op1 ops :test #'same-token-p)
+	   (return nil))
+	  ((find op2 ops :test #'same-token-p)
+	   (return t)))))
+
+(defparameter *right-associative-operators* '(^ =))
+(defun operator-right-associative-p (operator)
+  (find operator *right-associative-operators*))
+
+
+
+;;; ********************************
+;;; Define Operators ***************
+;;; ********************************
+
+(defvar *token-operators* nil)
+(defvar *token-prefix-operator-table* (make-hash-table))
+(defvar *token-infix-operator-table* (make-hash-table))
+(defun token-operator-p (token)
+  (find token *token-operators*))
+(defun get-token-prefix-operator (token)
+  (gethash token *token-prefix-operator-table*))
+(defun get-token-infix-operator (token)
+  (gethash token *token-infix-operator-table*))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro define-token-operator (operator-name &key
+						 (prefix nil prefix-p)
+						 (infix nil infix-p))
+    `(progn
+       (pushnew ',operator-name *token-operators*)
+       ,(when prefix-p
+	  `(setf (gethash ',operator-name *token-prefix-operator-table*)
+		 #'(lambda (stream)
+		     ,@(cond ((and (consp prefix)
+				   (eq (car prefix) 'infix-error))
+			      ;; To avoid ugly compiler warnings.
+			      `((declare (ignore stream))
+				,prefix))
+			     (t
+			      (list prefix))))))
+       ,(when infix-p
+	  `(setf (gethash ',operator-name *token-infix-operator-table*)
+		 #'(lambda (stream left)
+		     ,@(cond ((and (consp infix)
+				   (eq (car infix) 'infix-error))
+			      ;; To avoid ugly compiler warnings.
+			      `((declare (ignore stream left))
+				,infix))
+			     (t
+			      (list infix)))))))))
+
+;;; Readtable definitions for characters, so that the right token is returned.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro define-character-tokenization (char function)
+    `(set-macro-character ,char ,function nil *infix-readtable*)))
+
+
+
+;;; ********************************
+;;; Operator Definitions ***********
+;;; ********************************
+
+(define-token-operator and
+    :infix  `(and ,left ,(gather-superiors 'and stream)))
+(define-token-operator or
+    :infix  `(or ,left ,(gather-superiors 'or stream)))
+(define-token-operator not
+    :prefix `(not ,(gather-superiors 'not stream)))
+
+(define-token-operator if
+    :prefix (let* ((test (gather-superiors 'if stream))
+		   (then (cond ((same-token-p (peek-token stream) 'then)
+				(read-token stream)
+				(gather-superiors 'then stream))
+			       (t
+				(infix-error "Missing THEN clause."))))
+		   (else (when (same-token-p (peek-token stream) 'else)
+			   (read-token stream)
+			   (gather-superiors 'else stream))))
+	      (cond ((and test then else)
+		     `(if ,test ,then ,else))
+		    ((and test then)
+		     ;; no else clause
+		     `(when ,test ,then))
+		    ((and test else)
+		     ;; no then clause
+		     `(unless ,test ,else))
+		    (t
+		     ;; no then and else clauses --> always NIL
+		     nil))))
+
+(define-token-operator then
+    :prefix (infix-error "THEN clause without an IF."))
+(define-token-operator else
+    :prefix (infix-error "ELSE clause without an IF."))
+
+(define-character-tokenization #\+
+    #'(lambda (stream char)
+	(declare (ignore char))
+	(cond ((char= (peek-char nil stream t nil t) #\=)
+	       (read-char stream t nil t)
+	       '+=)
+	      (t
+	       '+))))
+(define-token-operator +
+    :infix `(+ ,left ,(gather-superiors '+ stream))
+    :prefix (gather-superiors '+ stream))
+(define-token-operator +=
+    :infix `(incf ,left ,(gather-superiors '+= stream)))
+
+(define-character-tokenization #\-
+    #'(lambda (stream char)
+	(declare (ignore char))
+	(cond ((char= (peek-char nil stream t nil t) #\=)
+	       (read-char stream t nil t)
+	       '-=)
+	      (t
+	       '-))))
+(define-token-operator -
+    :infix `(- ,left ,(gather-superiors '- stream))
+    :prefix `(- ,(gather-superiors '- stream)))
+(define-token-operator -=
+    :infix `(decf ,left ,(gather-superiors '-= stream)))
+
+(define-character-tokenization #\*
+    #'(lambda (stream char)
+	(declare (ignore char))
+	(cond ((char= (peek-char nil stream t nil t) #\=)
+	       (read-char stream t nil t)
+	       '*=)
+	      (t
+	       '*))))
+(define-token-operator *
+    :infix `(* ,left ,(gather-superiors '* stream)))
+(define-token-operator *=
+    :infix `(,(if (symbolp left) 
+		  'setq
+		  'setf)
+	      ,left 
+	      (* ,left ,(gather-superiors '*= stream))))
+
+(define-character-tokenization #\/
+    #'(lambda (stream char)
+	(declare (ignore char))
+	(cond ((char= (peek-char nil stream t nil t) #\=)
+	       (read-char stream t nil t)
+	       '/=)
+	      (t
+	       '/))))
+(define-token-operator /
+    :infix `(/ ,left ,(gather-superiors '/ stream))
+    :prefix `(/ ,(gather-superiors '/ stream)))
+(define-token-operator /=
+    :infix `(,(if (symbolp left) 
+		  'setq
+		  'setf)
+	      ,left 
+	      (/ ,left ,(gather-superiors '/= stream))))
+
+(define-character-tokenization #\^
+    #'(lambda (stream char)
+	(declare (ignore char))
+	(cond ((char= (peek-char nil stream t nil t) #\^)
+	       (read-char stream t nil t)
+	       '^^)
+	      (t
+	       '^))))
+(define-token-operator ^
+    :infix `(expt ,left ,(gather-superiors '^ stream)))
+(define-token-operator ^^
+    :infix `(logxor ,left ,(gather-superiors '^^ stream)))
+
+(define-character-tokenization #\|
+    #'(lambda (stream char)
+	(declare (ignore char))
+	(cond ((char= (peek-char nil stream t nil t) #\|)
+	       (read-char stream t nil t)
+	       'or)
+	      (t
+	       '\|))))
+(define-token-operator \|
+    :infix `(logior ,left ,(gather-superiors '\| stream)))
+
+(define-character-tokenization #\&
+    #'(lambda (stream char)
+	(declare (ignore char))
+	(cond ((char= (peek-char nil stream t nil t) #\&)
+	       (read-char stream t nil t)
+	       'and)
+	      (t
+	       '\&))))
+(define-token-operator \&
+    :infix `(logand ,left ,(gather-superiors '\& stream)))
+
+(define-character-tokenization #\%
+    #'(lambda (stream char)
+	(declare (ignore stream char))
+	'\%))
+(define-token-operator \%
+    :infix `(mod ,left ,(gather-superiors '\% stream)))
+
+(define-character-tokenization #\~
+    #'(lambda (stream char)
+	(declare (ignore stream char))
+	'\~))
+(define-token-operator \~
+    :prefix `(lognot ,(gather-superiors '\~ stream)))
+
+(define-character-tokenization #\,
+    #'(lambda (stream char)
+	(declare (ignore stream char))
+	'\,))
+(define-token-operator \,
+    :infix `(progn ,left ,(gather-superiors '\, stream)))
+
+(define-character-tokenization #\=
+    #'(lambda (stream char)
+	(declare (ignore char))
+	(cond ((char= (peek-char nil stream t nil t) #\=)
+	       (read-char stream t nil t)
+	       '==)
+	      (t
+	       '=))))
+(define-token-operator ==
+    :infix `(= ,left ,(gather-superiors '== stream)))
+(define-token-operator =
+    :infix `(,(if (symbolp left) 
+		  'setq
+		  'setf)
+	      ,left
+	      ,(gather-superiors '= stream)))
+
+(define-character-tokenization #\:	
+    #'(lambda (stream char)
+        (declare (ignore char))
+        (cond ((char= (peek-char nil stream t nil t) #\=)
+               (read-char stream t nil t)
+               '|:=|)
+              (t
+               '|:|))))
+(define-token-operator |:=|		
+    :infix `(,(if (symbolp left)
+                  'setq
+                  'setf)
+              ,left
+              ,(gather-superiors '|:=| stream)))
+
+(define-character-tokenization #\<
+    #'(lambda (stream char)
+	(declare (ignore char))
+	(cond ((char= (peek-char nil stream t nil t) #\=)
+	       (read-char stream t nil t)
+	       '<=)
+	      ((char= (peek-char nil stream t nil t) #\<)
+	       (read-char stream t nil t)
+	       '<<)
+	      (t
+	       '<))))
+(define-token-operator <
+    :infix `(< ,left ,(gather-superiors '< stream)))
+(define-token-operator <=
+    :infix `(<= ,left ,(gather-superiors '<= stream)))
+(define-token-operator <<
+    :infix `(ash ,left ,(gather-superiors '<< stream)))
+
+(define-character-tokenization #\>
+    #'(lambda (stream char)
+	(declare (ignore char))
+	(cond ((char= (peek-char nil stream t nil t) #\=)
+	       (read-char stream t nil t)
+	       '>=)
+	      ((char= (peek-char nil stream t nil t) #\>)
+	       (read-char stream t nil t)
+	       '>>)
+	      (t
+	       '>))))
+(define-token-operator >
+    :infix `(> ,left ,(gather-superiors '> stream)))
+(define-token-operator >=
+    :infix `(>= ,left ,(gather-superiors '>= stream)))
+(define-token-operator >>
+    :infix `(ash ,left (- ,(gather-superiors '>> stream))))
+
+(define-character-tokenization #\!
+    #'(lambda (stream char)
+	(declare (ignore char))
+	(cond ((char= (peek-char nil stream t nil t) #\=)
+	       (read-char stream t nil t)
+	       '!=)
+	      (t
+	       '!))))
+(define-token-operator !=
+    :infix `(not (= ,left ,(gather-superiors '!= stream))))
+(define-token-operator !
+    :prefix (read-regular stream))
+
+(define-character-tokenization #\[
+    #'(lambda (stream char)
+	(declare (ignore stream char))
+	'\[))
+(define-token-operator \[
+    :infix (let ((indices (infix-read-delimited-list '\] '\, stream)))
+	     (if (null indices)
+		 (infix-error "No indices found in array reference.")
+		 `(aref ,left ,@indices)))
+    :prefix (let ((list-members (infix-read-delimited-list '\] '\, stream)))
+	      `(:[ ,@list-members)))
+
+(define-character-tokenization #\(
+    #'(lambda (stream char)
+	(declare (ignore stream char))
+	'\())
+(define-token-operator \(
+    :infix `(,left ,@(infix-read-delimited-list '\) '\, stream))
+    :prefix (let ((list (infix-read-delimited-list '\) '\, stream)))
+	      (if (null (rest list))
+		  ;; only one element in list. works correctly if list is NIL
+		  (first list)
+		  ;; several elements in list
+		  `(progn ,@list))))
+
+(define-character-tokenization #\]
+    #'(lambda (stream char)
+	(declare (ignore stream char))
+	'\]))
+(define-token-operator \]
+    :infix (infix-error "Extra close brace \"]\" in infix expression"))
+
+(define-character-tokenization #\)
+    #'(lambda (stream char)
+	(declare (ignore stream char))
+	'\)))
+(define-token-operator \)
+    :infix (infix-error "Extra close paren \")\" in infix expression"))
+
+#|
+;;; Commented out because no longer using $ as the macro character.
+(define-character-tokenization #\$
+    #'(lambda (stream char)
+	(declare (ignore stream char))
+	'%infix-end-token%))
+(define-token-operator %infix-end-token%
+    :infix (infix-error "Prematurely terminated infix expression")
+    :prefix (infix-error "Prematurely terminated infix expression"))
+|#
+
+(define-character-tokenization #\;
+    #'(lambda (stream char)
+	(declare (ignore char))
+	(do ((char (peek-char nil stream t nil t)
+		   (peek-char nil stream t nil t)))
+	    ((or (char= char #\newline) (char= char #\return)
+		 ;; was #\$
+;		 (char= char #\))
+		 )
+	     ;; Gobble characters until the end of the line or the
+	     ;; end of the input.
+	     (cond ((or (char= char #\newline) (char= char #\return))
+		    (read-char stream)
+		    (read stream t nil t))
+		   (t
+		    ;; i.e., return %infix-end-token%
+		    (read stream t nil t))))
+	  (read-char stream))))
+
+
+
+;;; ********************************
+;;; Syntactic Modifications ********
+;;; ********************************
+
+;;; Post processes the expression to remove some unsightliness caused
+;;; by the way infix processes the input. Note that it is also required
+;;; for correctness in the a<b<=c case. 
+
+(defun post-process-expression (expression)
+  (if (and (consp expression)
+	   (= (length expression) 3))
+      (destructuring-bind (operator left right) expression
+	(cond ((and (consp left)
+		    (same-operator-p (first left) operator)
+		    (find operator '(+ * / - and or < > <= >= progn)
+			  :test #'same-operator-p))
+	       ;; Flatten the expression if possible
+	       (cond ((and (eq operator '-)
+			   (= (length left) 2))
+		      ;; -a-b --> (+ (- a) (- b)). 
+		      `(+ ,left (- ,right)))
+		     ((and (eq operator '/)
+			   (= (length left) 2))
+		      ;; ditto with /
+		      `(/ (* ,(second left) ,right)))
+		     (t 
+		      ;; merges a+b+c as (+ a b c).	     
+		      (append left (list right)))))
+	      ((and (consp left)
+		    (eq operator '-)
+		    (eq (first left) '+))
+	       ;; merges a+b-c as (+ a b (- c)).
+	       (append left (list `(- ,right))))
+	      ((and (consp left)
+		    (find operator '(< > <= >=))
+		    (find (first left) '(< > <= >=)))
+	       ;; a<b<c --> a<b and b<c
+	       `(and ,left
+		     (,operator ,(first (last left))
+				,right)))
+	      (t
+	       expression)))
+      expression))
+
+
+
+;;; ********************************
+;;; Test Infix *********************
+;;; ********************************
+
+;;; Invoke with (infix:test-infix). 
+;;; Prints out all the tests that fail and a count of the number of failures.
+
+(defparameter *test-cases*
+    ;; Note that in strings, we have to slashify \ as \\.
+    '(("1 * +2"         (* 1 2))
+      ("1 * -2"         (* 1 (- 2)))
+      ("1 * /2"         (* 1 (/ 2)))
+      ("/2"             (/ 2))
+      ("not true"       (not true))
+      ("foo\\-bar"     foo-bar)
+      ("a + b-c"       (+ a b (- c)))
+      ("a + b\\-c"      (+ a b-c))
+      ("f\\oo"          |FoO|)
+      ("!foo-bar * 2"  (* foo-bar 2))
+      ("!(foo bar baz)" (foo bar baz))
+      ("!foo-bar "     foo-bar)
+      ;; The following now longer gives an eof error, since the close
+      ;; parenthesis terminates the token.
+      ("!foo-bar"      foo-bar)		; eof error -- ! eats the close $
+      ("a+-b"          (+ a (- b)))
+      ("a+b"           (+ a b))
+      ("a+b*c"         (+ a (* b c)))
+      ("a+b+c"         (+ a b c))
+      ("a+b-c"         (+ a b (- c)))
+      ("a+b-c+d"       (+ a b (- c) d))
+      ("a+b-c-d"       (+ a b (- c) (- d)))
+      ("a-b"           (- a b))
+      ("a*b"           (* a b))
+      ("a*b*c"         (* a b c))
+      ("a*b+c"         (+ (* a b) c))
+      ("a/b"           (/ a b))
+      ("a^b"           (expt a b))
+      ("foo/-bar"      (/ foo (- bar)))
+      ("1+2*3^4"       (+ 1 (* 2 (expt 3 4))))
+      ("1+2*3^4+5"     (+ 1 (* 2 (expt 3 4)) 5))
+      ("2*3^4+1"       (+ (* 2 (expt 3 4)) 1))
+      ("2+3^4*5"       (+ 2 (* (expt 3 4) 5)))
+      ("2^3^4"         (expt 2 (expt 3 4)))
+      ("x^2 + y^2"     (+ (expt x 2) (expt y 2)))
+      ("(1+2)/3"       (/ (+ 1 2) 3))
+      ("(a=b)"         (setq a b))
+      ("(a=b,b=c)"     (progn (setq a b) (setq b c)))
+      ("1*(2+3)"       (* 1 (+ 2 3)))
+      ("1+2/3"         (+ 1 (/ 2 3)))
+      ("a,b"           (progn a b))
+      ("a,b,c"         (progn a b c))
+      ("foo(a,b,(c,d))" (foo a b (progn c d)))
+      ("foo(a,b,c)"    (foo a b c))
+      ("(a+b,c)"       (progn (+ a b) c))
+      ("1"             1)
+      ("-1"            (- 1))
+      ("+1"            1)
+      ("1."            1)
+      ("1.1"           1.1)
+      ("1e3"           1000.0)
+      ("1e-3"          0.001)
+      ("1f-3"          1f-3)
+      ("1e-3e"         (- 1e 3e))
+      ("!1e-3 "        0.001)
+      ("a and b and c" (and a b c))
+      ("a and b or c"  (or (and a b) c))
+      ("a and b"       (and a b))
+      ("a or b and c"  (or a (and b c)))
+      ("a or b"        (or a b))
+      ("a<b and b<c"   (and (< a b) (< b c)))
+      ("if (if a then b else c) then e" (when (if a b c) e))
+      ("if 1 then 2 else 3+4"  (if 1 2 (+ 3 4)))
+      ("(if 1 then 2 else 3)+4"  (+ (if 1 2 3) 4))
+      ("if a < b then b else a"   (if (< a b) b a))
+      ("if a and b then c and d else e and f"
+       (if (and a b) (and c d) (and e f)))
+      ("if a or b then c or d else e or f" (if (or a b) (or c d) (or e f)))
+      ("if a then (if b then c else d) else e"  (if a (if b c d) e))
+      ("if a then (if b then c) else d"  (if a (when b c) d))
+      ("if a then b else c"       (if a b c))
+      ("if a then b"              (when a b))
+      ("if a then if b then c else d else e" (if a (if b c d) e))
+      ("if a then if b then c else d"  (when a (if b c d)))
+      ("if if a then b else c then e" (when (if a b c) e))
+      ("if not a and not b then c" (when (and (not a) (not b)) c))
+      ("if not a then not b else not c and d"
+       (if (not a) (not b) (and (not c) d)))
+      ("not a and not b" (and (not a) (not b)))
+      ("not a or not b" (or (not a) (not b)))
+      ("not a<b and not b<c"   (and (not (< a b)) (not (< b c))))
+      ("not a<b"       (not (< a b)))
+      ("a[i,k]*b[j,k]"          (* (aref a i k) (aref b j k)))
+      ("foo(bar)=foo[bar,baz]"  (setf (foo bar) (aref foo bar baz)))
+      ("foo(bar,baz)"           (foo bar baz))
+      ("foo[bar,baz]"           (aref foo bar baz))
+      ("foo[bar,baz]=barf"      (setf (aref foo bar baz) barf))
+      ("max = if a < b then b else a"   (setq max (if (< a b) b a)))
+      ("a < b < c"     (< A B C))
+      ("a < b <= c"    (and (< a b) (<= b c)))
+      ("a <= b <= c"   (<= A B C))
+      ("a <= b <= c"   (<= A B C))
+      ("a!=b and b<c"  (and (not (= a b)) (< b c)))
+      ("a!=b"          (not (= a b)))
+      ("a<b"           (< a b))
+      ("a==b"          (= a b))
+      ("a*b(c)+d"      (+ (* a (b c)) d))
+      ("a+b(c)*d"      (+ a (* (b c) d)))
+      ("a+b(c)+d"      (+ a (b c) d))
+      ("d+a*b(c)"      (+ d (* a (b c))))
+      ("+a+b"          (+ a b))
+      ("-a+b"          (+ (- a) b))
+      ("-a-b"          (+ (- a) (- b)))
+      ("-a-b-c"        (+ (- a) (- b) (- c)))
+      ("a*b/c"         (/ (* a b) c))
+      ("a+b-c"         (+ a b (- c)))
+      ("a-b-c"         (- a b c))
+      ("a/b*c"         (* (/ a b) c))
+      ("a/b/c"         (/ a b c))
+      ("/a/b"          (/ (* a b)))
+      ("a^b^c"         (expt a (expt b c)))
+      ("a(d)^b^c"      (expt (a d) (expt b c)))
+      ("a<b+c<d"       (< a (+ b c) d))
+      ("1*~2+3"        (+ (* 1 (lognot 2)) 3)) 
+      ("1+~2*3"        (+ 1 (* (lognot 2) 3))) 
+      ("1+~2+3"        (+ 1 (lognot 2) 3)) 
+      ("f(a)*=g(b)"    (setf (f a) (* (f a) (g b))))
+      ("f(a)+=g(b)"    (incf (f a) (g b)))
+      ("f(a)-=g(b)"    (decf (f a) (g b)))
+      ("f(a)/=g(b)"    (setf (f a) (/ (f a) (g b))))
+      ("a&b"           (logand a b))
+      ("a^^b"          (logxor a b))
+      ("a|b"           (logior a b))
+      ("a<<b"          (ash a b))
+      ("a>>b"          (ash a (- b)))
+      ("~a"            (lognot a))
+      ("a&&b"          (and a b))
+      ("a||b"          (or a b))
+      ("a%b"           (mod a b))
+
+      ;; Comment character -- must have carriage return after semicolon.
+      ("x^2   ; the x coordinate
+        + y^2 ; the y coordinate" :error)
+      ("x^2   ; the x coordinate
+        + y^2 ; the y coordinate
+        "              (+ (expt x 2) (expt y 2)))
+
+      ;; Errors
+      ("foo(bar,baz"   :error)		; premature termination
+      ;; The following no longer gives an error
+      ("foo(bar,baz))" (foo bar baz))	; extra close parenthesis
+      ("foo[bar,baz]]" :error)		; extra close bracket
+      ("[foo,bar]"     :error)		; AREF is not a prefix operator
+      ("and a"         :error)		; AND is not a prefix operator
+      ("< a"           :error)		; < is not a prefix operator
+      ("=bar"         :error)		; SETF is not a prefix operator
+      ("*bar"          :error)		; * is not a prefix operator
+      ("a not b"       :error)		; NOT is not an infix operator
+      ("a if b then c" :error)		; IF is not an infix operator
+      (""              :error)		; premature termination (empty clause)
+      (")a"            :error)		; left parent is not a prefix operator
+      ("]a"            :error)		; left bracket is not a prefix operator
+      ))
+
+(defun test-infix (&optional (tests *test-cases*))
+  (let ((count 0))
+    (dolist (test tests)
+      (destructuring-bind (string result) test
+	(unless (test-infix-case string result)
+	  (incf count))))
+    (format t "~&~:(~R~) test~p failed." count count)
+    (values)))
+
+(defun test-infix-case (string result)
+  (multiple-value-bind (value error)
+      (let ((*package* (find-package "INFIX")))
+	(ignore-errors
+	 (values (read-from-string (concatenate 'string "#I(" string ")")
+				   t nil))))
+    (cond (error
+	   (cond ((eq result :error)
+		  t)
+		 (t
+		  (format t "~&Test #I(~A) failed with ERROR." string)
+		  nil)))
+	  ((eq result :error)
+	   (format t "~&Test #I(~A) failed. ~
+                           ~&   Expected ERROR ~
+                           ~&   but got ~A." 
+		   string value)
+	   nil)
+	  ((not (equal value result))
+	   (format t "~&Test #I(~A) failed. ~
+                           ~&   Expected ~A ~
+                           ~&   but got ~A." 
+		   string result value)
+	   nil)
+	  (t
+	   t))))  
+
+;;; *EOF*
Index: /trunk/src/make-cgb.lisp
===================================================================
--- /trunk/src/make-cgb.lisp	(revision 14)
+++ /trunk/src/make-cgb.lisp	(revision 14)
@@ -0,0 +1,181 @@
+#|
+  $Id: make-cgb.lisp,v 1.3 2009/01/19 07:05:15 marek Exp $
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+;;(eval-when (eval load compile)
+;;  (require :user-manual "../contrib/user_man/user-manual"))
+
+(defpackage "MAKE-CGB"
+  (:use "COMMON-LISP"))
+
+(in-package "MAKE-CGB")
+
+(defvar *save-path* "cgblisp")
+
+(defvar *cgb-version-string* "CGB Package: @(#)defsystem.lisp, version 1.9 of 2/13/96(17:56:13)"
+  "Refer to this version string when reporting bugs.")
+
+(defvar *lisp-suffix* ".lisp" "File extension used by the lisp system.")
+(defvar *cgb-packages*
+  '("MAKELIST" "ORDER" "MONOM" "XGCD" "MODULAR" "COEFFICIENT-RING"
+    "TERM" "POLY" "MODULAR-POLY" "DIVISION" "PARSE" "PRINTER" "POLY-WITH-SUGAR"
+    "GROBNER" "COLORED-POLY" "POLY-GCD" "RAT" "RATPOLY"
+    "STRING-GROBNER" "DYNAMICS" "PROVER"
+    "INFIX" "CGB-LISP"))
+
+;;----------------------------------------------------------------
+;; Various features which affect the functioning of the package
+;;----------------------------------------------------------------
+
+;;Use pseudodivision to keep the size of integer coefficients 
+;;as small as possible
+(pushnew :pseudodivide *features*)
+
+;;Use the grobner package within colored-poly package
+(pushnew :colored-poly-use-grobner *features*)
+
+;;colored-poly package
+;;Compute saturation of green lists with respect to
+;;red lists in order to eliminate cases early
+(pushnew :use-saturation *features*)
+
+;;Print tracing and debugging output
+(pushnew :debug *features*)
+
+;;Use gcd of integers to keep the size of integer coefficients
+;; of S-polynomials and normal forms down
+(pushnew :use-gcd *features*)
+
+;;grobner package
+;;Use the algorithm of Gebauer and Moeller (1988) to
+;;calculate Grobner bases
+;;(pushnew :use-gebauer-moeller *features*)
+
+#|
+;;Needed by Allegro Common Lisp in order to maintain
+;;compatibility with the book of Steele (1st edition)
+;;in regard to in-package and related operations
+(pushnew :cgb-cltl1-compatibility *features*)
+|#
+
+;;Use pair reordering according to some heuristic in the
+;;Grobner algorithm
+(pushnew :reorder-pairs *features*)
+
+;;Perform Buchberger criterion every time a Grobner
+;;basis is returned or assumed as an argument;
+;;This feature is mostly for debugging by the
+;;package developer, but if you detect failure
+;;of the package in this way, please send the
+;;output to rychlik@math.arizona.edu
+;;DO NOT TURN THIS FEATURE ON IF EFFICIENCY
+;;IS REQUIRED!!!
+;;(pushnew :grobner-check *features*)
+
+#|
+#+cgb-cltl1-compatibility
+(progn
+  #+allegro
+  (progn
+    (setf *cltl1-in-package-compatibility-p* t)
+    (setf comp:*cltl1-compile-file-toplevel-compatibility-p* t)
+    (use-package *cltl1-package*))
+  )
+|#
+
+(defun package-file (package-name)
+  (string-downcase package-name))
+
+(defun cgb-compile ()
+  #+kcl(system "rm *.o")
+  (dolist (package *cgb-packages*)
+    (print '----------------)
+    (compile-file (package-file package))
+    (load (package-file package))))
+
+(defun cgb-load (&key (print nil))
+  (declare (ignore print))
+  (dolist (package *cgb-packages*)
+    (load (package-file package)))
+  ;;A fix around a bug in GCL which causes
+  ;;an undefined symbol __setjmp with
+  ;;compiled code
+  #+gcl (load (concatenate 'string "parse" *lisp-suffix*))
+  )
+
+(defun cgb-load-lisp (&key (print nil))
+  (declare (ignore print))
+  (dolist (package *cgb-packages*)
+    (let ((lisp-file (concatenate 'string (package-file package) *lisp-suffix*)))
+      (load lisp-file)
+      ;;(use-package package)
+      )))
+
+(defun cgb-compile-and-load ()
+  (cgb-compile)
+  (cgb-load))
+
+(defun cgb-go ()
+  (in-package :cgb-lisp))
+
+#+allegro
+(defun start-cgb-lisp ()
+  (tpl:start-interactive-top-level
+   *terminal-io*
+   #'cgb-lisp-top-level-read-eval-print-loop
+   nil
+   :initial-bindings nil))
+
+#+allegro
+(defun cgb-lisp-top-level-read-eval-print-loop (&rest args)
+  (in-package :cgb-lisp)
+  (apply #'tpl:top-level-read-eval-print-loop args))
+
+#+allegro
+(defun cgb-lisp-banner ()
+  (format 
+   t 
+   "~&Comprehensive Grobner Basis package by Marek Rychlik preloaded.~%~a~%"
+   *cgb-version-string*))
+
+#+kcl
+(defun cgb-save ()
+  (defvar system::*akcl-top-level* (symbol-function 'system::top-level))
+  (compile 
+   'system::top-level
+   '(lambda  ()
+      (format 
+       t 
+       "~&Comprehensive Grobner Basis package by Marek Rychlik preloaded.~%~a~%"
+       *cgb-version-string*)
+      (funcall system::*akcl-top-level*)))
+  (save *save-path*))
+
+#+allegro
+(defun cgb-save ()
+  (setf excl:*restart-init-function* 'cgb-lisp-banner)
+  ;;(setf excl:*restart-app-function* 'start-cgb-lisp)
+  (excl:dumplisp
+   :name *save-path*
+   :home-env-var "CGBLISP_HOME"))
+
+;;(load-system)
+
+;;----------------------------------------------------------------
+;; Generate documentation
+;;----------------------------------------------------------------
+;;(defun create-cgb-manuals (prefix format)
+;;  (create-manuals (mapcar #'intern *cgb-packages*)
+;;			      :prefix prefix
+;;			      :extension '.lisp
+;;			      :output-format format))
+
+;;(defun cgb-doc ()
+;;  (create-cgb-manuals '../doc/ 'text)
+;;  (create-cgb-manuals '../latex-doc/ 'latex))
Index: /trunk/src/makelist.lisp
===================================================================
--- /trunk/src/makelist.lisp	(revision 14)
+++ /trunk/src/makelist.lisp	(revision 14)
@@ -0,0 +1,138 @@
+#|
+	$Id: makelist.lisp,v 1.4 2009/01/23 10:45:43 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+(defpackage "MAKELIST"
+  (:use "COMMON-LISP")
+  (:export makelist-1  makelist list-of set-of union-of select sum summation difference standard-vector))
+
+(in-package "MAKELIST")
+
+#+debug(proclaim '(optimize (speed 0) (debug 3)))
+#-debug(proclaim '(optimize (speed 3) (debug 0)))
+
+
+;; 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))
+
+;; Summation with SUM:
+;; Sum of squares of integers from 1 to 10:
+;; >(sum (expt i 2) (i 1 10))
+;; 385
+;; Sum of inverses of integers from 1 to 50:
+;; >(sum (/ n) (n 1 50))
+;; 13943237577224054960759/3099044504245996706400
+;; Sum of 1/(m^2+n^2) where m,n vary from 1 to 10:
+;; >(sum (/ (+ (expt m 2) (expt n 2))) (n 1 10) (m 1 10))
+;; 125085870045079516933345908893314157/42204464874461454985621846571472000
+;; Sum of 1/(m^2+n^2) where m,n vary from 1 to 10 and m>n:
+;; >(sum (/ (+ (expt m 2) (expt n 2))) (n 1 10) (m 1 (1- n)))
+;; 13092731173226115661182811487147/11962716801151206061684196874000
+
+;; 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))))))
+      
+(defmacro sum (&body body)
+  `(reduce #'+ (makelist ,@body)))
+
+(defmacro summation (&body body)
+  ``(+ ,@(makelist ,@body)))
+
+(defmacro difference (&body body)
+  ``(- ,@(makelist ,@body)))
+
+;; List of all EXPR where VAR varies over the list LST
+(defmacro list-of (expr (var lst) &rest more)
+  (if (endp more)
+      `(list-of-1 ,expr ,var ,lst)
+    (let ((l (gensym)))
+      `(let ((,l))
+	(dolist (,var ,lst ,l)
+	  (setf  ,l (nconc ,l ,`(list-of ,expr ,@more))))))))
+
+(defmacro list-of-1 (expr var lst)
+  (let ((l (gensym)))
+    `(let ((,l))
+      (dolist (,var ,lst (reverse ,l))
+	(setf ,l ,`(cons ,expr ,l))))))
+
+;; Union of all EXPR where VAR varies over the list LST
+(defmacro union-of (expr (var lst) &rest more)
+  (if (endp more)
+      `(union-of-1 ,expr ,var ,lst)
+    (let ((l (gensym)))
+      `(let ((,l))
+	(dolist (,var ,lst ,l)
+	  (setf  ,l (union ,l ,`(union-of ,expr ,@more) :test #'equalp)))))))
+
+(defmacro union-of-1 (expr var lst)
+  (let ((l (gensym)))
+    `(let ((,l))
+      (dolist (,var ,lst (reverse ,l))
+	(setf ,l ,`(union ,expr ,l :test #'equalp))))))
+
+
+;; Set of all EXPR where VAR varies over the list LST
+(defmacro set-of (expr (var lst) &rest more)
+  (if (endp more)
+      `(set-of-1 ,expr ,var ,lst)
+    (let ((l (gensym)))
+      `(let ((,l))
+	(dolist (,var ,lst ,l)
+	  (setf  ,l (union ,l ,`(set-of ,expr ,@more) :test #'equalp)))))))
+
+(defmacro set-of-1 (expr var lst)
+  (let ((l (gensym)))
+    `(let ((,l))
+      (dolist (,var ,lst (reverse ,l))
+	(pushnew ,expr ,l :test #'equalp)))))
+
+;; sublist of LST consisting of elements with indecies in IND
+(defun select (ind lst)
+  (cond 
+    ((endp ind) nil)
+    (t (cons (elt lst (car ind)) (select (cdr ind) lst)))))
+
+(defun standard-vector (n k &optional (coeff 1)
+			&aux (v (make-list n :initial-element 0)))
+  "Returns vector (0 0 ... 1 ... 0 0) of length N, where 1 appears on K-th place."
+  (setf (elt v k) coeff)
+  v)
Index: /trunk/src/modular-poly.lisp
===================================================================
--- /trunk/src/modular-poly.lisp	(revision 14)
+++ /trunk/src/modular-poly.lisp	(revision 14)
@@ -0,0 +1,40 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
+#|
+	$Id: modular-poly.lisp,v 1.2 2009/01/22 04:04:10 marek Exp $
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+(defpackage "MODULAR-POLY"
+  (:export modular-trace modular-trace-1)
+  (:use "MODULAR" "POLY" "COMMON-LISP"))
+    
+(in-package "MODULAR-POLY")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(defun modular-trace (plist modulus)
+  "Return PLIST with coefficients reduced modulo prime MODULUS."
+  (mapcar #'(lambda (p) (modular-trace-1 p modulus)) plist))
+
+(defun modular-trace-1 (p modulus)
+  "Return a polynomial P with coefficients reduced modulo prime MODULUS."
+  (mapcar
+   #'(lambda (term) (cons (car term) (mod (cdr term) modulus)))
+   p))
+
+(defun frobenius-kernel (n modulus)
+  "Return a list of N polynomials of the form XI**MODULUS-XI, where
+XI is the I-th variable. Work in internal alist representation."
+  (let* ((zero (make-list n :initial-element 0))
+	 (plist (make-list n :initial-element (list (cons zero 1) (cons zero (- modulus 1))))))
+    (dotimes (i n plist)
+      (setf (elt plist i) (copy-tree (elt plist i))
+	    (elt (caar (elt plist i)) i) modulus
+	    (elt (caadr (elt plist i)) i) 1))))
+    
Index: /trunk/src/modular.lisp
===================================================================
--- /trunk/src/modular.lisp	(revision 14)
+++ /trunk/src/modular.lisp	(revision 14)
@@ -0,0 +1,53 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
+#|
+	$Id: modular.lisp,v 1.4 2009/01/22 04:03:50 marek Exp $
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+(defpackage "MODULAR"
+  (:export modular-division make-modular-division)
+  (:use "XGCD" "COMMON-LISP"))
+    
+(in-package "MODULAR")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(defun modular-inverse (x p)
+  "Find the inverse of X modulo prime P, using Euclid algorithm."
+  (multiple-value-bind (gcd u v)
+      (xgcd x p)
+    (declare (ignore gcd v))
+    (mod u p)))
+
+(defun modular-division (x y p)
+  "Divide X by Y modulo prime P."
+  (mod (* x (modular-inverse y p)) p))
+
+(defvar *inverse-by-lookup-limit* 100000
+  "If prime modulus is < this number then the division algorithm
+will use a lookup table of inverses created at the time when field-modulo-prime is called.")
+  
+(defun make-inverse-table (modulus &aux (table (list 0)))
+  "Make a vector of length MODULUS containing all inverses modulo MODULUS,
+which should be a prime number. The inverse of 0 is 0."
+  (do ((x 1 (1+ x))) ((>= x modulus) (apply #'vector (nreverse table)))
+    (push (modular-inverse x modulus) table)))
+
+(defun make-modular-division (modulus)
+  "Return a function of two arguments which will perform division
+modulo MODULUS. Currently, if MODULUS is < *INVERSE-BY-LOOKUP-LIMIT*
+then the returned function does table lookup, otherwise it uses
+the Euclid algorithm to find the inverse."
+  (cond
+   ((>= modulus *inverse-by-lookup-limit*)
+    #'(lambda (x y) (modular-division x y modulus)))
+   (t
+    (let ((table (make-inverse-table modulus)))
+      #'(lambda (x y)
+	  (mod (* x (svref table y)) modulus))))))
Index: /trunk/src/monom.lisp
===================================================================
--- /trunk/src/monom.lisp	(revision 14)
+++ /trunk/src/monom.lisp	(revision 14)
@@ -0,0 +1,70 @@
+#|
+	$Id: monom.lisp,v 1.3 2009/01/22 04:04:31 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+(defpackage "MONOM"
+  (:use "COMMON-LISP")
+  (:export monom-equal monom-divides-p monom-divisible-by-p monom-rel-prime
+	   monom* nmonom* monom/ 
+	   monom-lcm monom-gcd))
+
+(in-package "MONOM")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+;;----------------------------------------------------------------
+;; This package implements BASIC OPERATIONS ON MONOMIALS
+;;----------------------------------------------------------------
+;; DATA STRUCTURES: Monomials are represented as lists:
+;;
+;; 	monom:	(n1 n2 ... nk) where ni are non-negative integers
+;;
+;;----------------------------------------------------------------
+;; EXAMPLES: Suppose that variables are x and y. Then
+;;
+;; 	Monom x*y^2 ---> (1 2)
+;;
+;;----------------------------------------------------------------
+
+(defun monom/ (m1 m2)
+  "Divide monomial M1 by monomial M2."
+  (mapcar #'- m1 m2))
+
+(defun monom* (m1 m2)
+  "Multiply monomial M1 by monomial M2."
+  (mapcar #'+ m1 m2))
+
+(defun nmonom* (m1 m2)
+  "Multiply monomials M1 and M2 - destructive version.
+  M1 is destructively modified, M2 is not modified."
+  (mapl #'(lambda (x y) (incf (car x) (car y))) m1 m2))
+
+(defun monom-divides-p (m1 m2)
+  "Returns T if monomial M1 divides monomial M2, NIL otherwise."
+   (every #'<= m1 m2))
+
+(defun monom-divisible-by-p (m1 m2)
+  "Returns T if monomial M1 is divisible by monomial M2, NIL otherwise."
+   (every #'>= m1 m2))
+
+(defun monom-rel-prime (m1 m2)
+  "Returns T if two monomials M1 and M2 are relatively prime (disjoint)."
+  (every #'(lambda (x y) (zerop (min x y))) m1 m2))
+
+(defun monom-equal (m1 m2)
+  "Returns T if two monomials M1 and M2 are equal."
+   (every #'= m1 m2))
+
+(defun monom-lcm (m1 m2)
+  "Returns least common multiple of monomials M1 and M2."
+  (mapcar #'max m1 m2))
+
+(defun monom-gcd (m1 m2)
+  "Returns greatest common divisor of monomials M1 and M2."
+  (mapcar #'min m1 m2))
Index: /trunk/src/order.lisp
===================================================================
--- /trunk/src/order.lisp	(revision 14)
+++ /trunk/src/order.lisp	(revision 14)
@@ -0,0 +1,137 @@
+#|
+	$Id: order.lisp,v 1.4 2009/01/23 10:39:41 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+;; Order relations for vectors of numbers
+;; Below p, q is a multiindex: p ---> (n1 n2 ... nk), where ni are
+;; nonnegative integers. The package, though, will work with any
+;; kind of real numbers.
+;; These functions have a common interface
+;; Their arguments are:
+;; -two monomials P and Q to be compared
+;; -function KEY which is called before comparing the entries
+;; -START and END which restrict the index range for comparison
+;; Each of the functions returs two values
+;; -T or NIL depending on whether P>Q or not
+;; -the second value is T if the sequences are equal
+
+(defpackage "ORDER"
+  (:use "COMMON-LISP")
+  (:export
+   lex>
+   invlex>
+   grlex>
+   grevlex>
+   elimination-order
+   elimination-order-1
+   total-degree))
+   
+(in-package "ORDER")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+;; pure lexicographic
+(defun lex> (p q &optional (start 0) (end (length 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."
+  (do ((i start (1+ i)))
+      ((>= i end) (values NIL T))
+    (cond
+     ((> (elt p i) (elt q i)) 
+      (return-from lex> (values t nil)))
+     ((< (elt p i) (elt q i))
+      (return-from lex> (values nil nil))))))
+
+;; total degree of a multiindex
+(defun total-degree (m &optional (start 0) (end (length m)))
+  "Return the todal degree of a monomoal M."
+  (reduce #'+ (subseq m start end)))
+
+;; total degree order , ties broken by lexicographic
+(defun grlex> (p q &optional (start 0) (end (length 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."
+  (let ((d1 (total-degree p start end))
+	(d2 (total-degree q start end)))
+    (cond
+      ((> d1 d2) (values t nil))
+      ((< d1 d2) (values nil nil))
+      (t
+       (lex> p q start end)))))
+
+;; reverse lexicographic
+(defun revlex> (p q &optional (start 0) (end (length 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."
+  (do ((i (1- end) (1- i)))
+      ((< i start) (values NIL T))
+    (cond
+     ((< (elt p i) (elt q i)) 
+      (return-from revlex> (values t nil)))
+     ((> (elt p i) (elt q i)) 
+     (return-from revlex> (values nil nil))))))
+
+;; total degree, ties broken by reverse lexicographic
+(defun grevlex> (p q &optional (start 0) (end (length 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."
+  (let ((d1 (total-degree p start end))
+	(d2 (total-degree q start end)))
+    (cond 
+     ((> d1 d2) (values t nil))
+     ((< d1 d2) (values nil nil))
+     (t (revlex> p q start end)))))
+
+(defun invlex> (p q &optional (start 0) (end (length 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."
+  (do ((i (1- end) (1- i)))
+       ((< i start) (values NIL T))
+      (cond
+	((> (elt p i) (elt q i)) 
+	 (return-from invlex> (values t nil)))
+	((< (elt p i) (elt q i)) 
+	 (return-from invlex> (values nil nil))))))
+
+
+;;----------------------------------------------------------------
+;; Order making functions
+;;----------------------------------------------------------------
+
+;; Make an order which compares the first K variables according to
+;; PRIMARY-ORDER and the remaining elements according to
+;; SECONDARY-ORDER
+(defun elimination-order (k &key (primary-order #'lex>)
+			    (secondary-order #'lex>))
+  "Return a predicate which compares monomials according to the
+K-th elimination order. Two optional arguments are PRIMARY-ORDER
+and SECONDARY-ORDER and they should be term orders which are used
+on the first K and the remaining variables."
+  #'(lambda (p q &optional (start 0) (end (length p)))
+      (multiple-value-bind (primary equal)
+	  (funcall primary-order p q start k)
+	(if equal
+	    (funcall secondary-order p q k end)
+	  (values primary nil)))))
+
+(defun elimination-order-1 (order)
+  "A special case of the ELIMINATION-ORDER when there is only
+one primary variable."
+  #'(lambda (p q
+	     &optional (start 0)
+		       (end (length p)))
+      (cond
+	((> (elt p start) (elt q start)) (values t nil))
+	((< (elt p start) (elt q start)) (values nil nil))
+	(t (funcall order p q (1+ start) end)))))
+
+      
Index: /trunk/src/parse.lisp
===================================================================
--- /trunk/src/parse.lisp	(revision 14)
+++ /trunk/src/parse.lisp	(revision 14)
@@ -0,0 +1,285 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
+#|
+	$Id: parse.lisp,v 1.11 2009/01/22 04:05:13 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+(defpackage "PARSE"
+  (:export parse parse-to-alist parse-string-to-alist 
+	   parse-to-sorted-alist parse-string-to-sorted-alist ^ [
+	   poly-eval)
+  (:use "ORDER" "POLY" "COEFFICIENT-RING" "COMMON-LISP")
+  (:shadow sort-poly))
+
+(in-package "PARSE")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+;; The function PARSE yields the representations as above.  The two functions
+;; PARSE-TO-ALIST and PARSE-STRING-TO-ALIST parse polynomials to the alist
+;; representations. For example
+;;
+;; >(parse)x^2-y^2+(-4/3)*u^2*w^3-5 --->
+;; (+ (* 1 (^ X 2)) (* -1 (^ Y 2)) (* -4/3 (^ U 2) (^ W 3)) (* -5))
+;;
+;; >(parse-to-alist '(x y u w))x^2-y^2+(-4/3)*u^2*w^3-5 --->
+;; (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1) ((0 0 0 0) . -5))
+;;
+;; >(parse-string-to-alist "x^2-y^2+(-4/3)*u^2*w^3-5" '(x y u w)) --->
+;; (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1) ((0 0 0 0) . -5))
+;;
+;; >(parse-string-to-alist "[x^2-y^2+(-4/3)*u^2*w^3-5,y]" '(x y u w))
+;; ([ (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1)
+;;     ((0 0 0 0) . -5))
+;;    (((0 1 0 0) . 1)))
+;; The functions PARSE-TO-SORTED-ALIST and PARSE-STRING-TO-SORTED-ALIST
+;; in addition sort terms by the predicate defined in the ORDER package
+;; For instance:
+;; >(parse-to-sorted-alist '(x y u w))x^2-y^2+(-4/3)*u^2*w^3-5
+;; (((2 0 0 0) . 1) ((0 2 0 0) . -1) ((0 0 2 3) . -4/3) ((0 0 0 0) . -5))
+;; >(parse-to-sorted-alist '(x y u w) t #'grlex>)x^2-y^2+(-4/3)*u^2*w^3-5
+;; (((0 0 2 3) . -4/3) ((2 0 0 0) . 1) ((0 2 0 0) . -1) ((0 0 0 0) . -5))
+
+;;(eval-when (compile)
+;;  (proclaim '(optimize safety)))
+
+(defun convert-number (number-or-poly n)
+  "Returns NUMBER-OR-POLY, if it is a polynomial. If it is a number,
+it converts it to the constant monomial in N variables. If the result
+is a number then convert it to a polynomial in N variables."
+  (if (numberp number-or-poly)
+      (list (cons (make-list n :initial-element 0) number-or-poly))
+    number-or-poly))
+
+(defun $poly+ (p q n order ring)
+  "Add two polynomials P and Q, where each polynomial is either a
+numeric constant or a polynomial in internal representation. If the
+result is a number then convert it to a polynomial in N variables."
+  (poly+ (convert-number p n) (convert-number q n) order ring))
+
+(defun $poly- (p q n order ring)
+  "Subtract two polynomials P and Q, where each polynomial is either a
+numeric constant or a polynomial in internal representation. If the
+result is a number then convert it to a polynomial in N variables."
+  (poly- (convert-number p n) (convert-number q n) order ring))
+
+(defun $minus-poly (p n ring)
+  "Negation of P is a polynomial is either a numeric constant or a
+polynomial in internal representation. If the result is a number then
+convert it to a polynomial in N variables."
+  (minus-poly (convert-number p n) ring))
+
+(defun $poly* (p q n order ring)
+  "Multiply two polynomials P and Q, where each polynomial is either a
+numeric constant or a polynomial in internal representation. If the
+result is a number then convert it to a polynomial in N variables."
+  (poly* (convert-number p n) (convert-number q n) order ring))
+
+(defun $poly/ (p q ring)
+  "Divide a polynomials P which is either a numeric constant or a
+polynomial in internal representation, by a number Q."
+  (if (numberp p)
+      (common-lisp:/ p q)
+      (scalar-times-poly (common-lisp:/ q) p ring)))
+    
+(defun $poly-expt (p l n order ring)
+  "Raise polynomial P, which is a polynomial in internal
+representation or a numeric constant, to power L. If P is a number,
+convert the result to a polynomial in N variables."
+  (poly-expt (convert-number p n) l order ring))
+
+(defun parse (&optional stream)
+  "Parser of infis expressions with integer/rational coefficients
+The parser will recognize two kinds of polynomial expressions:
+
+- polynomials in fully expanded forms with coefficients
+  written in front of symbolic expressions; constants can be optionally
+  enclosed in (); for example, the infix form
+  	X^2-Y^2+(-4/3)*U^2*W^3-5
+  parses to
+	(+ (- (EXPT X 2) (EXPT Y 2)) (* (- (/ 4 3)) (EXPT U 2) (EXPT W 3)) (- 5))
+
+- lists of polynomials; for example
+        [X-Y, X^2+3*Z]          
+  parses to
+	  (:[ (- X Y) (+ (EXPT X 2) (* 3 Z)))
+  where the first symbol [ marks a list of polynomials.
+
+-other infix expressions, for example
+        [(X-Y)*(X+Y)/Z,(X+1)^2]
+parses to:
+	(:[ (/ (* (- X Y) (+ X Y)) Z) (EXPT (+ X 1) 2))
+Currently this function is implemented using M. Kantrowitz's INFIX package."
+  (read-from-string
+   (concatenate 'string
+     "#I(" 
+     (with-output-to-string (s)
+       (loop
+	 (multiple-value-bind (line eof)
+	     (read-line stream t)
+	   (format s "~A" line)
+	   (when eof (return)))))
+     ")")))
+
+;; Translate output from parse to a pure list form
+;; assuming variables are VARS
+
+(defun alist-form (plist vars)
+  "Translates an expression PLIST, which should be a list of polynomials
+in variables VARS, to an alist representation of a polynomial.
+It returns the alist. See also PARSE-TO-ALIST."
+  (cond
+   ((endp plist) nil)
+   ((eql (first plist) '[)
+    (cons '[ (mapcar #'(lambda (x) (alist-form x vars)) (rest plist))))
+   (t
+    (assert (eql (car plist) '+))
+    (alist-form-1 (rest plist) vars))))
+
+(defun alist-form-1 (p vars
+			 &aux (ht (make-hash-table
+				   :test #'equal :size 16))
+			 stack)
+  (dolist (term p)
+    (assert (eql (car term) '*))
+    (incf  (gethash (powers (cddr term) vars) ht 0) (second term)))
+  (maphash #'(lambda (key value) (unless (zerop value)
+				   (push (cons key value) stack))) ht)
+  stack)
+    
+(defun powers (monom vars
+		     &aux (tab (pairlis vars (make-list (length vars)
+							:initial-element 0))))
+  (dolist (e monom (mapcar #'(lambda (v) (cdr (assoc v tab))) vars))
+    (assert (equal (first e) '^))
+    (assert (integerp (third e)))
+    (assert (= (length e) 3))
+    (let ((x (assoc (second e) tab)))
+      (if (null x) (error "Variable ~a not in the list of variables." 
+			 (second e))
+	(incf (cdr x) (third e))))))
+  
+
+;; New implementation based on the INFIX package of Mark Kantorowitz
+(defun parse-to-alist (vars &optional stream)
+  "Parse an expression already in prefix form to an association list form
+according to the internal CGBlisp polynomial syntax: a polynomial is an
+alist of pairs (MONOM . COEFFICIENT). For example:
+  (WITH-INPUT-FROM-STRING (S \"X^2-Y^2+(-4/3)*U^2*W^3-5\")
+	(PARSE-TO-ALIST '(X Y U W) S))
+evaluates to
+(((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1) ((0 0 0 0) . -5))"
+  (poly-eval (parse stream) vars))
+
+
+(defun parse-string-to-alist (str vars)
+  "Parse string STR and return a polynomial as a sorted association
+list of pairs (MONOM . COEFFICIENT). For example:
+(parse-string-to-alist \"[x^2-y^2+(-4/3)*u^2*w^3-5,y]\" '(x y u w))
+ ([ (((0 0 2 3) . -4/3) ((0 2 0 0) . -1) ((2 0 0 0) . 1)
+     ((0 0 0 0) . -5))
+    (((0 1 0 0) . 1)))
+The functions PARSE-TO-SORTED-ALIST and PARSE-STRING-TO-SORTED-ALIST
+sort terms by the predicate defined in the ORDER package."
+  (with-input-from-string (stream str)
+    (parse-to-alist vars stream)))
+
+
+(defun parse-to-sorted-alist (vars &optional (order #'lex>) (stream t))
+  "Parses streasm STREAM and returns a polynomial represented as 
+a sorted alist. For example:
+(WITH-INPUT-FROM-STRING (S \"X^2-Y^2+(-4/3)*U^2*W^3-5\")
+  (PARSE-TO-SORTED-ALIST '(X Y U W) S))
+returns
+(((2 0 0 0) . 1) ((0 2 0 0) . -1) ((0 0 2 3) . -4/3) ((0 0 0 0) . -5))
+and
+(WITH-INPUT-FROM-STRING (S \"X^2-Y^2+(-4/3)*U^2*W^3-5\")
+  (PARSE-TO-SORTED-ALIST '(X Y U W) T #'GRLEX>) S)
+returns
+(((0 0 2 3) . -4/3) ((2 0 0 0) . 1) ((0 2 0 0) . -1) ((0 0 0 0) . -5))"
+  (sort-poly (parse-to-alist vars stream) order))
+
+(defun parse-string-to-sorted-alist (str vars &optional (order #'lex>))
+  "Parse a string to a sorted alist form, the internal representation
+of polynomials used by our system."
+  (with-input-from-string (stream str)
+    (parse-to-sorted-alist vars order stream)))
+
+(defun sort-poly-1 (p order)
+  "Sort the terms of a single polynomial P using an admissible monomial order ORDER.
+Returns the sorted polynomial. Destructively modifies P."
+  (sort p order :key #'first))
+
+;; Sort a polynomial or polynomial list
+(defun sort-poly (poly-or-poly-list &optional (order #'lex>))
+  "Sort POLY-OR-POLY-LIST, which could be either a single polynomial
+or a list of polynomials in internal alist representation, using
+admissible monomial order ORDER. Each polynomial is sorted using
+SORT-POLY-1."
+  (cond
+   ((eql poly-or-poly-list :syntax-error) nil)
+   ((null poly-or-poly-list) nil)
+   ((eql (car poly-or-poly-list) '[)
+    (cons '[ (mapcar #'(lambda (p) (sort-poly-1 p order)) 
+		     (rest poly-or-poly-list))))
+   (t (sort-poly-1 poly-or-poly-list order))))
+
+(defun poly-eval-1 (expr vars order ring &aux (n (length vars)))
+  "Evaluate an expression EXPR as polynomial
+by substituting operators + - * expt with
+corresponding polynomial operators
+and variables VARS with monomials (1 0 ... 0), (0 1 ... 0) etc.
+We use special versions of binary
+operators $poly+, $poly-, $minus-poly, $poly* and $poly-expt
+which work like the corresponding functions in the
+POLY package, but accept scalars as arguments as well."
+  (eval
+   (sublis
+    (pairlis '(+ - * / expt) 
+	     `((lambda (&rest r) (reduce #'(lambda (p q) ($poly+ p q ,n ,order ,ring)) r))
+	       (lambda (p &rest r)
+		 (if (endp r) ($minus-poly p ,n ,ring)
+		     ($poly- p (reduce #'(lambda (p q) ($poly+ p q ,n ,order ,ring)) r) ,n
+			     ,order ,ring)))
+	       (lambda (&rest r) (reduce #'(lambda (p q) ($poly* p q ,n ,order ,ring)) r))
+	       (lambda (p q) ($poly/ p q ,ring))
+	       (lambda (p l) ($poly-expt p l ,n ,order ,ring))))
+    (sublis
+     (pairlis vars (monom-basis (length vars)))
+     expr))))
+	     
+(defun poly-eval (expr vars &optional (order #'lex>) (ring *coefficient-ring*))
+  "Evaluate an expression EXPR, which should be a polynomial
+expression or a list of polynomial expressions (a list of expressions
+marked by prepending keyword :[ to it) given in lisp prefix notation,
+in variables VARS, which should be a list of symbols. The result of
+the evaluation is a polynomial or a list of polynomials (marked by
+prepending symbol '[) in the internal alist form. This evaluator is
+used by the PARSE package to convert input from strings directly to
+internal form."
+  (cond
+   ((numberp expr) (list (cons (make-list (length vars) :initial-element 0) expr)))
+   ((or (symbolp expr) (not (eq (car expr) :[)))
+    (poly-eval-1 expr vars order ring))
+   (t (cons '[ (mapcar #'(lambda (p) (poly-eval-1 p vars order ring)) (rest expr))))))
+
+
+;; Return the standard basis of the monomials in n variables
+(defun monom-basis (n &aux
+		      (basis
+		       (copy-tree
+			(make-list n :initial-element
+				   (list 'quote (list (cons
+						       (make-list
+							n
+							:initial-element 0)
+						       1)))))))
+  "Generate a list of monomials ((1 0 ... 0) (0 1 0 ... 0) ... (0 0 ... 1)
+which correspond to linear monomials X1, X2, ... XN."
+  (dotimes (i n basis)
+    (setf (elt (caaadr (elt basis i)) i) 1)))
Index: /trunk/src/poly-gcd.lisp
===================================================================
--- /trunk/src/poly-gcd.lisp	(revision 14)
+++ /trunk/src/poly-gcd.lisp	(revision 14)
@@ -0,0 +1,103 @@
+#|
+	$Id: poly-gcd.lisp,v 1.4 2009/01/22 04:05:32 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+(defpackage "POLY-GCD"
+  (:export poly-gcd poly-content poly-pseudo-divide poly-primitive-part
+		   poly-pseudo-remainder)
+  (:use "ORDER" "POLY" "DIVISION" "COMMON-LISP"))
+
+(in-package "POLY-GCD")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+;; This package calculates GCD of polynomials over integers.
+;; They are assumed to be ordered lexicographically. 
+;;
+;; The algorithm is that on p. 57 of Geddes, Czapor, Labahn
+;; Given polynomials a(x),b(x) in D[x] where D is a UFD, we
+;; compute g(x)=GCD(a(x),b(x))
+;; Assume that the poly's are sorted lexicographically
+
+(defun poly-gcd (a b)
+  (cond
+   ((endp a) b)
+   ((endp b) a)
+   ((endp (caar a))			;scalar
+    (list (cons nil (gcd (cdar a) (cdar b)))))
+   (t
+    (do* ((r nil (poly-pseudo-remainder c d))
+	  (c (poly-primitive-part a) d)
+	  (d (poly-primitive-part b) (poly-primitive-part r)))
+	((endp d)
+	 (poly* (poly-extend 
+		 (poly-gcd (poly-content a) (poly-content b)))
+		c))))))
+	 
+;; Perform a pseudo-division in k[x2,....,xn][x1]
+;; Assume that the terms are sorted according to decreasing powers of x1
+;; p.297 of Cox
+(defun poly-pseudo-divide (f g)	
+  (multiple-value-bind (lg grest)
+      (lpart g)
+    (do* ((m (mdeg g))
+	  (dm (poly-extend lg))
+	  (lpart nil (multiple-value-list (lpart r)))
+	  (lr nil (car lpart))
+	  (lrest nil (cadr lpart))
+	  (term nil (poly-extend lr (list (- (mdeg r) m))))
+	  (r f (poly- (poly* dm lrest)
+		      (poly* term grest)))
+	  (q nil (append (poly* dm q) term)))
+	((or (endp r) (< (mdeg r) m))
+	 (values q r)))))
+
+
+(defun poly-pseudo-remainder (f g)
+  (second (multiple-value-list (poly-pseudo-divide f g))))
+
+;; Degree in main variable
+(defun mdeg (b) (caaar b))
+
+;; Leading coefficient in the first variable; a poly in k[x2,...,xn]
+(defun lcoeff (b)
+  (first (multiple-value-list (lpart b))))
+
+(defun lrest (b)
+  (second (multiple-value-list (lpart b))))
+
+(defun lpart (b)
+  (do ((mdeg (mdeg b))
+       (b b (rest b))
+       (b1 nil (cons  (cons (cdaar b) (cdar b)) b1)))
+      ((or (endp b) (/= (caaar b) mdeg))
+       (values (reverse b1) b))))
+
+;; Divide f by its content
+(defun poly-primitive-part (f)
+  (cond
+   ((endp (caar f))			;scalar
+    f)
+   (t
+    (poly-exact-divide f (poly-extend (poly-content f))))))
+
+
+(defun poly-content (f)
+  (cond
+   ((endp f) (error "Zero argument"))
+   (t (multiple-value-bind (lc r)
+	  (lpart f)
+	(cond
+	 ((endp r) lc)
+	 ((and (= (length lc) 1)
+	       (every #'zerop (caar lc))
+	       (or (= (cdar lc) 1) 
+		   (= (cdar lc) -1)))	;lc is 1 or -1
+	  lc)
+	 (t (poly-gcd lc (poly-content r))))))))
Index: /trunk/src/poly-with-sugar.lisp
===================================================================
--- /trunk/src/poly-with-sugar.lisp	(revision 14)
+++ /trunk/src/poly-with-sugar.lisp	(revision 14)
@@ -0,0 +1,141 @@
+#|
+	$Id: poly-with-sugar.lisp,v 1.3 2009/01/22 04:06:12 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+(defpackage "POLY-WITH-SUGAR"
+  (:export poly-with-sugar-poly
+	   poly-with-sugar-tail
+	   poly-with-sugar-sugar
+	   monom-sugar
+	   term-sugar
+	   monom-times-poly-with-sugar
+	   scalar-times-poly-with-sugar
+	   term-times-poly-with-sugar
+	   minus-poly-with-sugar
+	   poly-with-sugar+
+	   poly-with-sugar- 
+	   poly-with-sugar-op
+	   poly-with-sugar-zerop
+	   poly-with-sugar-nreverse
+	   poly-with-sugar-append
+	   poly-with-sugar-lm
+	   poly-with-sugar-lc
+	   poly-with-sugar-lt
+	   poly-add-sugar)
+  (:use "ORDER" "MONOM" "TERM" "TERM" "POLY" "COEFFICIENT-RING" "COMMON-LISP"))
+
+(in-package "POLY-WITH-SUGAR")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+;;----------------------------------------------------------------
+;; BASIC OPERATIONS ON POLYNOMIALS of many variables WITH SUGAR
+;; Hybrid operations involving polynomials and monomials or terms
+;;----------------------------------------------------------------
+;; The representation is as follows:
+;;
+;;	polynomial-with-sugar:	(poly . sugar)
+;;
+;;----------------------------------------------------------------
+
+(defun poly-with-sugar-poly (p) (car p))
+(defun poly-with-sugar-sugar (p) (cdr p))
+(defun poly-with-sugar-tail (p) (cons (cdar p) (cdr p)))
+
+(defsetf poly-with-sugar-poly (p) (poly)
+  `(setf (car ,p) ,poly))
+
+(defsetf poly-with-sugar-sugar (p) (sugar)
+  `(setf (cdr ,p) ,sugar))
+
+(defsetf poly-with-sugar-tail (p) (tail)
+  `(setf (cdar ,p) ,tail))
+
+;;----------------------------------------------------------------
+;; Sugar of monomials and terms
+;; The total degree is used
+;;----------------------------------------------------------------
+(defun monom-sugar (m)
+  (total-degree m))
+
+(defun coefficient-sugar (c ring)
+  (funcall (ring-length ring) c))
+
+(defun term-sugar (term ring)
+  (declare (ignore ring))
+  (monom-sugar (term-monom term)))
+
+;;----------------------------------------------------------------
+;; Initialize sugar of an ordinary polynomial
+;;----------------------------------------------------------------
+(defun poly-add-sugar (poly ring)
+  (cons poly
+	(apply #'max (mapcar #'(lambda (term) (term-sugar term ring)) poly))))
+
+;; Multiplies scalar c by a polynomial p
+(defun scalar-times-poly-with-sugar (c p ring)
+  (cons (scalar-times-poly c (poly-with-sugar-poly p) ring)
+	(poly-with-sugar-sugar p)))
+
+;; Multiplies term m by a poly-with-sugar f
+(defun term-times-poly-with-sugar (term f ring)
+  (cons (term-times-poly term (poly-with-sugar-poly f) ring)
+	(+ (poly-with-sugar-sugar f) (term-sugar term ring))))
+
+;; Multiply a monom by a poly-with-sugarnomial
+(defun monom-times-poly-with-sugar (m f)
+  (cons
+   (monom-times-poly m (poly-with-sugar-poly f))
+   (+ (poly-with-sugar-sugar f) (monom-sugar m))))
+
+;; Changes the sign of the polynomial f with sugar
+(defun minus-poly-with-sugar (f ring)
+  (cons
+   (minus-poly (poly-with-sugar-poly f) ring)
+   (poly-with-sugar-poly f)))
+
+;; Addition and subtraction of polynomials with sugar
+(defun poly-with-sugar+ (p q pred ring)
+  (cons
+   (poly+ (poly-with-sugar-poly p) (poly-with-sugar-poly q) pred ring)
+   (max (poly-with-sugar-sugar p) (poly-with-sugar-sugar q))))
+
+;; Addition and subtraction of polynomials with sugar
+(defun poly-with-sugar- (p q pred ring)
+  (cons
+   (poly- (poly-with-sugar-poly p) (poly-with-sugar-poly q) pred ring)
+   (max (poly-with-sugar-sugar p) (poly-with-sugar-sugar q))))
+
+;; Implement f-term*g
+(defun poly-with-sugar-op (f term g pred ring)
+  (poly-with-sugar- f (term-times-poly-with-sugar term g ring) pred ring))
+
+
+;; Destructively reverse the order of terms in a polynomial with sugar
+(defun poly-with-sugar-nreverse (p)
+  (setf (poly-with-sugar-poly p) (nreverse (poly-with-sugar-poly p)))
+  p)
+
+;; Append two polynomials with sugar, which are assumed to be
+;; sorted and all terms of q are smaller than terms of p
+(defun poly-with-sugar-append (p q)
+  (cons (append (poly-with-sugar-poly p) (poly-with-sugar-poly q))
+	(max (poly-with-sugar-sugar p) (poly-with-sugar-sugar q))))
+
+(defun poly-with-sugar-zerop (p)
+  (poly-zerop (poly-with-sugar-poly p)))
+
+(defun poly-with-sugar-lm (p)
+  (lm (poly-with-sugar-poly p)))
+
+(defun poly-with-sugar-lc (p)
+  (lc (poly-with-sugar-poly p)))
+
+(defun poly-with-sugar-lt (p)
+  (lt (poly-with-sugar-poly p)))
Index: /trunk/src/poly.lisp
===================================================================
--- /trunk/src/poly.lisp	(revision 14)
+++ /trunk/src/poly.lisp	(revision 14)
@@ -0,0 +1,206 @@
+#|
+	$Id: poly.lisp,v 1.6 2009/01/22 04:05:52 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+(defpackage "POLY"
+  (:export monom-times-poly scalar-times-poly term-times-poly
+	   minus-poly poly+ poly- poly* poly-expt
+	   sort-poly poly-op poly-constant-p poly-extend
+	   poly-mexpt poly-extend-end
+	   lt lm lc poly-zerop)
+  (:use "ORDER" "MONOM" "TERM" "COEFFICIENT-RING" "COMMON-LISP"))
+(in-package "POLY")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+;;----------------------------------------------------------------
+;; BASIC OPERATIONS ON POLYNOMIALS of many variables
+;; Hybrid operations involving polynomials and monomials or terms
+;;----------------------------------------------------------------
+;; The representations are as follows:
+;;
+;; 	monom:		(n1 n2 ... nk) where ni are non-negative integers
+;;	term:		(monom . coefficient)
+;;	polynomial:	(term1 term2 ... termk)
+;;
+;; The terms in a polynomial are assumed to be sorted in descending order by
+;; some admissible well-ordering, typically defaulting to the lexicographic
+;; order from  the "order" package.  Thus, the polynomials are represented
+;; non-recursively as alists.
+;;----------------------------------------------------------------
+;; EXAMPLES: Suppose that variables are x and y. Then
+;; Monom x*y^2 ---> (1 2)
+;; Term  3*x*y^2 ---> ((1 2) . 3) 
+;; Polynomial x^2+x*y ---> (((2 0) . 1) ((1 1) . 1))
+;;----------------------------------------------------------------
+
+
+(defun scalar-times-poly (c p &optional (ring *coefficient-ring*))
+  "Return product of a scalar C by a polynomial P with coefficient ring RING."
+  (unless (funcall (ring-zerop ring) c)
+    (mapcar
+     #'(lambda (term) (cons (car term) (funcall (ring-* ring) c (cdr term))))
+     p)))
+
+(defun term-times-poly (term f &optional (ring *coefficient-ring*))
+  "Return product of a term TERM by a polynomial F with coefficient ring RING."
+  (mapcar #'(lambda (x) (term* term x ring)) f))
+
+(defun monom-times-poly (m f)
+  "Return product of a monomial M by a polynomial F with coefficient ring RING."
+  (mapcar #'(lambda (x) (monom-times-term m x)) f))
+
+(defun minus-poly (f &optional (ring *coefficient-ring*))
+  "Changes the sign of a polynomial F with coefficients in coefficient ring
+RING, and returns the result."
+  (mapcar #'(lambda (x) (cons (car x) (funcall (ring-- ring) (cdr x)))) f))
+
+(defun sort-poly (poly
+		  &optional 
+		  (pred #'lex>)
+		  (start 0)
+		  (end (unless (null poly) ;zero
+			 (length (caar poly)))))
+  "Destructively Sorts a polynomial POLY by predicate PRED; the predicate is assumed
+to take arguments START and END in addition to the pair of
+monomials, as the functions in the ORDER package do."
+  (sort poly #'(lambda (p q) (funcall pred p q :start start :end end))
+	:key #'first))
+
+(defun poly+ (p q &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Returns the sum of two polynomials P and Q with coefficients in
+ring RING, with terms ordered according to monomial order PRED."
+  (do (r)
+      (nil)
+    (cond 
+      ((endp p) (return (nreconc r q)))
+      ((endp q) (return (nreconc r p)))
+      (t 
+       (multiple-value-bind 
+	     (mgreater mequal)
+	   (funcall pred (caar p) (caar q))
+	 (cond
+	   (mequal
+	    (let ((s (funcall (ring-+ ring) (cdar p) (cdar q))))
+	      (unless (funcall (ring-zerop ring) s)		;check for cancellation
+		      (setf r (cons (cons (caar p) s) r)))
+	      (setf p (cdr p) q (cdr q))))
+	   (mgreater
+	    (setf r (cons (car p) r)
+		  p (cdr p)))
+	   (t (setf r (cons (car q) r)
+		    q (cdr q)))))))))
+
+(defun poly- (p q &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Returns the difference of two polynomials P and Q with coefficients
+in ring RING, with terms ordered according to monomial order PRED."
+  (do (r done)
+      (done r)
+    (cond 
+      ((endp p) (return (revappend r (minus-poly q ring))))
+      ((endp q) (return (revappend r p)))
+      (t 
+       (multiple-value-bind 
+	     (mgreater mequal)
+	   (funcall pred (caar p) (caar q))
+	 (cond
+	   (mequal
+	    (let ((s (funcall (ring-- ring) (cdar p) (cdar q))))
+	      (unless (zerop s)		;check for cancellation
+		(setf r (cons (cons (caar p) s) r)))
+	      (setf p (cdr p) q (cdr q))))
+	   (mgreater
+	    (setf r (cons (car p) r)
+		  p (cdr p)))
+	   (t (setf r (cons (cons (caar q) (funcall (ring-- ring) (cdar q))) r)
+		    q (cdr q)))))))))
+
+;; Multiplication of polynomials
+;; Non-destructive version
+(defun poly* (p q &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Returns the product of two polynomials P and Q with coefficients in
+ring RING, with terms ordered according to monomial order PRED."
+  (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
+	(t (cons (cons  (monom* (caar p) (caar q))
+			(funcall (ring-* ring) (cdar p) (cdar q)))
+		   (poly+ (term-times-poly (car p) (cdr q) ring)
+			  (poly* (cdr p) q pred ring)
+			  pred ring)))))
+
+(defun poly-op (f m g pred ring)
+  "Returns F-M*G, where F and G are polynomials with coefficients in
+ring RING, ordered according to monomial order PRED and M is a
+monomial."
+  (poly- f (term-times-poly m g ring) pred ring))
+
+(defun poly-expt (poly n &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Exponentiate a polynomial POLY to power N. The terms of the
+polynomial are assumed to be ordered by monomial order PRED and with
+coefficients in ring RING.  Use the Chinese algorithm; assume N>=0 and
+POLY is non-zero (not NIL)."
+  (labels ((poly-one ()
+	     (list
+	      (cons (make-list (length (caar poly)) :initial-element 0) (ring-unit ring)))))
+    (cond
+     ((minusp n) (error "Negative exponent."))
+     ((endp poly) (if (zerop n) (poly-one) nil))
+     (t
+      (do ((k 1 (ash k 1))
+	   (q poly (poly* q q pred ring))	;keep squaring
+	   (p (poly-one) (if (not (zerop (logand k n))) (poly* p q pred ring) p)))
+	  ((> k n) p))))))
+
+(defun poly-mexpt (plist monom &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Raise a polynomial vector represented ad a list of polynomials
+PLIST to power MULTIINDEX.  Every polynomial has its terms ordered by
+predicate PRED and coefficients in the ring RING."
+  (reduce 
+   #'(lambda (u v) (poly* u v pred ring))
+   (mapcan #'(lambda (y i)
+	       (cond ((endp y) (if (zerop i) nil (list nil)))
+		     (t (list (poly-expt y i pred ring)))))
+	   plist monom)))
+
+(defun poly-constant-p (p)
+  "Returns T if P is a constant polynomial."
+  (and (= (length p) 1)
+       (every #'zerop (caar p))))
+
+       
+(defun	poly-extend (p &optional (m (list 0)))
+  "Given a polynomial P in k[x[r+1],...,xn], it returns the same
+polynomial as an element of k[x1,...,xn], optionally multiplying it by
+a monomial x1^m1*x2^m2*...*xr^mr, where m=(m1,m2,...,mr) is a
+multiindex."
+  (mapcar #'(lambda (term) (cons (append m (car term)) (cdr term))) p))
+
+(defun	poly-extend-end (p &optional (m (list 0)))
+  "Similar to POLY-EXTEND, but it adds new variables at the end."
+  (mapcar #'(lambda (term) (cons (append (car term) m) (cdr term))) p))
+
+(defun poly-zerop (p)
+  "Returns T if P is a zero polynomial."
+  (null p))
+
+(defun lt (p)
+  "Returns the leading term of a polynomial P."
+  #+debugging(assert (consp p))
+  (first p))
+
+(defun lm (p)
+  "Returns the leading monomial of a polynomial P."
+  #+debugging(assert (consp (lt p)))
+  (car (lt p)))
+
+(defun lc (p)
+  "Returns the leading coefficient of a polynomial P."
+  #+debugging(assert (consp (lt p)))
+  (cdr (lt p)))
+
Index: /trunk/src/printer.lisp
===================================================================
--- /trunk/src/printer.lisp	(revision 14)
+++ /trunk/src/printer.lisp	(revision 14)
@@ -0,0 +1,103 @@
+#|
+	$Id: printer.lisp,v 1.3 2009/01/22 04:06:32 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+(defpackage "PRINTER"
+  (:export poly-print print-term print-monom)
+  (:use "COMMON-LISP"))
+  
+(in-package "PRINTER")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(defun poly-print (plist vars &optional (stream t))
+  "Prints a polynomial or  a list of polynomials PLIST using infix syntax compatible
+with most software systems. The following data representations are assumed:
+1) Polynomial list is ([ poly1 poly2 ...)
+2) Polynomial is a list (term1 term2 ...)
+3) Term is (monom . number)
+4) Monom is (number1 number2 ...) and is a list of powers at corresponding 
+variables
+Variable names must be provided to the printer explicitly."
+  (cond 
+    ((and (symbolp (car plist)) (string= (symbol-name (car plist)) "["))
+     (format stream "[ ")
+     (poly-print-2 (rest plist) vars stream)
+     (format stream " ]"))
+    ;; Not a list but a single polynomial
+    (t (poly-print-1 plist vars stream))))
+
+(defun poly-print-1 (p vars &optional (stream t))
+  "An auxillary function of POLY-PRINT. It prints a single polynomial P."
+  (labels ((infix-sum (l &optional (beg t))
+	     (unless (endp l)
+	       (infix-term (first l) beg)
+	       (infix-sum (rest l) nil)))
+ 	   (infix-term (l &optional beg)
+	     (unless (zerop (cdr l))
+	       (case (cdr l)
+		 (1 (unless beg (format stream " + "))
+		    (infix-monom (first l) vars t))
+		 (-1 (format stream " - ") (infix-monom (first l) vars t))
+		 (otherwise
+		  (cond
+		    ((plusp (cdr l)) (unless beg (format stream " + ")))
+		    ((minusp (cdr l)) (format stream " - ")))
+		  (format stream "~d" (abs (cdr l)))
+		  (infix-monom (first l) vars nil)))))
+ 	   (infix-monom (l vars &optional beg)
+	     (cond
+	       ((endp l) (when beg (format stream "~d" 1)))
+	       (t
+		(unless (zerop (car l))
+		  (unless beg (format stream " * "))
+		  ;; if in x^n we have n=1 then print just x
+		  (format stream "~a~:[^~d~;~*~]" (car vars)
+			  (= (car l) 1) (car l)))
+		(infix-monom (rest l) (rest vars) (and (zerop (car l)) beg)))
+	       )))
+    (if (endp p)
+	(format stream "0")
+      (infix-sum p)))
+  p)
+
+(defun poly-print-2 (plist vars stream &optional (beg t))
+  "An auxillary function of POLY-PRINT. It prints a comma-separated list of polynomials PLIST."
+  (unless (endp plist)
+    (unless beg (format stream ", "))
+    (poly-print-1 (first plist) vars stream)
+    (poly-print-2 (rest plist) vars stream nil)))
+
+
+(defun print-term (l vars &optional (stream t) beg)
+  "An auxillary function of POLY-PRINT. It prints a single term L."
+  (unless (zerop (cdr l))
+    (case (cdr l)
+      (1 (unless beg (format stream " + "))
+	 (print-monom (first l) vars stream t))
+      (-1 (format stream " - ") (print-monom (first l) vars stream t))
+      (otherwise
+       (cond
+	((plusp (cdr l)) (unless beg (format stream " + ")))
+	((minusp (cdr l)) (format stream " - ")))
+       (format stream "~d" (abs (cdr l)))
+       (print-monom (first l) vars stream nil)))))
+
+(defun print-monom (l vars &optional (stream t) beg)
+  "An auxillary function of POLY-PRINT. It prints a single monomial L."
+  (cond
+   ((endp l) (when beg (format stream "~d" 1)))
+   (t
+    (unless (zerop (car l))
+      (unless beg (format stream " * "))
+      ;; if in x^n we have n=1 then print just x
+      (format stream "~a~:[^~d~;~*~]" (car vars)
+	      (= (car l) 1) (car l)))
+    (print-monom (rest l) (rest vars) stream (and (zerop (car l)) beg)))
+   ))
Index: /trunk/src/prover.lisp
===================================================================
--- /trunk/src/prover.lisp	(revision 14)
+++ /trunk/src/prover.lisp	(revision 14)
@@ -0,0 +1,211 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
+#|
+	$Id: prover.lisp,v 1.3 2009/01/22 04:06:51 marek Exp $
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+(defpackage "PROVER"
+  (:use "COMMON-LISP" "GROBNER" "PARSE" "ORDER" "COEFFICIENT-RING" "PRINTER")
+  (:export identical-points perpendicular parallel collinear translate-theorem prove-theorem
+	   equidistant midpoint translate-statements real-identical-points
+	   euclidean-distance
+	   *prover-order*))
+
+(in-package "PROVER")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(defvar *prover-order* #'grevlex>
+  "Admissible monomial order used internally in the proofs of theorems.")
+
+;; Translate a geometric theorem specification into a statement of the
+;; form
+;; for all u1, u2, ... , us f1=f2=...=fn=0 => g=0
+
+(defun csym (symbol number)
+  "Return symbol whose name is a concatenation of (SYMBOL-NAME SYMBOL)
+and a number NUMBER."
+  (intern (concatenate 'string (symbol-name symbol) (format nil "~d" number))))
+
+(defmacro real-identical-points (A B)
+  "Return [ (A1-B1)**2 + (A2-B2)**2 ] in lisp (prefix) notation.
+The second value is the list of variables (A1 B1 A2 B2). Note that
+if the distance between two complex points A, B is zero, it does not
+mean that the points are identical. Use IDENTICAL-POINTS to express
+the fact that A and B are really identical. Use this macro in conclusions
+of theorems, as it may not be possible to prove that A and B are trully
+identical in the complex domain."
+  (let ((A1 (csym A 1))
+	(A2 (csym A 2))
+	(B1 (csym B 1))
+	(B2 (csym B 2)))
+    `(list
+      '((+ (expt (- ,A1 ,B1) 2) (expt (- ,A2 ,B2) 2)))
+      '(,A1 ,A2 ,B1 ,B2))))
+
+(defmacro identical-points (A B)
+  "Return [ A1-B1, A2-B2 ] in lisp (prefix) notation.
+The second value is the list of variables (A1 B1 A2 B2). Note that
+sometimes one is able to prove only that (A1-B1)**2 + (A2-B2)**2 = 0.
+This equation in the complex domain has solutions with A and B distinct.
+Use REAL-IDENTICAL-POINTS to express the fact that the distance between
+two points is 0. Use this macro in assumptions of theorems, although this
+is seldom necessary because we assume most of the time that in assumptions
+all points are distinct if they are denoted by different symbols."
+  (let ((A1 (csym A 1))
+	(A2 (csym A 2))
+	(B1 (csym B 1))
+	(B2 (csym B 2)))
+    `(list
+      '((- ,A1 ,B1) (- ,A2 ,B2))
+      '(,A1 ,A2 ,B1 ,B2))))
+
+(defmacro perpendicular (A B C D)
+  "Return [ (A1-B1) * (C1-D1) + (A2-B2) * (C2-D2) ] in lisp (prefix) notation.
+The second value is the list of variables (A1 A2 B1 B2 C1 C2 D1 D2)."
+  (let ((A1 (csym A 1))
+	(A2 (csym A 2))
+	(B1 (csym B 1))
+	(B2 (csym B 2))
+	(C1 (csym C 1))
+	(C2 (csym C 2))
+	(D1 (csym D 1))
+	(D2 (csym D 2)))
+    `(list
+      '((+ (* (- ,A1 ,B1) (- ,C1 ,D1))
+	   (* (- ,A2 ,B2) (- ,C2 ,D2))))
+      '(,A1 ,A2 ,B1 ,B2 ,C1 ,C2 ,D1 ,D2))))
+
+(defmacro parallel (A B C D)
+  "Return [ (A1-B1) * (C2-D2) - (A2-B2) * (C1-D1) ] in lisp (prefix) notation.
+The second value is the list of variables (A1 A2 B1 B2 C1 C2 D1 D2)."
+  (let ((A1 (csym A 1))
+	(A2 (csym A 2))
+	(B1 (csym B 1))
+	(B2 (csym B 2))
+	(C1 (csym C 1))
+	(C2 (csym C 2))
+	(D1 (csym D 1))
+	(D2 (csym D 2)))
+    `(list
+      '((- (* (- ,A1 ,B1) (- ,C2 ,D2))
+	   (* (- ,A2 ,B2) (- ,C1 ,D1))))
+      '(,A1 ,A2 ,B1 ,B2 ,C1 ,C2 ,D1 ,D2))))
+
+
+(defmacro collinear (A B C)
+  "Return the determinant det([[A1,A2,1],[B1,B2,1],[C1,C2,1]]) in lisp (prefix) notation.
+The second value is the list of variables (A1 A2 B1 B2 C1 C2)."
+  (let ((A1 (csym A 1))
+	(A2 (csym A 2))
+	(B1 (csym B 1))
+	(B2 (csym B 2))
+	(C1 (csym C 1))
+	(C2 (csym C 2)))
+    `(list
+      '((+ (- (* ,B1 ,C2) (* ,B2 ,C1))
+	   (- (* ,A2 ,C1) (* ,A1 ,C2))
+	   (- (* ,A1 ,B2) (* ,A2 ,B1))))
+      '(,A1 ,A2 ,B1 ,B2 ,C1 ,C2))))
+
+(defmacro equidistant (A B C D)
+  "Return the polynomial [(A1-B1)**2+(A2-B2)**2-(C1-D1)**2-(C2-D2)**2] in lisp (prefix)
+notation. The second value is the list of variables (A1 A2 B1 B2 C1 C2 D1 D2)."
+  (let ((A1 (csym A 1))
+	(A2 (csym A 2))
+	(B1 (csym B 1))
+	(B2 (csym B 2))
+	(C1 (csym C 1))
+	(C2 (csym C 2))
+	(D1 (csym D 1))
+	(D2 (csym D 2)))
+    `(list
+      '((- (+ (expt (- ,A1 ,B1) 2) (expt (- ,A2 ,B2) 2))
+	   (+ (expt (- ,C1 ,D1) 2) (expt (- ,C2 ,D2) 2))))
+      '(,A1 ,A2 ,B1 ,B2 ,C1 ,C2 ,D1 ,D2))))
+  
+(defmacro euclidean-distance (A B R)
+  "Return the polynomial [(A1-B1)**2+(A2-B2)**2-R^2] in lisp (prefix)
+notation. The second value is the list of variables (A1 A2 B1 B2 R)."
+    (let ((A1 (csym A 1))
+	  (A2 (csym A 2))
+	  (B1 (csym B 1))
+	  (B2 (csym B 2)))
+      `(list
+	'((- (+ (expt (- ,A1 ,B1) 2) (expt (- ,A2 ,B2) 2))
+	     (expt ,R 2)))
+	'(,A1 ,A2 ,B1 ,B2 ,R))))
+
+(defmacro midpoint (A B C)
+  "Express the fact that C is a midpoint of the segment AB.
+Returns the list [ 2*C1-A1-B1, 2*C2-A2-B2 ]. The second value returned is the list
+of variables (A1 A2 B1 B2 C1 C2)."
+  (let ((A1 (csym A 1))
+	(A2 (csym A 2))
+	(B1 (csym B 1))
+	(B2 (csym B 2))
+	(C1 (csym C 1))
+	(C2 (csym C 2)))
+    `(list
+      '((- (* 2 ,C1) ,A1 ,B1) (- (* 2 ,C2) ,A2 ,B2))
+      '(,A1 ,A2 ,B1 ,B2 ,C1 ,C2))))
+
+(defmacro translate-statements (&rest statements)
+  `(list (mapcar #'car (list ,@statements))
+	 (remove-duplicates (apply #'append (mapcar #'cadr (list ,@statements))))))
+
+(defmacro translate-assumptions (&rest assumptions)
+  (let ((x (gensym)))
+    `(let ((,x (translate-statements ,@assumptions)))
+       (list (apply #'append (car ,x))
+	     (cadr ,x)))))
+
+(defmacro translate-conclusions (&rest conclusions)
+  `(translate-statements ,@conclusions))
+  
+(defmacro translate-theorem ((&rest assumptions) (&rest conclusions))
+  "Translates a planar geometry theorem into a system of polynomial equations.
+Each assumption or conclusion takes form of a declaration (RELATION-NAME A B C ...)
+where A B C are points, entered as symbols and RELATION-NAME is a name of
+a geometric relation, for example, (COLLINEAR A B C) means that points A, B, C
+are all collinear. The translated equations use the convention that (A1,A2)
+are the coordinates of the point A. This macro returns multiple values.
+The first value is a list of polynomial expressions and the second value
+is an automatically generated list of variables from points A, B, C, etc.
+For convenience, several macros have been defined in order to make specifying
+common geometric relations easy."
+  `(values
+    (translate-assumptions ,@assumptions)
+    (translate-conclusions ,@conclusions)))
+
+(defmacro prove-theorem ((&rest assumptions) (&rest conclusions)
+			 &key (order *prover-order*))
+  "Proves a geometric theorem, specified in the same manner as in
+the macro TRANSLATE-THEOREM. The proof is achieved by a call to
+IDEAL-POLYSATURATION. The theorem is true if the returned value
+is a trivial ideal containing 1."
+  (let ((vars (gensym))
+	(ideal (gensym))
+	(assump (gensym))
+	(concl (gensym)))
+    `(multiple-value-bind (,assump ,concl)
+	 (translate-theorem ,assumptions ,conclusions)
+       (let* ((,vars (union (second ,assump) (second ,concl)))
+	      (,ideal (ideal-polysaturation 
+		      (cdr (poly-eval `(:[ ,@(car ,assump)) ,vars
+				      ,order *ring-of-integers*))
+		      (mapcar #'(lambda (x)
+				  (cdr (poly-eval (cons :[ x) ,vars
+						  ,order *ring-of-integers*)))
+			      (car ,concl))
+		      ,order
+		      0
+		      nil
+		      *ring-of-integers*)))
+	 (poly-print (cons '[ ,ideal) ,vars)
+	 (values)))))
Index: /trunk/src/rat.lisp
===================================================================
--- /trunk/src/rat.lisp	(revision 14)
+++ /trunk/src/rat.lisp	(revision 14)
@@ -0,0 +1,92 @@
+#|
+	$Id: rat.lisp,v 1.4 2009/01/22 04:07:12 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+;;
+;; Arithmetic on rational functions in n variables
+;; They are represented as conses of two polynomials, represented 
+;; as in the monom package, ordered lexicographically (the default
+;; of the monom package).
+;; This package is trivial in the sense that it does not produce
+;; results in which numerator and denominator are relatively prime.
+;; However, zero testing works correctly. This is all that is
+;; needed for the resultant package
+;;
+
+(defpackage "RAT"
+  (:export num denom rat+ rat- rat* rat/ scalar-times-rat scalar-div-rat
+	   rat-zerop rat-uminus rat-expt rat-constant rat-to-poly
+	   rat-simplify)
+  (:use "ORDER" "POLY-GCD" "DIVISION" "POLY" "COMMON-LISP"))
+ 
+(in-package "RAT")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(defun num (p) (car p))			;numerator
+(defun denom (p) (cdr p))		;denominator
+
+(defun rat-simplify-2 (num denom)
+  (let ((gcd (poly-gcd num denom)))
+    (cons (poly-exact-divide num gcd)
+	  (poly-exact-divide denom gcd))))
+
+(defun rat-simplify (p)
+  (rat-simplify-2 (car p) (cdr p)))
+
+(defun rat+ (p q)
+  ;; p1/p2+q1/q2=(p1*q2+p2*q1)/(p2*q2)
+  (rat-simplify-2 
+   (poly+ (poly* (num p) (denom q))
+		(poly* (denom p) (num q)))
+   (poly* (denom p) (denom q))))
+
+(defun rat- (p q)
+  ;; p1/p2-q1/q2=(p1*q2+p2-q1)/(p2*q2)
+  (rat-simplify-2
+   (poly- (poly* (num p) (denom q))
+	  (poly* (denom p) (num q)))
+   (poly* (denom p) (denom q))))
+
+;; This could be more efficient if it simplified before multiplication
+(defun rat* (p q)
+  (rat-simplify-2
+   (poly* (num p) (num q))
+   (poly* (denom p) (denom q))))
+
+(defun rat/ (p q)
+  (rat-simplify-2
+   (poly* (num p) (denom q))
+   (poly* (denom p) (num q))))
+
+(defun scalar-times-rat (scalar p)
+  (cons (scalar-times-poly scalar (num p)) (denom p)))
+
+;; scalar/rational-fun
+(defun scalar-div-rat (scalar p)
+  (cons (scalar-times-poly scalar (denom p)) (num p)))
+
+(defun rat-zerop (p)
+  (endp (car p)))
+
+(defun rat-uminus (p)
+  (cons (minus-poly (car p)) (cdr p)))
+
+(defun rat-expt (p n)
+  (cons (poly-expt (car p) n) (poly-expt (cdr p) n)))
+
+(defun rat-constant (c n)
+  "Make a constant rational function equal to c with n variables"
+  (cons (list (cons (make-list n :initial-element 0) c))
+	(list (cons (make-list n :initial-element 0) 1))))
+
+(defun rat-to-poly (p)
+  "Attempt to convert a rational function to a polynomial by
+dividing numerator by denominator. Error if not divisible"
+  (poly-exact-divide (car p) (cdr p)))
Index: /trunk/src/ratpoly.lisp
===================================================================
--- /trunk/src/ratpoly.lisp	(revision 14)
+++ /trunk/src/ratpoly.lisp	(revision 14)
@@ -0,0 +1,303 @@
+#|
+	$Id: ratpoly.lisp,v 1.4 2009/01/22 04:07:33 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+;; Operations in the ring k(x2,x3,...,xn)[x1]
+;; The representation is (n1 a1 n2 a2 ... nk ak)
+;; where ak are rational functions in an arbitrary number of variables 
+;; as in the "rat" package; this representation is referred to as RATPOLY
+;;
+;; Another representation is POLY1 and this corresponds to reppresenting
+;; polynomials as elements of k[x2,x3,...,xn][x1]
+;;
+;; In order to facilitate input, a function called 
+;; poly-to-ratpoly is provided; it converts a polynomial in alist form
+;; to a form like above (plist form) with ai being rational
+;; Output is done by function ratpoly-print
+;;
+ 
+(defpackage "RATPOLY"
+  (:export ratpoly+ ratpoly- ratpoly* ratpoly-uminus scalar-times-ratpoly
+	   rat-times-ratpoly ratpoly-divide ratpoly-remainder
+	   ratpoly-gcd ratpoly-diff ratpoly-square-free
+	   ratpoly-normalize ratpoly-resultant
+	   deg lead ratpoly-discriminant ratpoly-print
+	   poly-to-ratpoly ratpoly-to-poly poly-resultant)
+  (:use "RAT" "PRINTER" "MONOM"  "DIVISION" "TERM" "POLY" "COMMON-LISP"))
+
+(in-package "RATPOLY")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+;; Arithmetic on polynomials in one variable
+;; The polynomial a1 * x^n1 + a2 * x^n2 + ... + ak * x^nk
+;; where ai are nonzero numbers and n1>n2>...>nk is represented as list
+;; 	(n1 a1 n2 a2 ... nk ak)
+;; This is the sparse recursive representation
+
+(defun ratpoly+ (p q)
+  "Add polynomials P and Q."
+  (cond ((endp p) q)
+	((endp q) p)
+	((= (car p) (car q))
+	 (let ((s (rat+ (cadr p) (cadr q))))
+	   (if (rat-zerop s)		;check for cancellation
+	       (ratpoly+ (cddr p) (cddr q))
+	     (append (list (car p) s)
+		     (ratpoly+ (cddr p) (cddr q))))))
+	((> (car p) (car q))
+	 (append (list (car p) (cadr p))
+		 (ratpoly+ (cddr p) q)))
+	(t (append (list (car q) (cadr q))
+		   (ratpoly+ p (cddr q))))))
+
+(defun ratpoly- (p q)
+  ;;"Subtract polynomial Q from P."
+  (cond ((endp p) (ratpoly-uminus q))
+	((endp q) p)
+	((= (car p) (car q))
+	 (let ((s (rat- (cadr p) (cadr q))))
+	   (if (rat-zerop s)		;check for cancellation
+	       (ratpoly- (cddr p) (cddr q))
+	     (append (list (car p) s)
+		     (ratpoly- (cddr p) (cddr q))))))
+	((> (car p) (car q))
+	 (append (list (car p) (cadr p))
+		 (ratpoly- (cddr p) q)))
+	(t (append (list (car q) (rat-uminus (cadr q)))
+		   (ratpoly- p (cddr q))))))
+
+(defun ratpoly-uminus (p)
+  (cond
+   ((endp p) nil)
+   (t (cons (car p) (cons (rat-uminus (cadr p)) (ratpoly-uminus (cddr p)))))))
+
+(defun ratpoly* (p q)
+  "Multiply polynomials P and 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
+	(t (append (list  (+ (car p) (car q)) (rat* (cadr p) (cadr q)))
+		   (ratpoly+ (ratpoly* (list (car p) (cadr p)) (cddr q))
+			     (ratpoly* (cddr p) q))))))
+
+(defun scalar-times-ratpoly (scalar p)
+  "Multiply scalar SCALAR by a polynomial P."
+  (cond ((endp p) nil)
+	(t (cons (car p)
+		 (cons (scalar-times-rat scalar (cadr p))
+		       (scalar-times-ratpoly scalar (cddr p)))))))
+
+(defun rat-times-ratpoly (scalar p)
+  "Multiply rational function SCALAR by a polynomial P."
+  (cond ((endp p) nil)
+	(t (cons (car p)
+		 (cons (rat* scalar (cadr p))
+		       (rat-times-ratpoly scalar (cddr p)))))))
+
+(defun ratpoly-divide (f g)
+  "Divide polynomial F by G. Return quotient and remainder as multiple values."
+  (do* ((lp nil (- (car r) (car g)))
+	(lc nil (rat/ (cadr r) (cadr g)))
+	(q nil (nconc q (list lp lc)))
+	(r f (ratpoly- (cddr r) (ratpoly* (list lp lc) (cddr g)))))
+      ((or (endp r) (< (car r) (car g)))
+       (values q r))))
+
+(defun ratpoly-remainder (f g)
+  "The remainder of the division of a polynomial F by G."
+  (second (multiple-value-list (ratpoly-divide f g))))
+
+(defun ratpoly-gcd (f g)
+  "Return GCD of polynomials F and G."
+  (do ((h f s)
+       (s g (ratpoly-remainder h s)))
+      ((endp s) h)))
+
+(defun ratpoly-diff (f)
+  "Differentiate a polynomial."
+  (cond ((endp f) nil)
+	((zerop (car f)) nil)		;degree 0
+	(t (append (list (1- (car f)) (scalar-times-rat (car f) (cadr f)))
+		   (ratpoly-diff (cddr f))))))
+
+(defun ratpoly-square-free (f)
+  "Return the square-free part of a polynomial F."
+  (ratpoly-divide f (ratpoly-gcd f (ratpoly-diff f))))
+
+(defun ratpoly-normalize (f)
+  "Divide a non-zero polynomial by the coefficient at the highest power."
+  (rat-times-ratpoly (cons (denom (cadr f)) (num (cadr f))) f))
+  
+;; A modification of Euclidean algorithm 
+(defun ratpoly-resultant (f g)
+  "Return the resultant of polynomials F and G."
+  (do* ((r nil (ratpoly-remainder h s))
+	(res (list 0 (rat-constant 1 (length (car (caaadr f)))))
+	     (rat-times-ratpoly
+	      (scalar-times-rat 
+	       (expt -1 (* (deg h) (deg s)))
+	       (rat-expt (lead s) (- (deg h) (deg r))))
+	      res))
+	(h f s)
+	(s g r))
+      ((<= (deg s) 0)
+       (cond 
+	((or (endp s) (endp h)) nil)
+	((plusp (deg h)) 
+	 (rat-times-ratpoly (rat-expt (lead s) (deg h))
+			    res))))))
+
+(defun deg (s) 
+  (cond 
+   ((endp s) 
+    #+debugging(warn "ratpoly::deg: Calculating degree of 0 polynomial")
+    -1)
+   (t (car s))))
+
+(defun lead (s) (cadr s))
+
+(defun ratpoly-discriminant (p &aux (l (deg p)))
+  "The discriminant of a polynomial P."
+  (rat-times-ratpoly 
+   (scalar-div-rat (expt -1 (mod (* l (1- l)) 2)) (lead p))
+   (ratpoly-resultant p (ratpoly-diff p))))
+
+(defun ratpoly-print (p vars &optional (stream t) (beg t) (p-orig p))
+  (when (endp p)
+    (when beg (format stream "0")) 
+    (return-from ratpoly-print p-orig))
+  (if beg (format stream "((")
+    (format stream " + (("))
+  (poly-print (caadr p) (rest vars) stream)
+  (format stream ") / (")
+  (poly-print (cdadr p) (rest vars) stream)
+  (case (car p)
+    (1  (format stream ")) * ~a" (car vars)))
+    (0  (format stream "))" (car vars)))
+    (otherwise  
+     (format stream ")) * ~a^~d" (car vars) (car p))))
+  (ratpoly-print (cddr p) vars stream nil p-orig))
+
+(defun poly-to-ratpoly (p)
+  (poly1-to-ratpoly (poly-to-poly1 p)))
+
+;; Convert a polynomial to a polynomial in k[x2,...,xn][x1]
+(defun poly-to-poly1 (p &aux (htab (make-hash-table)) q) 
+  (dolist (term p)
+    (push (cons (cdar term) (cdr term))
+	  (gethash (caar term) htab nil)))
+  (maphash #'(lambda (key val) (push (cons key val) q)) htab)
+  (mapcan #'(lambda (x &aux (deg (car x)) (coef (cdr x)))
+		      (list deg
+			    (sort-poly coef)))
+		  (sort q #'> :key #'car)))
+
+
+;; Convert poly1 to ratpoly, i.e. add denominators=1
+(defun poly1-to-ratpoly (p)
+  (unless (endp p)
+    (cons (car p) 
+	  (cons 
+	   (cons (cadr p)
+		 (list
+		  (cons (make-list (length (caaadr p)) :initial-element 0) 1)))
+	   (poly1-to-ratpoly (cddr p))))))
+
+(defun ratpoly-to-poly1 (p)
+  "Convert every coefficient of ratpoly to polynomial if possible"
+  (cond 
+   ((endp p) nil) 
+   (t (cons (car p)
+	    (cons (rat-to-poly (cadr p))
+		  (ratpoly-to-poly1 (cddr p)))))))
+  
+(defun poly1-to-poly (p)
+  "Convert a ratpoly, whose coeffs have been converted to poly,
+into a poly structure, i.e. tack in powers of first variable."
+  (cond 
+   ((endp p) nil)
+   (t
+    (append
+     (mapcar #'(lambda (x) (cons (cons (car p) (car x)) (cdr x))) (cadr p))
+     (poly1-to-poly (cddr p))))))
+
+(defun ratpoly-to-poly (p)
+  (poly1-to-poly (ratpoly-to-poly1 p)))
+  
+
+(defun poly-resultant (f g)
+  "Calculate resultant of F and G given in poly i.e. alist representation." 
+  (ratpoly-to-poly
+   (ratpoly-resultant (poly-to-ratpoly f)
+		      (poly-to-ratpoly g))))
+
+#|
+;;----------------------------------------------------------------
+;; Multi-variable GCD algorithm
+;; Roughly p. 134 of Davenport, Siret, Tournier
+;;----------------------------------------------------------------
+(defun poly-gcd (A B) 
+  (multiple-value-bind (Ap Ac)
+      (primitive-part (poly-to-poly1 A))
+    (multiple-value-bind (Bp Bc)
+	(primitive-part (poly-to-poly1 B))
+      (poly* (poly1-to-poly (primitive-part (euclid Ap Bp)))
+	     (poly1-to-poly 
+	      (list 0 
+		    (cond
+		     ((numberp Ac) (list (cons nil (gcd Ac Bc))))
+		     (t (poly-gcd Ac Bc)))))))))
+
+;; This operates on poly1
+(defun content1 (A)
+  (cond 
+    ((endp A) (error "content1: Content of 0 is not defined."))
+    ((endp (caaadr A))			;1-variable poly
+     (content1-aux A))			;a number
+    ((endp (cddr A)) (cadr A))
+    (t (poly-gcd (cadr A) (content1 (cddr A))))))
+
+;; 1-variable case
+(defun content1-aux (A)
+  (cond ((endp A) (error "content1-aux: Content of 0 is not defined."))
+	((endp (cddr A)) (cdaadr A))
+	(t (gcd (cdaadr A) (content1-aux (cddr A))))))
+
+;; operates on poly
+(defun content (A &aux (A1 (poly-to-poly1 A)))
+  (content1 A1))
+       
+;; Operates on poly1
+(defun primitive-part (A)
+  (let ((Ac (content1 A)))
+    (values (divide-coeffs A Ac) Ac)))
+
+;; Operates on A in poly1 form and A in poly form of 1 variable less
+(defun divide-coeffs (A Ac)
+  (cond 
+    ((endp A) nil)
+    ((numberp Ac)		;ground case
+     (cons (car A) 
+	     (cons (list (cons nil (floor (cdaadr A) Ac)))
+		   (divide-coeffs (cddr A) Ac))))
+    (t (cons (car A) 
+	     (cons 
+	      (multiple-value-bind (q r)
+		  (divide (cadr A) (list Ac))
+		(unless (endp r) (error "divide-coeffs: not divisible."))
+		(car q))
+	      (divide-coeffs (cddr A) Ac))))))
+
+;; Euclid operates on poly1
+(defun euclid (A B)
+  (ratpoly-to-poly1 (ratpoly-gcd (poly1-to-ratpoly A)
+				 (poly1-to-ratpoly B))))
+
+|#
+
Index: /trunk/src/semantic.cache
===================================================================
--- /trunk/src/semantic.cache	(revision 14)
+++ /trunk/src/semantic.cache	(revision 14)
@@ -0,0 +1,15 @@
+;; Object src/
+;; SEMANTICDB Tags save file
+(semanticdb-project-database-file "src/"
+  :tables (list 
+   (semanticdb-table "grobner.lisp"
+    :major-mode 'lisp-mode
+    :tags '(("C" code nil nil [229 232]) ("e-mail:" code nil nil [253 287]) ("defpackage" code nil nil [691 1563]) ("in-package" code nil nil [1565 1587]) ("eval-when" code nil nil [1589 1732]) ("*grobner-debug*" variable nil nil [1742 1818]) ("*buchberger-merge-pairs*" variable (:default-value (quote buchberger-merge-pairs-smallest-lcm)) nil [1820 2021]) ("*gebauer-moeller-merge-pairs*" variable (:default-value (quote gebauer-moeller-merge-pairs-use-mock-spoly)) nil [2023 2240]) ("*grobner-function*" variable (:default-value (quote buchberger)) nil [2242 2342]) ("select-grobner-algorithm" function (:arguments ("algorithm")) nil [2344 2790]) ("eval-when" code nil nil [2792 2844]) ("grobner" function (:arguments ("F" "&optional" "pred" "start" "top-reduction-only" "ring")) nil [2846 3956]) ("debug-cgb" function (:arguments ("&rest" "args")) nil [3967 4320]) ("spoly" function (:arguments ("f" "g" "pred" "ring")) nil [4322 4955]) ("eval-when" code nil nil [4957 5040]) ("grobner-primitive-part" function (:arguments ("p" "ring")) nil [5043 5502]) ("grobner-content" function (:arguments ("p" "ring")) nil [5505 5863]) ("grobner-op" function (:arguments ("c1" "c2" "m" "A" "B" "pred" "ring" "&aux" "n" "A1" "A2")) nil [9780 11423]) ("eval-when" code nil nil [11568 11634]) ("buchberger-sort-pairs" function (:arguments ("B" "G" "pred" "ring")) nil [11636 12044]) ("mock-spoly" function (:arguments ("f" "g" "pred")) nil [12047 12599]) ("eval-when" code nil nil [12601 12783]) ("buchberger-merge-pairs-use-mock-spoly" function (:arguments ("B" "C" "G" "pred" "ring")) nil [12980 13822]) ("buchberger-merge-pairs-smallest-lcm" function (:arguments ("B" "C" "G" "pred" "ring")) nil [14078 14611]) ("buchberger-merge-pairs-use-smallest-degree" function (:arguments ("B" "C" "G" "pred" "ring")) nil [14852 15321]) ("buchberger-merge-pairs-use-smallest-length" function (:arguments ("B" "C" "G" "pred" "ring")) nil [15323 15781]) ("buchberger-merge-pairs-use-smallest-coefficient-length" function (:arguments ("B" "C" "G" "pred" "ring")) nil [15783 16360]) ("buchberger-set-pair-heuristic" function (:arguments ("method" "&aux" "strategy-fn")) nil [16362 17074]) ("eval-when" code nil nil [17230 17298]) ("Criterion-1" function (:arguments ("pair" "G" "&aux" "i" "j")) nil [17300 17623]) ("normalize-poly" function (:arguments ("p" "ring")) nil [18602 19014]) ("normalize-basis" function (:arguments ("plist" "ring")) nil [19016 19244]) ("reduction" function (:arguments ("P" "pred" "ring")) nil [19246 19918]) ("reduced-grobner" function (:arguments ("F" "&optional" "pred" "start" "top-reduction-only" "ring")) nil [19921 20339]) ("*vars*" variable nil nil [20347 20411]) ("eval-when" code nil nil [20413 20503]) ("monom-depends-p" function (:arguments ("m" "k")) nil [20549 20659]) ("term-depends-p" function (:arguments ("term" "k")) nil [20699 20823]) ("poly-depends-p" function (:arguments ("p" "k")) nil [20871 21020]) ("ring-intersection" function (:arguments ("plist" "k" "&key" "key")) nil [21022 21421]) ("elimination-ideal" function (:arguments ("flist" "k" "&key" "primary-order" "secondary-order" "start" "order" "top-reduction-only" "ring")) nil [21423 22566]) ("ideal-intersection" function (:arguments ("F" "G" "pred" "top-reduction-only" "ring")) nil [22569 23510]) ("poly-contract" function (:arguments ("f" "&optional" "k")) nil [23513 24119]) ("poly-lcm" function (:arguments ("f" "g" "&optional" "pred" "ring")) nil [24122 24925]) ("grobner-gcd" function (:arguments ("f" "g" "&optional" "pred" "ring")) nil [24974 25383]) ("grobner-equal" function (:arguments ("g1" "g2" "&optional" "pred" "ring")) nil [25431 25720]) ("grobner-subsetp" function (:arguments ("g1" "g2" "&optional" "pred" "ring")) nil [25722 26049]) ("grobner-member" function (:arguments ("p" "g" "&optional" "pred" "ring")) nil [26051 26334]) ("ideal-equal" function (:arguments ("f1" "f2" "pred" "top-reduction-only" "ring")) nil [26336 26620]) ("ideal-subsetp" function (:arguments ("f1" "f2" "&optional" "pred" "ring")) nil [26622 26943]) ("ideal-member" function (:arguments ("p" "plist" "pred" "top-reduction-only" "ring")) nil [26945 27221]) ("ideal-saturation-1" function (:arguments ("F" "p" "pred" "start" "top-reduction-only" "ring" "&aux" "pred")) nil [27246 27964]) ("add-variables" function (:arguments ("plist" "n")) nil [27967 28310]) ("extend-polynomials" function (:arguments ("plist" "&aux" "k")) nil [28349 29190]) ("saturation-extension" function (:arguments ("F" "plist" "ring" "&aux" "k" "d")) nil [29238 30132]) ("polysaturation-extension" function (:arguments ("F" "plist" "ring" "&aux" "k" "d")) nil [30176 31070]) ("saturation-extension-1" function (:arguments ("F" "p" "ring")) nil [31072 31390]) ("ideal-polysaturation-1" function (:arguments ("F" "plist" "pred" "start" "top-reduction-only" "ring")) nil [31440 31964]) ("ideal-saturation" function (:arguments ("F" "G" "pred" "start" "top-reduction-only" "ring" "&aux" "k" "pred")) nil [31966 32845]) ("ideal-polysaturation" function (:arguments ("F" "ideal-list" "pred" "start" "top-reduction-only" "ring")) nil [32847 33301]) ("buchberger-criterion" function (:arguments ("G" "pred" "ring")) nil [33303 33673]) ("minimization" function (:arguments ("P" "pred")) nil [34249 34796]) ("add-minimized" function (:arguments ("f" "Gred" "pred")) nil [34799 35159]) ("colon-ideal" function (:arguments ("F" "G" "pred" "top-reduction-only" "ring")) nil [35161 35907]) ("colon-ideal-1" function (:arguments ("F" "g" "pred" "top-reduction-only" "ring")) nil [35909 36217]) ("update" function (:arguments ("G" "B" "h" "pred" "ring" "&aux" "C" "D" "E" "B-new" "G-new" "pair")) nil [39696 41320]) ("gebauer-moeller-merge-pairs-use-mock-spoly" function (:arguments ("B" "C" "pred" "ring")) nil [41328 41892]) ("gebauer-moeller-merge-pairs-smallest-lcm" function (:arguments ("B" "C" "pred" "ring")) nil [41894 42342]) ("gebauer-moeller-merge-pairs-use-smallest-degree" function (:arguments ("B" "C" "pred" "ring")) nil [42345 42800]) ("gebauer-moeller-merge-pairs-use-smallest-length" function (:arguments ("B" "C" "pred" "ring")) nil [42803 43291]) ("gebauer-moeller-merge-pairs-use-smallest-coefficient-length" function (:arguments ("B" "C" "pred" "ring")) nil [43294 43850]) ("gebauer-moeller-set-pair-heuristic" function (:arguments ("method" "&aux" "strategy-fn")) nil [43852 44392]) ("spoly-sugar" function (:arguments ("f-with-sugar" "g-with-sugar" "ring")) nil [44692 45992]) ("spoly-with-sugar" function (:arguments ("f-with-sugar" "g-with-sugar" "pred" "ring")) nil [46046 46721]) ("buchberger-with-sugar-merge-pairs" function (:arguments ("B" "C" "G" "M" "pred" "ring")) nil [51290 52547]) ("buchberger-with-sugar-sort-pairs" function (:arguments ("C" "G" "M" "pred" "ring")) nil [52549 52722]) ("eval-when" code nil nil [52724 52814]) ("Criterion-1-with-sugar" function (:arguments ("pair" "G" "&aux" "i" "j")) nil [52816 53114]) ("update-with-sugar" function (:arguments ("G" "B" "h" "pred" "ring" "&aux" "C" "D" "E" "B-new" "G-new" "pair")) nil [55825 57944]) ("gebauer-moeller-with-sugar-merge-pairs" function (:arguments ("B" "C" "pred" "ring")) nil [57946 58807]) ("grobner-primitive-part-with-sugar" function (:arguments ("h" "ring")) nil [58809 58914]) ("cached-grobner-op" function (:arguments ("c1" "c2" "m" "A" "B" "pred" "ring" "cache")) nil [60652 61023]) ("cached-spoly" function (:arguments ("f" "g" "pred" "ring" "cache-f" "cache-g")) nil [62986 63569]) ("cached-poly-with-sugar-op" function (:arguments ("f" "c" "m" "g" "pred" "ring" "Cache")) nil [69016 69193]) ("cached-monom-times-poly-with-sugar" function (:arguments ("m" "f" "Cache")) nil [69195 69369]))
+    :file "grobner.lisp"
+    :pointmax 69370
+    )
+   )
+  :file "semantic.cache"
+  :semantic-tag-version "2.0beta3"
+  :semanticdb-version "2.0beta3"
+  )
Index: /trunk/src/string-grobner.lisp
===================================================================
--- /trunk/src/string-grobner.lisp	(revision 14)
+++ /trunk/src/string-grobner.lisp	(revision 14)
@@ -0,0 +1,260 @@
+;;; -*- Mode: Common-Lisp; Package: String-Grobner; Base: 10 -*-
+#|
+	$Id: string-grobner.lisp,v 1.3 2009/01/22 04:07:58 marek Exp $
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+
+(defpackage "STRING-GROBNER"
+  (:export
+   string-normal-form
+   string-grobner	
+   string-colon-ideal	
+   string-ideal-polysaturation-1
+   string-ideal-saturation-1
+   string-ideal-polysaturation
+   string-ideal-saturation
+   string-poly-lcm
+   string-ideal-intersection
+   string-elimination-ideal
+   string-read-poly)
+ (:use "ORDER" "MONOM" "PARSE" "PRINTER" "GROBNER" "TERM" "POLY"
+	       "COEFFICIENT-RING" "COMMON-LISP"))
+
+(in-package "STRING-GROBNER")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(defun string-normal-form (f fl vars
+			   &key
+			   (stream t)
+			   (print t)
+			   (order #'lex>)
+			   (top-reduction-only nil)
+			   (ring *coefficient-ring*)
+			   (suppress-value t)
+			   &aux (vars (read-vars vars)))
+  (let ((f (parse-string-to-sorted-alist f vars order))
+	(fl (parse-string-to-sorted-alist fl vars order)))
+    (format stream "~&Args:")
+    (poly-print fl vars stream)
+    (let ((nf (normal-form (copy-tree f) (rest fl) order top-reduction-only ring)))
+      (terpri stream)
+      (when print
+	(poly-print
+	 nf
+	 vars
+	 stream))
+      (if suppress-value (values) nf))))
+
+(defun string-grobner (plist vars
+		       &key (order #'lex>)
+			    (start 0)
+			    (stream t)
+			    (reduce t)
+			    (reduce-before t)
+			    (suppress-value t)
+			    (top-reduction-only nil)
+			    (ring *coefficient-ring*)
+			    (print t)
+		       &aux (vars (read-vars vars)))
+  ;; Turn on some phancy tracing to see the action better
+  (let ((grobner-fun
+	 (if reduce #'reduced-grobner #'grobner))
+	(plist (parse-string-to-sorted-alist plist vars order)))
+    (format stream "~&Args:")
+    (poly-print plist vars stream)
+    (setf plist (rest plist))
+    (when reduce-before (setf plist (reduction plist order ring)))
+    (let ((gb (funcall grobner-fun plist order start top-reduction-only ring)))
+      (terpri stream)
+      (when print
+	(poly-print
+	 (cons '[ gb)
+	 vars
+	 stream))
+      (if suppress-value (values) gb))))
+
+(defun string-elimination-ideal (flist vars k
+				 &key (stream t)
+				      (key #'identity)
+				      (primary-order #'grevlex>)
+				      (secondary-order #'grevlex>)
+				      (suppress-value t)
+				      (order (elimination-order
+					      k
+					      :primary-order primary-order
+					      :secondary-order secondary-order
+					      ))
+				 &aux (vars (read-vars vars)))
+  (let ((id (ring-intersection
+	     (string-grobner flist vars
+			     :order order
+			     :suppress-value nil
+			     :stream stream
+			     :print nil)
+	     k :key key)))
+    (poly-print (cons '[ id) vars stream)
+    (if suppress-value (values) id)))
+
+
+(defun string-ideal-intersection (f g vars
+				  &key (order #'lex>)
+				       (top-reduction-only nil)
+				       (ring *coefficient-ring*)
+				       (stream t)
+				       (suppress-value t)
+				  &aux (vars (read-vars vars))
+				       (f (parse-string-to-sorted-alist
+					   f vars order))
+				       (g (parse-string-to-sorted-alist
+					   g vars order)))
+  (let ((id (ideal-intersection (rest f) (rest g) order top-reduction-only ring)))
+    (poly-print (cons '[ id) vars stream)
+    (if suppress-value (values) id)))
+
+(defun string-poly-lcm (f g vars
+			&key (order #'lex>)
+			     (ring *coefficient-ring*)
+			     (stream t)
+			     (suppress-value t)
+			&aux (vars (read-vars vars))
+			     (f (parse-string-to-sorted-alist
+				 f vars order))
+			     (g (parse-string-to-sorted-alist
+				 g vars order)))
+  (let ((lcm (poly-lcm f g order ring)))
+    (poly-print lcm vars stream)
+    (if suppress-value (values) lcm)))
+
+(defun string-ideal-saturation-1 (F p vars
+				  &key (order #'lex>) (start 0)
+				       (top-reduction-only nil)
+				       (ring *coefficient-ring*)
+				       (stream t)
+				       (suppress-value t)
+				  &aux (vars (read-vars vars))
+				       (F (parse-string-to-sorted-alist
+					   F vars order))
+				       (p (parse-string-to-sorted-alist
+					   p vars order)))
+  (let ((id (ideal-saturation-1 (rest F) p order start top-reduction-only ring)))
+    (poly-print (cons '[ id) vars stream)
+    (if suppress-value (values) id)))
+
+(defun string-ideal-polysaturation-1 (F plist vars
+				      &key (order #'lex>) (start 0)
+					   (top-reduction-only nil)
+					   (ring *coefficient-ring*)
+					   (stream t)
+					   (suppress-value t)
+				      &aux (vars (read-vars vars))
+					   (F (parse-string-to-sorted-alist
+					       F vars order))
+					   (plist (parse-string-to-sorted-alist
+						   plist vars order)))
+  (format stream "~&Args1:")
+  (poly-print F vars stream)
+  (format stream "~&Args2:")
+  (poly-print plist vars stream)
+  (terpri stream)
+  (let ((id (ideal-polysaturation-1 (rest F) (rest plist) order start top-reduction-only ring)))
+    (poly-print (cons '[ id) vars stream)
+    (if suppress-value (values) id)))
+
+(defun string-ideal-saturation (F G vars
+				&key (order #'lex>) (start 0)
+				     (top-reduction-only nil)
+				     (ring *coefficient-ring*)
+				     (stream t)
+				     (suppress-value t)
+				&aux (vars (read-vars vars))
+				     (F (parse-string-to-sorted-alist
+					 F vars order))
+				     (G (parse-string-to-sorted-alist
+					 G vars order)))
+  (let ((id (ideal-saturation (rest F) (rest G) order start top-reduction-only ring)))
+    (poly-print (cons '[ id) vars stream)
+    (if suppress-value (values) id)))
+
+(defun string-ideal-polysaturation (F ideal-list vars
+				    &key (order #'lex>) (start 0)
+					 (top-reduction-only nil)
+					 (ring *coefficient-ring*)
+					 (stream t)
+					 (suppress-value t)
+				    &aux (vars (read-vars vars))
+					 (F (parse-string-to-sorted-alist
+					     F vars order))
+					 (ideal-list
+					  (mapcar #'(lambda (G) (parse-string-to-sorted-alist
+								 G vars order))
+						  ideal-list)))
+  (format stream "~&Args1:")
+  (poly-print F vars stream)
+  (format stream "~&Args2:")
+  (dolist (G ideal-list)
+    (poly-print G vars stream))
+  (terpri stream)
+  (let ((id (ideal-polysaturation (rest F) (mapcar #'rest ideal-list) order start top-reduction-only ring)))
+    (poly-print (cons '[ id) vars stream)
+    (if suppress-value (values) id)))
+
+
+
+(defun string-colon-ideal (F G vars
+			   &key (top-reduction-only nil)
+				(ring *coefficient-ring*)
+				(stream t)
+				(order #'lex>)
+				(suppress-value t)
+			   &aux (vars (read-vars vars))
+				(F (parse-string-to-sorted-alist
+				    F vars order))
+				(G (parse-string-to-sorted-alist
+				    G vars order)))
+  (format stream "~&Args1:")
+  (poly-print F vars stream)
+  (format stream "~&Args2:")
+  (poly-print G vars stream)
+  (let ((id (colon-ideal (rest F) (rest G) order top-reduction-only ring)))
+    (poly-print (cons '[ id) vars stream)
+    (if suppress-value (values) id)))
+
+;;----------------------------------------------------------------
+;; An enhanced polynomial reader
+;;----------------------------------------------------------------
+(defun string-read-poly (F vars
+			 &key (order #'lex>)
+			      (suppress-value nil)
+			      (stream t)
+			      (convert-rational-to-integer t)
+			 &aux (vars (read-vars vars))
+			      (F (parse-string-to-sorted-alist F vars order)))
+  (when convert-rational-to-integer
+    (if (eq (car F) '[)
+	(setf F (cons (car F) (mapcar #'poly-rational-to-integer (rest F))))
+      (setf F (poly-rational-to-integer F))))
+  (format stream "~&Args:")
+  (poly-print F vars stream)
+  (terpri stream)
+  (if suppress-value (values) F))
+
+
+;; Multiply by lcm of denominators of coefficients
+(defun poly-rational-to-integer (p &optional (ring *coefficient-ring*))
+  (let ((c (apply (ring-lcm ring) (mapcar (ring-denominator ring) (mapcar #'cdr p)))))
+    (scalar-times-poly c p ring)))
+
+(defun read-vars (string-or-list)
+  "Read a list of variables, specified either as a list of symbols or a string
+listing variables in the form of a comma-separated list, delimited by [,]"
+  (typecase string-or-list
+    (list string-or-list)
+    (string (with-input-from-string (s string-or-list) (rest (parse s))))))
Index: /trunk/src/svpoly.lisp
===================================================================
--- /trunk/src/svpoly.lisp	(revision 14)
+++ /trunk/src/svpoly.lisp	(revision 14)
@@ -0,0 +1,258 @@
+#|
+	$Id: svpoly.lisp,v 1.4 2009/01/23 10:37:28 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+(defpackage "SVPOLY"
+  (:export))
+
+(in-package "SVPOLY")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(defstruct (svpoly (:constructor make-svpoly-raw))
+  (nvars "Number of variables." (:type fixnum))
+  (coefficient-type "Type of the coefficient.")
+  (order "Monomial order.")
+  (terms "The array of terms."))
+
+(defun make-svpoly (alist order
+		    &aux (nterms (length alist))
+			 (nvars (length (caar alist)))
+			 (coefficient-type (type-of (cdar alist))))
+  "Construct svpolynomial from ALIST."
+  (let ((svp (make-svpoly-raw
+	      :nvars nvars
+	      :coefficient-type (type-of (cdar alist))
+	      :order order
+	      :terms (make-array nterms :element-type 'cons))))
+    (dotimes (i nterms)
+      (let ((term (nth i alist)))
+	(setf (svref (svpoly-terms svp) i)
+	  (cons (make-array nvars :initial-contents (car term))
+		(cdr term)))))
+    (svpoly-sort svp)))
+
+(defun svpoly-sort (svp)
+  "Destructively sorts an sv-polynomial SVP."
+  (setf (svpoly-terms svp) (sort (svpoly-terms svp) (svpoly-order svp) :key #'car)) svp)
+
+(defun make-order (nvars order)
+  "Returns an order function with two parameters P and Q such that if called
+on a pair of monomials with exactly NVARS variables, this function
+will return T if P is greater than Q and NIL otherwise. The keyword
+ORDER indicates one of several standard orders (:LEX, etc)."
+  (declare (fixnum nvars))
+  (ecase order
+    (:lex #'(lambda (p q)
+	      (dotimes (i nvars (values NIL T))
+		(declare (fixnum i))
+		(cond
+		 ((> (svref p i) (svref q i)) 
+		  (return (values t nil)))
+		 ((< (svref p i) (svref q i))
+		  (return (values nil nil)))))))))
+
+(defun svpoly-add (p q)
+  "Adds polynomials P and Q, where P and Q are assumed to be ordered
+by the same monomial order. Destructive to P and Q."
+  (setf (svpoly-terms p) (add-terms (svpoly-terms p) (svpoly-terms q)
+				    (svpoly-order p)))
+  p)
+
+(defun add-terms (p q pred &aux (lp (length p)) (lq (length q)))
+  (do ((r (make-array (+ lp lq)  :element-type 'cons))
+       (i 0) (j 0) (k 0) done)
+      (done (coerce (adjust-array r k) 'simple-vector))
+    (cond 
+     ((= i lp)
+      (do nil
+	  ((>= j lq) (setf done t))
+	(setf (aref r k) (svref q j))
+	(incf j) (incf k)))
+     ((= j lq)
+      (do nil
+	  ((>= i lp) (setf done t))
+	(setf (aref r k) (svref p i))
+	(incf i) (incf k))) 
+     (t
+      (multiple-value-bind 
+	  (mgreater mequal)
+	  (funcall pred (car (svref p i)) (car (svref q j)))
+	(cond
+	 (mequal
+	  (let ((s (+ (cdr (svref p i)) (cdr (svref q j)))))
+	    (unless (zerop s)		;check for cancellation
+	      (setf (aref r k) (cons (car (svref p i)) s))
+	      (incf k))
+	    (incf i)
+	    (incf j)))
+	 (mgreater
+	  (setf (aref r k) (svref p i))
+	  (incf i)
+	  (incf k))
+	 (t
+	  (setf (aref r k) (svref q j))
+	  (incf j) 
+	  (incf k))))))))
+
+#|
+
+(defun scalar-times-poly (c p)
+  "Return product of a scalar C by a polynomial P with coefficient ring RING."
+  (unless (funcall (ring-zerop ring) c)
+    (mapcar
+     #'(lambda (term) (cons (car term) (funcall (ring-* ring) c (cdr term))))
+     p)))
+
+(defun term-times-poly (term f &optional (ring *coefficient-ring*))
+  "Return product of a term TERM by a polynomial F with coefficient ring RING."
+  (mapcar #'(lambda (x) (term* term x ring)) f))
+
+(defun monom-times-poly (m f)
+  "Return product of a monomial M by a polynomial F with coefficient ring RING."
+  (mapcar #'(lambda (x) (monom-times-term m x)) f))
+
+(defun minus-poly (f &optional (ring *coefficient-ring*))
+  "Changes the sign of a polynomial F with coefficients in coefficient ring
+RING, and returns the result."
+  (mapcar #'(lambda (x) (cons (car x) (funcall (ring-- ring) (cdr x)))) f))
+
+
+(defun poly+ (p q &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Returns the sum of two polynomials P and Q with coefficients in
+ring RING, with terms ordered according to monomial order PRED."
+  (do (r done)
+      (done r)
+    (cond 
+      ((endp p) (setf r (append (nreverse r) q) done t))
+      ((endp q) (setf r (append (nreverse r) p) done t))
+      (t 
+       (multiple-value-bind 
+	     (mgreater mequal)
+	   (funcall pred (caar p) (caar q))
+	 (cond
+	   (mequal
+	    (let ((s (funcall (ring-+ ring) (cdar p) (cdar q))))
+	      (unless (funcall (ring-zerop ring) s)		;check for cancellation
+		      (setf r (cons (cons (caar p) s) r)))
+	      (setf p (cdr p) q (cdr q))))
+	   (mgreater
+	    (setf r (cons (car p) r)
+		  p (cdr p)))
+	   (t (setf r (cons (car q) r)
+		    q (cdr q)))))))))
+
+(defun poly- (p q &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Returns the difference of two polynomials P and Q with coefficients
+in ring RING, with terms ordered according to monomial order PRED."
+  (do (r done)
+      (done r)
+    (cond 
+      ((endp p) (setf r (append (nreverse r) (minus-poly q ring)) done t))
+      ((endp q) (setf r (append (nreverse r) p) done t))
+      (t 
+       (multiple-value-bind 
+	     (mgreater mequal)
+	   (funcall pred (caar p) (caar q))
+	 (cond
+	   (mequal
+	    (let ((s (funcall (ring-- ring) (cdar p) (cdar q))))
+	      (unless (zerop s)		;check for cancellation
+		(setf r (cons (cons (caar p) s) r)))
+	      (setf p (cdr p) q (cdr q))))
+	   (mgreater
+	    (setf r (cons (car p) r)
+		  p (cdr p)))
+	   (t (setf r (cons (cons (caar q) (funcall (ring-- ring) (cdar q))) r)
+		    q (cdr q)))))))))
+
+;; Multiplication of polynomials
+;; Non-destructive version
+(defun poly* (p q &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Returns the product of two polynomials P and Q with coefficients in
+ring RING, with terms ordered according to monomial order PRED."
+  (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
+	(t (cons (cons  (monom* (caar p) (caar q))
+			(funcall (ring-* ring) (cdar p) (cdar q)))
+		   (poly+ (term-times-poly (car p) (cdr q) ring)
+			  (poly* (cdr p) q pred ring)
+			  pred ring)))))
+
+(defun poly-op (f m g pred ring)
+  "Returns F-M*G, where F and G are polynomials with coefficients in
+ring RING, ordered according to monomial order PRED and M is a
+monomial."
+  (poly- f (term-times-poly m g ring) pred ring))
+
+(defun poly-expt (poly n &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Exponentiate a polynomial POLY to power N. The terms of the
+polynomial are assumed to be ordered by monomial order PRED and with
+coefficients in ring RING.  Use the Chinese algorithm; assume N>=0 and
+POLY is non-zero (not NIL)."
+  (labels ((poly-one ()
+	     (list
+	      (cons (make-list (length (caar poly)) :initial-element 0) (ring-unit ring)))))
+    (cond
+     ((minusp n) (error "Negative exponent."))
+     ((endp poly) (if (zerop n) (poly-one) nil))
+     (t
+      (do ((k 1 (ash k 1))
+	   (q poly (poly* q q pred ring))	;keep squaring
+	   (p (poly-one) (if (not (zerop (logand k n))) (poly* p q pred ring) p)))
+	  ((> k n) p))))))
+
+(defun poly-mexpt (plist monom &optional (pred #'lex>) (ring *coefficient-ring*))
+  "Raise a polynomial vector represented ad a list of polynomials
+PLIST to power MULTIINDEX.  Every polynomial has its terms ordered by
+predicate PRED and coefficients in the ring RING."
+  (reduce 
+   #'(lambda (u v) (poly* u v pred ring))
+   (mapcan #'(lambda (y i)
+	       (cond ((endp y) (if (zerop i) nil (list nil)))
+		     (t (list (poly-expt y i pred ring)))))
+	   plist monom)))
+
+(defun poly-constant-p (p)
+  "Returns T if P is a constant polynomial."
+  (and (= (length p) 1)
+       (every #'zerop (caar p))))
+
+       
+(defun	poly-extend (p &optional (m (list 0)))
+  "Given a polynomial P in k[x[r+1],...,xn], it returns the same
+polynomial as an element of k[x1,...,xn], optionally multiplying it by
+a monomial x1^m1*x2^m2*...*xr^mr, where m=(m1,m2,...,mr) is a
+multiindex."
+  (mapcar #'(lambda (term) (cons (append m (car term)) (cdr term))) p))
+
+(defun	poly-extend-end (p &optional (m (list 0)))
+  "Similar to POLY-EXTEND, but it adds new variables at the end."
+  (mapcar #'(lambda (term) (cons (append (car term) m) (cdr term))) p))
+
+(defun poly-zerop (p)
+  "Returns T if P is a zero polynomial."
+  (null p))
+
+(defun lt (p)
+  "Returns the leading term of a polynomial P."
+  #+debugging(assert (consp p))
+  (first p))
+
+(defun lm (p)
+  "Returns the leading monomial of a polynomial P."
+  #+debugging(assert (consp (lt p)))
+  (car (lt p)))
+
+(defun lc (p)
+  "Returns the leading coefficient of a polynomial P."
+  #+debugging(assert (consp (lt p)))
+  (cdr (lt p)))
+
+|#
Index: /trunk/src/term.lisp
===================================================================
--- /trunk/src/term.lisp	(revision 14)
+++ /trunk/src/term.lisp	(revision 14)
@@ -0,0 +1,63 @@
+#|
+	$Id: term.lisp,v 1.4 2009/01/22 04:08:39 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+(defpackage "TERM"
+  (:use "MONOM" "COEFFICIENT-RING" "COMMON-LISP")
+  (:export term-divides-p  term*  term/ term-coefficient term-monom monom-times-term))
+
+(in-package "TERM")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+;;----------------------------------------------------------------
+;; Basic operations on terms
+;;----------------------------------------------------------------
+;; THE REPRESENTATION: Terms are cons cells consisting
+;; of a monom and coefficient
+;;
+;;	term:		(monom . coefficient)
+;;
+;;----------------------------------------------------------------
+;; EXAMPLES: Suppose that variables are x and y. Then
+;; Term  3*x*y^2 ---> ((1 2) . 3) 
+;;----------------------------------------------------------------
+
+;; Multiplication of terms
+(defun term* (term1 term2 &optional (ring *coefficient-ring*))
+  (cons 
+   (monom* (car term1) (car term2))
+   (funcall (ring-* ring) (cdr term1) (cdr term2))))
+
+;;;; Division of terms
+(defun term/ (term1 term2 &optional (ring *coefficient-ring*))
+  (cons 
+   (monom/ (car term1) (car term2))
+   (funcall (ring-/ ring) (cdr term1) (cdr term2))))
+
+;; Multiply monomial by term
+(defun monom-times-term (m term)
+  (cons (monom* m (car term)) (cdr term)))
+
+;; Whether a term divides another term
+(defun term-divides-p (term1 term2)
+  (monom-divides-p (car term1) (car term2)))
+
+;; Accessor functions
+(defmacro term-monom (term) `(car ,term))
+(defmacro term-coefficient (term) `(cdr ,term))
+
+;; Setf methods
+(defsetf term-monom (term) (monom)
+  `(setf (car ,term) ,monom))
+
+(defsetf term-coefficient (term) (coefficient)
+  `(setf (cdr ,term) ,coefficient))
+
Index: /trunk/src/trivial.lisp
===================================================================
--- /trunk/src/trivial.lisp	(revision 14)
+++ /trunk/src/trivial.lisp	(revision 14)
@@ -0,0 +1,29 @@
+#|
+	$Id: trivial.lisp,v 1.1 2009/01/19 08:51:43 marek Exp $
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+(defpackage "TRIVIAL"
+  (:export trivial-p))
+(in-package "TRIVIAL")
+
+;; This package develops Kronecker-like algorithm to test
+;; that 1 is in the ideal <f1,f2,...,fn> where fi are polynomial expressions
+;; given in lisp (prefix notation)
+
+;;Suppose we have a function f taking values f0, f1, ... , fn at
+;;points x0, x1, ... , xn and we want a function which will take a value
+;;f(n+1) at x(n+1); what is the formula?
+;;(x-x(n+1))*f(x)+f(n+1)
+
+  
+
+
+
+
Index: /trunk/src/xgcd.lisp
===================================================================
--- /trunk/src/xgcd.lisp	(revision 14)
+++ /trunk/src/xgcd.lisp	(revision 14)
@@ -0,0 +1,37 @@
+#|
+	$Id: xgcd.lisp,v 1.4 2009/01/22 04:09:05 marek Exp $
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+(defpackage "XGCD"
+  (:use "COMMON-LISP")
+  (:export xgcd))
+(in-package "XGCD")
+
+(proclaim '(optimize (speed 0) (debug 3)))
+
+(defun xgcd (X Y)
+  "Extended gcd; the call
+      (xgcd X Y)
+returns a multiple value list:
+- GCD
+- U,V  such that they solve the equation
+     GCD=U*X+V*Y
+- U1,V1 such that
+     LCM=U1*X=V1*Y (up to the sign)."
+  (labels ((xgcd-aux (x0 x1 u0 v0 u1 v1)
+	     (cond 
+	      ((= x1 0) (values x0 u0 v0 u1 v1))
+	      (t (multiple-value-bind (n x2) (floor x0 x1)
+		   (let ((u2 (- u0 (* n u1)))
+			 (v2 (- v0 (* n v1))))
+		     (xgcd-aux x1 x2 u1 v1 u2 v2)))))))
+    (xgcd-aux X Y 1 0 0 1)))
+
+
Index: /trunk/tests/TAGS
===================================================================
--- /trunk/tests/TAGS	(revision 14)
+++ /trunk/tests/TAGS	(revision 14)
@@ -0,0 +1,34 @@
+
+
+colored-poly-tests.lisp,0
+
+
+cox-tests.lisp,222
+(defun run 15,715
+(defun test-1 18,814
+(defun test-2 31,1169
+(defun test-3 46,1657
+(defun test-4 63,2350
+(defun test-5 70,2571
+(defun test-6 121,5866
+(defun run-short-tests 129,6119
+(defun run-long-tests 133,6204
+
+
+grobner-tests.lisp,33
+(defun run-grobner-test 25,1066
+
+
+ratpoly-tests.lisp,0
+
+
+tests.lisp,222
+(defun run 14,649
+(defun test-1 17,748
+(defun test-2 30,1103
+(defun test-3 45,1591
+(defun test-4 62,2284
+(defun test-5 69,2505
+(defun test-6 120,5800
+(defun run-short-tests 128,6053
+(defun run-long-tests 132,6138
Index: /trunk/tests/colored-poly-tests.lisp
===================================================================
--- /trunk/tests/colored-poly-tests.lisp	(revision 14)
+++ /trunk/tests/colored-poly-tests.lisp	(revision 14)
@@ -0,0 +1,134 @@
+#|
+	$Id$	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+;;(use-package '("parse" "monom" "printer" "colored-poly" "grobner" "coefficient-ring"))
+
+;; The value of this variable is a function that will do evaluation
+;; instead of eval; this one just prints what it is evaluating and calls eval
+
+(dribble "colored-poly-tests.output")
+
+
+#|
+(warn "Test 1")
+(setf f (parse-string-to-sorted-alist "4*x^2-3*x*y" '(x y)))
+(setf g (parse-string-to-sorted-alist "4*x+5*y" '(x y)))
+(setf cf (make-colored-poly f 2))
+(setf cg (make-colored-poly g 2))
+(time (cond-system-print (grobner-system (list cf cg)) '(x y) '()))
+(time (poly-print (cons '[ (grobner (list f g))) '(x y)))
+
+(warn" Test 2 - Enneper surface")
+(setf fl 
+      (cdr
+       (parse-string-to-sorted-alist
+	"[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
+	'(u v x y z))))
+(setf cfl (make-colored-poly-list fl 5))
+(time (cond-system-print (grobner-system cfl) '(u v x y z) '()))
+(time (poly-print (cons '[ (reduced-grobner fl)) '(u v x y z)))
+
+(warn" Test 3 - staple")
+(setf fl 
+      (cdr (parse-string-to-sorted-alist
+	    "[x+y,x+u*y]"
+	    '(x y u))))
+(setf cfl (make-colored-poly-list fl 2))
+(time (cond-system-print (grobner-system cfl) '(x y) '(u)))
+
+(warn" Test 4 - staple")
+(setf fl 
+      (cdr
+       (parse-string-to-sorted-alist
+	"[x+y,u*x+y]"
+	'(x y u))))
+(setf cfl (make-colored-poly-list fl 2))
+(time (cond-system-print (grobner-system cfl) '(x y) '(u)))
+
+(warn "Test 5 - a small robot example")
+(setf vars-params '(s1 c1 s2 c2 a b l1 l2 l3 ))
+(setf vars (butlast vars-params 5))
+(setf params (nthcdr 4 vars-params))
+(setf cover2 (cdr (parse-string-to-sorted-alist "[l1,l2,l3]" params)))
+(setf cover (list (list nil cover2)))
+(setf fl (cdr 
+	  (parse-string-to-sorted-alist
+	   "[a-l3*c1*c2+l3*s1*s2, b-l3*c1*s2-l3*c2*s1+l2*s1, c1^2+s1^2-1, c2^2+s2^2-1]"
+	   vars-params)))
+(setf  cfl (make-colored-poly-list fl 4))
+
+(time (cond-system-print (grobner-system cfl :cover cover)
+			 vars params))
+|#
+
+(warn "Test 1")
+(string-grobner-system "[4*x^2-3*x*y,4*x+5*y]" '(x y) '())
+
+(warn "Test 2 - Enneper")
+(let* ((val1
+       (string-grobner-system 
+	"[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
+	'(u v x y z) '() :suppress-value nil))
+       (val1 (grobner (mapcar #'colored-poly-to-poly (cadar val1))))
+       (val2 
+	(string-grobner "[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
+			'(u v x y z) :suppress-value nil)))
+  (grobner-equal val1 val2))
+
+
+(warn" Test 3 - staple")
+(string-grobner-system "[x+y,x+u*y]" '(x y) '(u))
+
+(warn" Test 4 - staple")
+(string-grobner-system "[x+y,u*x+y]" '(x y) '(u))
+
+
+(warn "Test 5 - a small robot example")
+(string-grobner-system "[a-l3*c1*c2+l3*s1*s2-l2*c1, b-l3*c1*s2-l3*c2*s1-l2*s1, c1^2+s1^2-1, c2^2+s2^2-1]" '(c2 s2 c1 s1) '(a b l2 l3) :cover '(("[]" "[l2,l3]")))
+
+(warn "Test 6 - Circle of Apollonius")
+(string-grobner-system 
+ "[2*x1-u1,2*x2-u2,2*x3-u1,2*x4-u2,x5*u1-x6*u2,x5*u2+x6*u1-u1*u2,x1^2-2*x1*x7+x7^2+x8^2-x7^2-x8^2+2*x8*x2-x2^2,x1^2-2*x1*x7+x7^2+x6^2-2*x6*x8+x8^2-x3^2+2*x3*x7-x7^2-x4^2+2*x4*x8-x8^2,1-s*x5^2+2*s*x5*x7-s*x7^2-s*x6^2+2*s*x6*x8-s*x8^2+s*x1^2-2*s*x1*x7+s*x7^2+s*x8^2]"
+ '(s x1 x2 x3 x4 x5 x6 x7 x8)		;vars
+ '(u1 u2)				;parameters
+ )
+
+(warn "Test 7")
+(setf fl (cdr (parse-string-to-sorted-alist 
+	       "[a^2*x^2*y+b*x^2*y+a^3*b*x*y+a^3*c*x*y,c^2*a*x^2+c^2*b*x^2+b*y+4]"
+	       '(x y a b c))))
+(setf cfl (make-colored-poly-list fl 2))
+(cond-system-print (determine cfl) '(x y) '(a b c))
+
+(warn "Test 8")
+(setf fl (cdr (parse-string-to-sorted-alist 
+	       "[a^2*x+5*a]"
+	       '(x a))))
+(setf cfl (make-colored-poly-list fl 1))
+(cond-system-print (determine cfl) '(x) '(a))
+
+(warn "Test 9 - the discriminant of a quadratic polynomial")
+(string-grobner-system 
+ "[a*x^2+b*x+c,2*a*x+b]" '(x) '(a b c)
+ :cover (list (list "[]" "[a]")))
+
+(warn "Test 10 - the discriminant of a cubic polynomial")
+(string-grobner-system 
+ "[x^3+p*x+q,3*x^2+p]" '(x) '(p q)
+ :cover (list (list "[]" "[]")))
+
+(warn "Test 11 - the discriminant of a quartic polynomial")
+(string-grobner-system 
+ "[x^4+p*x^2+q*x+r,4*x^3+2*p*x+q]" '(x) '(p q r)
+ :cover (list (list "[]" "[]")))
+
+
+(dribble)
+
Index: /trunk/tests/cox-tests.lisp
===================================================================
--- /trunk/tests/cox-tests.lisp	(revision 14)
+++ /trunk/tests/cox-tests.lisp	(revision 14)
@@ -0,0 +1,136 @@
+;;; THIS FILE IS OBSOLETE!!! IT NEEDS A CONVERSION TO NEW FORMAT.
+#|
+  SccsId="@(#)tests.lisp, version 1.7 of 5/14/94(11:23:03)
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+;;(load "grobner-front-end")
+
+(defun run (test) 
+  (format t "Test ~a ~:[failed~;succeeded~]...~%" test (time (funcall test))))
+
+(defun test-1 ()
+  (let* ((vars '(x y)))
+    (equalp
+     (mapcar #'(lambda (pred)
+		 (let* ((f (poly "4*x^2-3*x*y" vars pred))
+			(g (poly "4*x+5*y" vars pred)))
+		   (spoly f g pred)))
+	     (list #'lex> #'grlex> #'grevlex>))
+     (list
+      (poly "-32*x*y" vars #'lex>)
+      (poly "-32*x*y" vars #'grlex>)
+      (poly "-32*x*y" vars #'grevlex>)))))
+
+(defun test-2 ()
+  (let* ((vars '(x y z)))
+    (equalp
+     (mapcar #'(lambda (pred)
+		 (let* ((f (poly "4*x^5-3*x*y-z^2" vars pred))
+			(g (poly-list "[4*x^3+5*y+z^2,y^2+z]" vars pred)))
+		   (normal-form f g pred)))
+	     (list #'lex> #'grlex> #'grevlex>))
+     (list
+      (poly "-5*x^2*y-x^2*z^2-3*x*y-z^2" vars #'lex>)
+      (poly "-X^2*Z^2-5*X^2*Y-3*X*Y-Z^2" vars #'grlex>)
+      (poly "-X^2*Z^2-5*X^2*Y-3*X*Y-Z^2" vars #'grevlex>)))))
+
+
+;; Find the equation of the Enneper surface
+(defun test-3 ()
+  (let* ((vars '(u v x y z))
+	 (eqns (poly-list
+		"[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
+		vars))
+	 (ans (poly-list
+	       "[X^6 - 3 * X^4 * Y^2 + 5/9 * X^4 * Z^3 + 6 * X^4 * Z^2 - 3 *
+	       X^4 * Z + 3 * X^2 * Y^4 + 26/9 * X^2 * Y^2 * Z^3 + 6 * X^2 *
+	       Y^2 * Z + 16/243 * X^2 * Z^6 + 16/9 * X^2 * Z^5 + 80/9 * X^2 *
+	       Z^4 - 16 * X^2 * Z^3 - Y^6 + 5/9 * Y^4 * Z^3 - 6 * Y^4 * Z^2 -
+	       3 * Y^4 * Z - 16/243 * Y^2 * Z^6 + 16/9 * Y^2 * Z^5 - 80/9 *
+	       Y^2 * Z^4 - 16 * Y^2 * Z^3 - 64/19683 * Z^9 + 128/243 * Z^7 -
+	       64/3 * Z^5]"
+	       vars)))
+    (set-coefficient-ring nil)			;char=0
+    (equalp (elimination-ideal eqns 2) ans)))
+
+(defun test-4 ()
+  (let* ((vars '(x y))
+	 (id1 (poly-list "[x-y^2,y^2*x]" vars))
+	 (id2 (poly-list "[x^2-x*y^2,y^2]" vars))
+	 (ans (poly-list "[x^2,y^4,x*y^2]" vars)))
+    (equalp (ideal-intersection id1 id2) ans)))
+    
+(defun test-5 ()
+  (let* ((vars '(x y z))
+	 (f (poly-list "[x^5+y^4+z^3-1, x^3+y^2+z^2-1]" vars))
+	 (ans (poly-list
+	       "[ X^2 * Z^4 + X^2 * Z^3 - 2 * X^2 * Z^2 - 1/6 * X * Z^10 - 2/3
+	       * X * Z^9 - 1/4 * X * Z^8 + 7/6 * X * Z^7 - 1/12 * X * Z^6 - X
+	       * Z^5 + X * Z^4 + 1/2 * Y^10 * Z^2 + 1/3 * Y^10 * Z - 5/12 *
+	       Y^10 - 1/6 * Y^8 * Z^4 + 1/3 * Y^8 * Z^3 + 1/4 * Y^8 * Z^2 +
+	       1/2 * Y^8 + Y^6 * Z^5 - 5/3 * Y^6 * Z^4 - 17/6 * Y^6 * Z^3 +
+	       17/6 * Y^6 * Z^2 + 2/3 * Y^6 * Z - 1/3 * Y^6 - 1/3 * Y^4 * Z^7
+	       - 7/2 * Y^4 * Z^6 - 3 * Y^4 * Z^5 + 131/12 * Y^4 * Z^4 + 23/4 *
+	       Y^4 * Z^3 - 13 * Y^4 * Z^2 - 8/3 * Y^4 * Z + 29/6 * Y^4 - 17/6
+	       * Y^2 * Z^8 - 4 * Y^2 * Z^7 + 119/12 * Y^2 * Z^6 + 17/2 * Y^2 *
+	       Z^5 - 16 * Y^2 * Z^4 - 14/3 * Y^2 * Z^3 + 12 * Y^2 * Z^2 + 5/3
+	       * Y^2 * Z - 55/12 * Y^2 - 7/6 * Z^10 - 7/6 * Z^9 + 55/12 * Z^8
+	       + 21/4 * Z^7 - 31/4 * Z^6 - 15/2 * Z^5 + 83/12 * Z^4 + 41/12 *
+	       Z^3 - 31/12 * Z^2, X * Y^2 * Z - X * Y^2 - 1/8 * X * Z^10 -
+	       7/24 * X * Z^9 + 1/2 * X * Z^8 + 7/8 * X * Z^7 - 23/24 * X *
+	       Z^6 + 1/2 * X * Z^4 - 1/2 * X * Z^3 - X * Z + X + 3/8 * Y^10 *
+	       Z^2 - 3/8 * Y^10 * Z - 7/24 * Y^10 - 1/8 * Y^8 * Z^4 + 11/24 *
+	       Y^8 * Z^3 - 3/8 * Y^8 * Z^2 + 1/4 * Y^8 * Z - 1/4 * Y^8 + 3/4 *
+	       Y^6 * Z^5 - 5/2 * Y^6 * Z^4 + 5/6 * Y^6 * Z^3 + 31/12 * Y^6 *
+	       Z^2 - Y^6 * Z - 1/3 * Y^6 - 1/4 * Y^4 * Z^7 - 53/24 * Y^4 * Z^6
+	       + 11/6 * Y^4 * Z^5 + 113/12 * Y^4 * Z^4 - 55/8 * Y^4 * Z^3 -
+	       29/4 * Y^4 * Z^2 + 15/4 * Y^4 * Z + 19/12 * Y^4 - 17/8 * Y^2 *
+	       Z^8 + 13/24 * Y^2 * Z^7 + 239/24 * Y^2 * Z^6 - 59/12 * Y^2 *
+	       Z^5 - 151/12 * Y^2 * Z^4 + 85/12 * Y^2 * Z^3 + 43/8 * Y^2 * Z^2
+	       - 29/8 * Y^2 * Z + 7/24 * Y^2 - 7/8 * Z^10 + 7/12 * Z^9 + 31/8
+	       * Z^8 - 11/12 * Z^7 - 103/12 * Z^6 + 17/6 * Z^5 + 127/24 * Z^4
+	       - 3/2 * Z^3 - 17/24 * Z^2 + Z - 1, X * Z^11 + 4 * X * Z^10 + X
+	       * Z^9 - 10 * X * Z^8 - 4 * X * Z^7 + 8 * X * Z^6 - 3 * Y^10 *
+	       Z^3 - 2 * Y^10 * Z^2 + 4 * Y^10 * Z + 4 * Y^10 + Y^8 * Z^5 - 2
+	       * Y^8 * Z^4 - 2 * Y^8 * Z^3 - 6 * Y^6 * Z^6 + 10 * Y^6 * Z^5 +
+	       20 * Y^6 * Z^4 - 16 * Y^6 * Z^3 - 24 * Y^6 * Z^2 + 8 * Y^6 * Z
+	       + 8 * Y^6 + 2 * Y^4 * Z^8 + 21 * Y^4 * Z^7 + 17 * Y^4 * Z^6 -
+	       78 * Y^4 * Z^5 - 64 * Y^4 * Z^4 + 90 * Y^4 * Z^3 + 76 * Y^4 *
+	       Z^2 - 32 * Y^4 * Z - 32 * Y^4 + 17 * Y^2 * Z^9 + 24 * Y^2 * Z^8
+	       - 68 * Y^2 * Z^7 - 80 * Y^2 * Z^6 + 106 * Y^2 * Z^5 + 108 * Y^2
+	       * Z^4 - 77 * Y^2 * Z^3 - 70 * Y^2 * Z^2 + 20 * Y^2 * Z + 20 *
+	       Y^2 + 7 * Z^11 + 7 * Z^10 - 31 * Z^9 - 42 * Z^8 + 55 * Z^7 + 77
+	       * Z^6 - 39 * Z^5 - 62 * Z^4 + 8 * Z^3 + 20 * Z^2, Y^12 - Y^10 +
+	       3 * Y^8 * Z^3 - 5 * Y^8 * Z^2 + 2 * Y^8 - 10 * Y^6 * Z^4 + 20 *
+	       Y^6 * Z^2 - 10 * Y^6 - 7 * Y^4 * Z^6 + 30 * Y^4 * Z^4 - 6 * Y^4
+	       * Z^3 - 30 * Y^4 * Z^2 + 13 * Y^4 - 5 * Y^2 * Z^8 + 20 * Y^2 *
+	       Z^6 - 30 * Y^2 * Z^4 + 20 * Y^2 * Z^2 - 5 * Y^2 - Z^10 + Z^9 +
+	       5 * Z^8 - 13 * Z^6 + 10 * Z^4 + 3 * Z^3 - 5 * Z^2, X * Y^4 + X
+	       * Z^3 - X + Y^4 + 2 * Y^2 * Z^2 - 2 * Y^2 + Z^4 - 2 * Z^2 + 1,
+	       X^2 * Y^2 + X^2 * Z^2 - X^2 - Y^4 - Z^3 + 1, X^3 + Y^2 + Z^2 -
+	       1 ]" vars)))
+    (equalp (grobner f :reduce t) ans)))
+
+(defun test-6 ()
+  (let* ((vars '(x y z))
+	 (f (poly-list "[x^5+y^4+z^3-1,x^3+y^3+z^2-1]" vars))
+	 (ans (poly-list "[x]" vars)))		;unknown yet
+    (equalp (grobner f :reduce t) ans)))
+
+;;----------------------------------------------------------------
+
+(defun run-short-tests ()
+  (dolist (test '(test-1 test-2 test-4))
+    (run test)))
+
+(defun run-long-tests ()
+  (dolist (test '(test-3 test-5))
+    (run test)))
+
Index: /trunk/tests/grobner-tests.lisp
===================================================================
--- /trunk/tests/grobner-tests.lisp	(revision 14)
+++ /trunk/tests/grobner-tests.lisp	(revision 14)
@@ -0,0 +1,113 @@
+#|
+	$Id: grobner-tests.lisp,v 1.2 2009/01/19 18:30:17 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+;;(use-package '("PARSE" "MONOM" "PRINTER" "COLORED-POLY" "GROBNER" "COEFFICIENT-RING"))
+
+;; The value of this variable is a function that will do evaluation
+;; instead of eval; this one just prints what it is evaluating and calls eval
+
+#+kcl
+(setf *evalhook* 
+  #'(lambda (form env)
+      (format t "~&EVAL> ~s~%" form)
+      (let (val)
+	(time (setf val (multiple-value-list (eval form))))
+	(format t "~&VALUES--> ~s~2%" val)
+	val)))
+
+(defun run-grobner-test (plist vars pred result &optional (ring *coefficient-ring*))
+  (let* ((new-answer (progn (time (string-grobner plist vars
+						  :order pred
+						  :suppress-value nil
+						  :top-reduction-only nil))
+			    (terpri)))
+	 (answer (rest
+		  (string-read-poly
+		   result
+		   vars :order pred))))
+    (terpri)
+    (assert (grobner-test answer
+			  (rest (string-read-poly plist vars
+						  :order pred))
+			  pred ring))
+    (terpri)
+    (assert (set-exclusive-or new-answer answer :test #'tree-equal))))
+
+(dribble "grobner-tests.output")
+
+(warn "Test 1 - Enneper, full reduction")
+(run-grobner-test
+ "[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
+ '(u v x y z)
+ #'lex>
+"[ 54 * V^2 * Y * Z + 27 * V * X^2 - 27 * V * Y^2 + 8 * V * Z^3 + 72 * V * Z^2 - 9 * Y * Z^2 - 27 * Y * Z, 9 * U * X + 6 * V^2 * Z - 9 * V * Y + Z^2 - 9 * Z, 243 * V^2 * X^2 - 243 * V^2 * Y^2 - 1296 * V^2 * Z - 108 * V * Y * Z^2 + 324 * V * Y * Z + 108 * X^2 * Z + 648 * X^2 + 135 * Y^2 * Z - 648 * Y^2 - 4 * Z^4 + 48 * Z^3 + 108 * Z^2 - 1944 * Z, 2 * V^3 + V * Z + 3 * V - Y, 6 * U * V^2 - U * Z + 9 * U - 3 * X, 3 * U^2 - 3 * V^2 - Z, 4 * U * V * Z - 3 * U * Y + 3 * V * X, 9 * U * V * Y - 2 * U * Z^2 + 18 * U * Z - 9 * V^2 * X - 6 * X * Z, 27 * U * Y^2 - 8 * U * Z^3 + 72 * U * Z^2 - 36 * V^2 * X * Z - 27 * V * X * Y - 24 * X * Z^2, 18 * V^2 * Z^2 + 54 * V^2 * Z - 54 * V * Y * Z - 27 * X^2 + 27 * Y^2 + Z^3 - 18 * Z^2 + 81 * Z, 27 * V * X^2 * Z + 81 * V * X^2 + 135 * V * Y^2 * Z - 81 * V * Y^2 + 8 * V * Z^4 + 96 * V * Z^3 + 216 * V * Z^2 + 81 * X^2 * Y - 81 * Y^3 - 12 * Y * Z^3 - 324 * Y * Z, 4374 * V * X^2 * Y + 8748 * V * Y^3 * Z - 4374 * V * Y^3 + 648 * V * Y * Z^4 + 5184 * V * Y * Z^3 + 17496 * V * Y * Z^2 - 729 * X^4 + 5832 * X^2 * Y^2 - 189 * X^2 * Z^3 - 2430 * X^2 * Z^2 + 2187 * X^2 * Z - 5103 * Y^4 - 945 * Y^2 * Z^3 + 972 * Y^2 * Z^2 - 19683 * Y^2 * Z + 8 * Z^6 - 72 * Z^5 - 648 * Z^4 + 5832 * Z^3, 8748 * V * Y^3 * Z^2 + 648 * V * Y * Z^5 + 5832 * V * Y * Z^4 + 17496 * V * Y * Z^3 + 17496 * V * Y * Z^2 - 729 * X^4 * Z - 2187 * X^4 + 5832 * X^2 * Y^2 * Z + 4374 * X^2 * Y^2 - 189 * X^2 * Z^4 - 2997 * X^2 * Z^3 - 5103 * X^2 * Z^2 + 6561 * X^2 * Z - 5103 * Y^4 * Z - 2187 * Y^4 - 945 * Y^2 * Z^4 + 81 * Y^2 * Z^3 - 16767 * Y^2 * Z^2 - 6561 * Y^2 * Z + 8 * Z^7 - 48 * Z^6 - 864 * Z^5 + 3888 * Z^4 + 17496 * Z^3, 2187 * V * X^4 + 69984 * V * X^2 + 8748 * V * Y^4 * Z - 2187 * V * Y^4 + 648 * V * Y^2 * Z^4 + 3240 * V * Y^2 * Z^3 - 11664 * V * Y^2 * Z^2 + 139968 * V * Y^2 * Z - 69984 * V * Y^2 - 192 * V * Z^6 - 3456 * V * Z^5 - 15552 * V * Z^4 + 20736 * V * Z^3 + 186624 * V * Z^2 - 729 * X^4 * Y + 5832 * X^2 * Y^3 - 189 * X^2 * Y * Z^3 - 7047 * X^2 * Y * Z^2 - 23328 * X^2 * Y * Z + 69984 * X^2 * Y - 5103 * Y^5 - 945 * Y^3 * Z^3 + 1215 * Y^3 * Z^2 + 5832 * Y^3 * Z - 69984 * Y^3 + 8 * Y * Z^6 + 288 * Y * Z^5 + 216 * Y * Z^4 + 5184 * Y * Z^3 + 93312 * Y * Z^2 - 279936 * Y * Z, 19683 * X^6 - 59049 * X^4 * Y^2 + 10935 * X^4 * Z^3 + 118098 * X^4 * Z^2 - 59049 * X^4 * Z + 59049 * X^2 * Y^4 + 56862 * X^2 * Y^2 * Z^3 + 118098 * X^2 * Y^2 * Z + 1296 * X^2 * Z^6 + 34992 * X^2 * Z^5 + 174960 * X^2 * Z^4 - 314928 * X^2 * Z^3 - 19683 * Y^6 + 10935 * Y^4 * Z^3 - 118098 * Y^4 * Z^2 - 59049 * Y^4 * Z - 1296 * Y^2 * Z^6 + 34992 * Y^2 * Z^5 - 174960 * Y^2 * Z^4 - 314928 * Y^2 * Z^3 - 64 * Z^9 + 10368 * Z^7 - 419904 * Z^5 ]")
+
+(warn "Test 2 - Cox Example 1")
+(run-grobner-test
+ "[x^5+y^4+z^3-1, x^3+y^2+z^2-1]"
+ '(x y z)
+ #'lex>
+ "[ X^2 * Z^4 + X^2 * Z^3 - 2 * X^2 * Z^2 - 1/6 * X * Z^10 - 2/3
+	       * X * Z^9 - 1/4 * X * Z^8 + 7/6 * X * Z^7 - 1/12 * X * Z^6 - X
+	       * Z^5 + X * Z^4 + 1/2 * Y^10 * Z^2 + 1/3 * Y^10 * Z - 5/12 *
+	       Y^10 - 1/6 * Y^8 * Z^4 + 1/3 * Y^8 * Z^3 + 1/4 * Y^8 * Z^2 +
+	       1/2 * Y^8 + Y^6 * Z^5 - 5/3 * Y^6 * Z^4 - 17/6 * Y^6 * Z^3 +
+	       17/6 * Y^6 * Z^2 + 2/3 * Y^6 * Z - 1/3 * Y^6 - 1/3 * Y^4 * Z^7
+	       - 7/2 * Y^4 * Z^6 - 3 * Y^4 * Z^5 + 131/12 * Y^4 * Z^4 + 23/4 *
+	       Y^4 * Z^3 - 13 * Y^4 * Z^2 - 8/3 * Y^4 * Z + 29/6 * Y^4 - 17/6
+	       * Y^2 * Z^8 - 4 * Y^2 * Z^7 + 119/12 * Y^2 * Z^6 + 17/2 * Y^2 *
+	       Z^5 - 16 * Y^2 * Z^4 - 14/3 * Y^2 * Z^3 + 12 * Y^2 * Z^2 + 5/3
+	       * Y^2 * Z - 55/12 * Y^2 - 7/6 * Z^10 - 7/6 * Z^9 + 55/12 * Z^8
+	       + 21/4 * Z^7 - 31/4 * Z^6 - 15/2 * Z^5 + 83/12 * Z^4 + 41/12 *
+	       Z^3 - 31/12 * Z^2, X * Y^2 * Z - X * Y^2 - 1/8 * X * Z^10 -
+	       7/24 * X * Z^9 + 1/2 * X * Z^8 + 7/8 * X * Z^7 - 23/24 * X *
+	       Z^6 + 1/2 * X * Z^4 - 1/2 * X * Z^3 - X * Z + X + 3/8 * Y^10 *
+	       Z^2 - 3/8 * Y^10 * Z - 7/24 * Y^10 - 1/8 * Y^8 * Z^4 + 11/24 *
+	       Y^8 * Z^3 - 3/8 * Y^8 * Z^2 + 1/4 * Y^8 * Z - 1/4 * Y^8 + 3/4 *
+	       Y^6 * Z^5 - 5/2 * Y^6 * Z^4 + 5/6 * Y^6 * Z^3 + 31/12 * Y^6 *
+	       Z^2 - Y^6 * Z - 1/3 * Y^6 - 1/4 * Y^4 * Z^7 - 53/24 * Y^4 * Z^6
+	       + 11/6 * Y^4 * Z^5 + 113/12 * Y^4 * Z^4 - 55/8 * Y^4 * Z^3 -
+	       29/4 * Y^4 * Z^2 + 15/4 * Y^4 * Z + 19/12 * Y^4 - 17/8 * Y^2 *
+	       Z^8 + 13/24 * Y^2 * Z^7 + 239/24 * Y^2 * Z^6 - 59/12 * Y^2 *
+	       Z^5 - 151/12 * Y^2 * Z^4 + 85/12 * Y^2 * Z^3 + 43/8 * Y^2 * Z^2
+	       - 29/8 * Y^2 * Z + 7/24 * Y^2 - 7/8 * Z^10 + 7/12 * Z^9 + 31/8
+	       * Z^8 - 11/12 * Z^7 - 103/12 * Z^6 + 17/6 * Z^5 + 127/24 * Z^4
+	       - 3/2 * Z^3 - 17/24 * Z^2 + Z - 1, X * Z^11 + 4 * X * Z^10 + X
+	       * Z^9 - 10 * X * Z^8 - 4 * X * Z^7 + 8 * X * Z^6 - 3 * Y^10 *
+	       Z^3 - 2 * Y^10 * Z^2 + 4 * Y^10 * Z + 4 * Y^10 + Y^8 * Z^5 - 2
+	       * Y^8 * Z^4 - 2 * Y^8 * Z^3 - 6 * Y^6 * Z^6 + 10 * Y^6 * Z^5 +
+	       20 * Y^6 * Z^4 - 16 * Y^6 * Z^3 - 24 * Y^6 * Z^2 + 8 * Y^6 * Z
+	       + 8 * Y^6 + 2 * Y^4 * Z^8 + 21 * Y^4 * Z^7 + 17 * Y^4 * Z^6 -
+	       78 * Y^4 * Z^5 - 64 * Y^4 * Z^4 + 90 * Y^4 * Z^3 + 76 * Y^4 *
+	       Z^2 - 32 * Y^4 * Z - 32 * Y^4 + 17 * Y^2 * Z^9 + 24 * Y^2 * Z^8
+	       - 68 * Y^2 * Z^7 - 80 * Y^2 * Z^6 + 106 * Y^2 * Z^5 + 108 * Y^2
+	       * Z^4 - 77 * Y^2 * Z^3 - 70 * Y^2 * Z^2 + 20 * Y^2 * Z + 20 *
+	       Y^2 + 7 * Z^11 + 7 * Z^10 - 31 * Z^9 - 42 * Z^8 + 55 * Z^7 + 77
+	       * Z^6 - 39 * Z^5 - 62 * Z^4 + 8 * Z^3 + 20 * Z^2, Y^12 - Y^10 +
+	       3 * Y^8 * Z^3 - 5 * Y^8 * Z^2 + 2 * Y^8 - 10 * Y^6 * Z^4 + 20 *
+	       Y^6 * Z^2 - 10 * Y^6 - 7 * Y^4 * Z^6 + 30 * Y^4 * Z^4 - 6 * Y^4
+	       * Z^3 - 30 * Y^4 * Z^2 + 13 * Y^4 - 5 * Y^2 * Z^8 + 20 * Y^2 *
+	       Z^6 - 30 * Y^2 * Z^4 + 20 * Y^2 * Z^2 - 5 * Y^2 - Z^10 + Z^9 +
+	       5 * Z^8 - 13 * Z^6 + 10 * Z^4 + 3 * Z^3 - 5 * Z^2, X * Y^4 + X
+	       * Z^3 - X + Y^4 + 2 * Y^2 * Z^2 - 2 * Y^2 + Z^4 - 2 * Z^2 + 1,
+	       X^2 * Y^2 + X^2 * Z^2 - X^2 - Y^4 - Z^3 + 1, X^3 + Y^2 + Z^2 -
+	       1 ]")
+
+
+
+(warn "Test 3 - Cox Example 2")
+(run-grobner-test
+ "[x^5+y^4+z^3-1,x^3+y^3+z^2-1]"
+ '(x y z)
+ #'lex>
+ "[ X^3 + Y^3 + Z^2 - 1, X^2 * Y^3 + X^2 * Z^2 - X^2 - Y^4 - Z^3 + 1, 7776 * X^2 * Y * Z - 7776 * X^2 * Y + 7776 * X^2 * Z^6 + 15552 * X^2 * Z^5 + 23328 * X^2 * Z^4 - 23328 * X^2 * Z^3 - 23328 * X^2 * Z^2 - 7776 * X^2 * Z + 7776 * X^2 + 54432 * X * Y^3 * Z - 54432 * X * Y^3 - 93312 * X * Y^2 * Z + 93312 * X * Y^2 - 62093 * X * Z^20 - 481184 * X * Z^19 - 1974401 * X * Z^18 - 4548614 * X * Z^17 - 5402786 * X * Z^16 + 1471927 * X * Z^15 + 15375648 * X * Z^14 + 22142511 * X * Z^13 + 5326449 * X * Z^12 - 20991981 * X * Z^11 - 25192515 * X * Z^10 - 3694290 * X * Z^9 + 10699009 * X * Z^8 + 7091971 * X * Z^7 + 217021 * X * Z^6 + 7776 * X * Z^5 + 9720 * X * Z^4 + 5832 * X * Z^3 + 38880 * X * Z - 38880 * X - 62093 * Y^14 * Z^11 + 450211 * Y^14 * Z^10 + 2449174 * Y^14 * Z^9 + 5152725 * Y^14 * Z^8 + 5893152 * Y^14 * Z^7 + 2999595 * Y^14 * Z^6 - 3276945 * Y^14 * Z^5 - 9750375 * Y^14 * Z^4 - 11437557 * Y^14 * Z^3 - 6849778 * Y^14 * Z^2 - 1891498 * Y^14 * Z - 67438 * Y^14 + 620930 * Y^13 * Z^11 + 2576492 * Y^13 * Z^10 + 5401850 * Y^13 * Z^9 + 7811974 * Y^13 * Z^8 + 8669290 * Y^13 * Z^7 + 5973124 * Y^13 * Z^6 - 1522340 * Y^13 * Z^5 - 9389888 * Y^13 * Z^4 - 11328236 * Y^13 * Z^3 - 6905668 * Y^13 * Z^2 - 1884694 * Y^13 * Z - 78130 * Y^13 + 372558 * Y^12 * Z^12 + 1148500 * Y^12 * Z^11 + 1726276 * Y^12 * Z^10 + 2463088 * Y^12 * Z^9 + 5337046 * Y^12 * Z^8 + 9191446 * Y^12 * Z^7 + 8486896 * Y^12 * Z^6 + 394832 * Y^12 * Z^5 - 9020896 * Y^12 * Z^4 - 11280880 * Y^12 * Z^3 - 6894490 * Y^12 * Z^2 - 1910938 * Y^12 * Z - 55774 * Y^12 - 124186 * Y^11 * Z^13 + 2390654 * Y^11 * Z^12 + 11665603 * Y^11 * Z^11 + 20826185 * Y^11 * Z^10 + 14515838 * Y^11 * Z^9 - 9842841 * Y^11 * Z^8 - 39441258 * Y^11 * Z^7 - 55471863 * Y^11 * Z^6 - 35486271 * Y^11 * Z^5 + 15841297 * Y^11 * Z^4 + 47780995 * Y^11 * Z^3 + 33943290 * Y^11 * Z^2 + 9409862 * Y^11 * Z + 373154 * Y^11 + 62093 * Y^10 * Z^14 + 2654439 * Y^10 * Z^13 + 10433286 * Y^10 * Z^12 + 18068852 * Y^10 * Z^11 + 18157977 * Y^10 * Z^10 + 10384929 * Y^10 * Z^9 - 8576554 * Y^10 * Z^8 - 43983913 * Y^10 * Z^7 - 68351032 * Y^10 * Z^6 - 43934307 * Y^10 * Z^5 + 13952111 * Y^10 * Z^4 + 47175827 * Y^10 * Z^3 + 34193580 * Y^10 * Z^2 + 9408890 * Y^10 * Z + 393566 * Y^10 + 1241860 * Y^9 * Z^14 + 3166008 * Y^9 * Z^13 + 994182 * Y^9 * Z^12 - 1766604 * Y^9 * Z^11 + 10234776 * Y^9 * Z^10 + 30607428 * Y^9 * Z^9 + 19746518 * Y^9 * Z^8 - 35115338 * Y^9 * Z^7 - 78724496 * Y^9 * Z^6 - 53390064 * Y^9 * Z^5 + 12147732 * Y^9 * Z^4 + 46880484 * Y^9 * Z^3 + 34174626 * Y^9 * Z^2 + 9573158 * Y^9 * Z + 248738 * Y^9 - 62093 * Y^8 * Z^15 + 4051605 * Y^8 * Z^14 + 18125525 * Y^8 * Z^13 + 28414036 * Y^8 * Z^12 + 9581124 * Y^8 * Z^11 - 32226896 * Y^8 * Z^10 - 69123395 * Y^8 * Z^9 - 81091480 * Y^8 * Z^8 - 35307862 * Y^8 * Z^7 + 66547639 * Y^8 * Z^6 + 115182683 * Y^8 * Z^5 + 48088910 * Y^8 * Z^4 - 29152980 * Y^8 * Z^3 - 33299528 * Y^8 * Z^2 - 9206714 * Y^8 * Z - 541310 * Y^8 + 124186 * Y^7 * Z^16 + 3818646 * Y^7 * Z^15 + 14285596 * Y^7 * Z^14 + 19298896 * Y^7 * Z^13 + 7117194 * Y^7 * Z^12 - 9270810 * Y^7 * Z^11 - 26804700 * Y^7 * Z^10 - 66254262 * Y^7 * Z^9 - 84309180 * Y^7 * Z^8 - 4494634 * Y^7 * Z^7 + 118530918 * Y^7 * Z^6 + 133783318 * Y^7 * Z^5 + 26287984 * Y^7 * Z^4 - 62322100 * Y^7 * Z^3 - 54131228 * Y^7 * Z^2 - 15072692 * Y^7 * Z - 571580 * Y^7 - 62093 * Y^6 * Z^17 + 1071141 * Y^6 * Z^16 + 1051714 * Y^6 * Z^15 - 10057949 * Y^6 * Z^14 - 21572134 * Y^6 * Z^13 + 6413327 * Y^6 * Z^12 + 59209974 * Y^6 * Z^11 + 39254296 * Y^6 * Z^10 - 78227581 * Y^6 * Z^9 - 143215725 * Y^6 * Z^8 - 32549470 * Y^6 * Z^7 + 132719201 * Y^6 * Z^6 + 148478637 * Y^6 * Z^5 + 29119635 * Y^6 * Z^4 - 61589201 * Y^6 * Z^3 - 54345068 * Y^6 * Z^2 - 15315692 * Y^6 * Z - 359684 * Y^6 + 2732092 * Y^5 * Z^16 + 10988844 * Y^5 * Z^15 + 12430164 * Y^5 * Z^14 - 10283576 * Y^5 * Z^13 - 40089496 * Y^5 * Z^12 - 50953520 * Y^5 * Z^11 - 45553956 * Y^5 * Z^10 - 701820 * Y^5 * Z^9 + 101520364 * Y^5 * Z^8 + 142704156 * Y^5 * Z^7 + 28845308 * Y^5 * Z^6 - 90595828 * Y^5 * Z^5 - 72824464 * Y^5 * Z^4 - 4522320 * Y^5 * Z^3 + 12452276 * Y^5 * Z^2 + 3496256 * Y^5 * Z + 386624 * Y^5 + 62093 * Y^4 * Z^18 + 2157695 * Y^4 * Z^17 + 7080558 * Y^4 * Z^16 + 6495674 * Y^4 * Z^15 - 1846064 * Y^4 * Z^14 + 885080 * Y^4 * Z^13 + 1387642 * Y^4 * Z^12 - 49868373 * Y^4 * Z^11 - 105032993 * Y^4 * Z^10 - 31820374 * Y^4 * Z^9 + 129546847 * Y^4 * Z^8 + 167383594 * Y^4 * Z^7 + 28654796 * Y^4 * Z^6 - 93073209 * Y^4 * Z^5 - 73097103 * Y^4 * Z^4 - 5850743 * Y^4 * Z^3 + 13044224 * Y^4 * Z^2 + 3690656 * Y^4 * Z + 200000 * Y^4 - 124186 * Y^3 * Z^19 - 93066 * Y^3 * Z^18 - 2614317 * Y^3 * Z^17 - 14439323 * Y^3 * Z^16 - 20470190 * Y^3 * Z^15 + 20484593 * Y^3 * Z^14 + 83602226 * Y^3 * Z^13 + 51887995 * Y^3 * Z^12 - 93415586 * Y^3 * Z^11 - 161017882 * Y^3 * Z^10 - 13363721 * Y^3 * Z^9 + 170255391 * Y^3 * Z^8 + 137957690 * Y^3 * Z^7 - 45834331 * Y^3 * Z^6 - 128446523 * Y^3 * Z^5 - 55627499 * Y^3 * Z^4 + 27747047 * Y^3 * Z^3 + 33736442 * Y^3 * Z^2 + 9648974 * Y^3 * Z + 126266 * Y^3 + 620930 * Y^2 * Z^18 + 1955562 * Y^2 * Z^17 - 279292 * Y^2 * Z^16 - 9851406 * Y^2 * Z^15 - 16124282 * Y^2 * Z^14 - 8540932 * Y^2 * Z^13 + 3321430 * Y^2 * Z^12 + 20070502 * Y^2 * Z^11 + 51189864 * Y^2 * Z^10 + 50901220 * Y^2 * Z^9 - 21177336 * Y^2 * Z^8 - 81223016 * Y^2 * Z^7 - 46221546 * Y^2 * Z^6 + 17771150 * Y^2 * Z^5 + 28155166 * Y^2 * Z^4 + 8893592 * Y^2 * Z^3 + 538394 * Y^2 * Z^2 + 93312 * Y^2 * Z - 93312 * Y^2 + 372558 * Y * Z^19 + 775942 * Y * Z^18 - 1285014 * Y * Z^17 - 4633130 * Y * Z^16 - 138226 * Y * Z^15 + 5184446 * Y * Z^14 - 13306902 * Y * Z^13 - 34770050 * Y * Z^12 + 3870366 * Y * Z^11 + 77880544 * Y * Z^10 + 72922124 * Y * Z^9 - 25219024 * Y * Z^8 - 88829334 * Y * Z^7 - 47570630 * Y * Z^6 + 16921524 * Y * Z^5 + 28220776 * Y * Z^4 + 9356264 * Y * Z^3 + 247766 * Y * Z^2 - 7776 * Y * Z + 7776 * Y - 62093 * Z^21 - 294905 * Z^20 - 1896895 * Z^19 - 5672158 * Z^18 - 3792326 * Z^17 + 17358124 * Z^16 + 37860730 * Z^15 + 4109437 * Z^14 - 75897065 * Z^13 - 89966545 * Z^12 + 21700007 * Z^11 + 135785208 * Z^10 + 98509917 * Z^9 - 39012662 * Z^8 - 103259594 * Z^7 - 50374091 * Z^6 + 17195287 * Z^5 + 27941326 * Z^4 + 9673136 * Z^3 + 95162 * Z^2 - 31104 * Z + 31104, 3888 * X^2 * Z^7 + 11664 * X^2 * Z^6 + 19440 * X^2 * Z^5 - 19440 * X^2 * Z^3 - 15552 * X^2 * Z^2 + 69984 * X * Y^3 * Z - 69984 * X * Y^3 - 104976 * X * Y^2 * Z + 104976 * X * Y^2 - 62197 * X * Z^20 - 477679 * X * Z^19 - 1943665 * X * Z^18 - 4414720 * X * Z^17 - 5079481 * X * Z^16 + 1881863 * X * Z^15 + 15324612 * X * Z^14 + 21069324 * X * Z^13 + 3669771 * X * Z^12 - 21506892 * X * Z^11 - 23712288 * X * Z^10 - 1764237 * X * Z^9 + 11052938 * X * Z^8 + 6288353 * X * Z^7 - 343198 * X * Z^6 + 5832 * X * Z^5 + 11664 * X * Z^4 + 34992 * X * Z - 34992 * X - 62197 * Y^14 * Z^11 + 455276 * Y^14 * Z^10 + 2422655 * Y^14 * Z^9 + 4986216 * Y^14 * Z^8 + 5523915 * Y^14 * Z^7 + 2561289 * Y^14 * Z^6 - 3518784 * Y^14 * Z^5 - 9539685 * Y^14 * Z^4 - 10740936 * Y^14 * Z^3 - 6000836 * Y^14 * Z^2 - 1367102 * Y^14 * Z + 74500 * Y^14 + 621970 * Y^13 * Z^11 + 2537698 * Y^13 * Z^10 + 5225662 * Y^13 * Z^9 + 7428554 * Y^13 * Z^8 + 8105042 * Y^13 * Z^7 + 5335154 * Y^13 * Z^6 - 1983340 * Y^13 * Z^5 - 9316858 * Y^13 * Z^4 - 10658716 * Y^13 * Z^3 - 6064016 * Y^13 * Z^2 - 1360298 * Y^13 * Z + 64780 * Y^13 + 373182 * Y^12 * Z^12 + 1124558 * Y^12 * Z^11 + 1645616 * Y^12 * Z^10 + 2338550 * Y^12 * Z^9 + 5165504 * Y^12 * Z^8 + 8820386 * Y^12 * Z^7 + 7823078 * Y^12 * Z^6 - 253010 * Y^12 * Z^5 - 9093788 * Y^12 * Z^4 - 10641134 * Y^12 * Z^3 - 6053324 * Y^12 * Z^2 - 1388486 * Y^12 * Z + 90052 * Y^12 - 124394 * Y^11 * Z^13 + 2403280 * Y^11 * Z^12 + 11520437 * Y^11 * Z^11 + 20025700 * Y^11 * Z^10 + 12994009 * Y^11 * Z^9 - 10993230 * Y^11 * Z^8 - 38847465 * Y^11 * Z^7 - 52680669 * Y^11 * Z^6 - 31408200 * Y^11 * Z^5 + 18625895 * Y^11 * Z^4 + 46816940 * Y^11 * Z^3 + 30408756 * Y^11 * Z^2 + 6785938 * Y^11 * Z - 331676 * Y^11 + 62197 * Y^10 * Z^14 + 2654574 * Y^10 * Z^13 + 10265835 * Y^10 * Z^12 + 17348077 * Y^10 * Z^11 + 16847943 * Y^10 * Z^10 + 9032604 * Y^10 * Z^9 - 9390554 * Y^10 * Z^8 - 43483352 * Y^10 * Z^7 - 65292989 * Y^10 * Z^6 - 38911488 * Y^10 * Z^5 + 17408485 * Y^10 * Z^4 + 46335370 * Y^10 * Z^3 + 30703272 * Y^10 * Z^2 + 6786910 * Y^10 * Z - 318068 * Y^10 + 1243940 * Y^9 * Z^14 + 3085092 * Y^9 * Z^13 + 763326 * Y^9 * Z^12 - 1861182 * Y^9 * Z^11 + 10386480 * Y^9 * Z^10 + 29961138 * Y^9 * Z^9 + 17534260 * Y^9 * Z^8 - 36765466 * Y^9 * Z^7 - 76413538 * Y^9 * Z^6 - 47606934 * Y^9 * Z^5 + 16339548 * Y^9 * Z^4 + 46176990 * Y^9 * Z^3 + 30698412 * Y^9 * Z^2 + 6962842 * Y^9 * Z - 479420 * Y^9 - 62197 * Y^8 * Z^15 + 4062702 * Y^8 * Z^14 + 17875228 * Y^8 * Z^13 + 27161252 * Y^8 * Z^12 + 7471074 * Y^8 * Z^11 - 33102991 * Y^8 * Z^10 - 66936577 * Y^8 * Z^9 - 76120232 * Y^8 * Z^8 - 29301146 * Y^8 * Z^7 + 69509327 * Y^8 * Z^6 + 110691688 * Y^8 * Z^5 + 39460090 * Y^8 * Z^4 - 33130656 * Y^8 * Z^3 - 31174168 * Y^8 * Z^2 - 6567238 * Y^8 * Z + 139220 * Y^8 + 124394 * Y^7 * Z^16 + 3816420 * Y^7 * Z^15 + 14043134 * Y^7 * Z^14 + 18301298 * Y^7 * Z^13 + 5672886 * Y^7 * Z^12 - 9874692 * Y^7 * Z^11 - 26175312 * Y^7 * Z^10 - 64418844 * Y^7 * Z^9 - 79656150 * Y^7 * Z^8 + 1847500 * Y^7 * Z^7 + 119457606 * Y^7 * Z^6 + 125367140 * Y^7 * Z^5 + 16066196 * Y^7 * Z^4 - 64709996 * Y^7 * Z^3 - 49525624 * Y^7 * Z^2 - 10879468 * Y^7 * Z + 559064 * Y^7 - 62197 * Y^6 * Z^17 + 1077246 * Y^6 * Z^16 + 979745 * Y^6 * Z^15 - 10159270 * Y^6 * Z^14 - 20912123 * Y^6 * Z^13 + 8030785 * Y^6 * Z^12 + 58997319 * Y^6 * Z^11 + 35006123 * Y^6 * Z^10 - 81555203 * Y^6 * Z^9 - 137987784 * Y^6 * Z^8 - 21773417 * Y^6 * Z^7 + 135926551 * Y^6 * Z^6 + 139019436 * Y^6 * Z^5 + 17749911 * Y^6 * Z^4 - 64170334 * Y^6 * Z^3 - 49799728 * Y^6 * Z^2 - 11139964 * Y^6 * Z + 796232 * Y^6 + 2736668 * Y^5 * Z^16 + 10817568 * Y^5 * Z^15 + 11660088 * Y^5 * Z^14 - 11254696 * Y^5 * Z^13 - 39489536 * Y^5 * Z^12 - 48089980 * Y^5 * Z^11 - 41808924 * Y^5 * Z^10 + 2708652 * Y^5 * Z^9 + 101941496 * Y^5 * Z^8 + 135684168 * Y^5 * Z^7 + 18081196 * Y^5 * Z^6 - 93428348 * Y^5 * Z^5 - 66181556 * Y^5 * Z^4 + 1268748 * Y^5 * Z^3 + 12830488 * Y^5 * Z^2 + 2410528 * Y^5 * Z + 148432 * Y^5 + 62197 * Y^4 * Z^18 + 2156998 * Y^4 * Z^17 + 6941979 * Y^4 * Z^16 + 5993371 * Y^4 * Z^15 - 2355712 * Y^4 * Z^14 + 998824 * Y^4 * Z^13 + 1373297 * Y^4 * Z^12 - 50094117 * Y^4 * Z^11 - 101736412 * Y^4 * Z^10 - 24063602 * Y^4 * Z^9 + 132624275 * Y^4 * Z^8 + 158340584 * Y^4 * Z^7 + 15863623 * Y^4 * Z^6 - 95842332 * Y^4 * Z^5 - 66222615 * Y^4 * Z^4 - 131590 * Y^4 * Z^3 + 13526440 * Y^4 * Z^2 + 2641864 * Y^4 * Z - 77072 * Y^4 - 124394 * Y^3 * Z^19 - 84600 * Y^3 * Z^18 - 2610963 * Y^3 * Z^17 - 14282032 * Y^3 * Z^16 - 19475671 * Y^3 * Z^15 + 22068016 * Y^3 * Z^14 + 82420621 * Y^3 * Z^13 + 45846113 * Y^3 * Z^12 - 97789063 * Y^3 * Z^11 - 154747355 * Y^3 * Z^10 - 1148833 * Y^3 * Z^9 + 172225566 * Y^3 * Z^8 + 125604427 * Y^3 * Z^7 - 56776217 * Y^3 * Z^6 - 125597464 * Y^3 * Z^5 - 45915757 * Y^3 * Z^4 + 32235268 * Y^3 * Z^3 + 31703908 * Y^3 * Z^2 + 7044490 * Y^3 * Z - 596060 * Y^3 + 621970 * Y^2 * Z^18 + 1915728 * Y^2 * Z^17 - 421886 * Y^2 * Z^16 - 9863628 * Y^2 * Z^15 - 15450484 * Y^2 * Z^14 - 7344470 * Y^2 * Z^13 + 4006574 * Y^2 * Z^12 + 19868540 * Y^2 * Z^11 + 49836054 * Y^2 * Z^10 + 47268530 * Y^2 * Z^9 - 25125354 * Y^2 * Z^8 - 80065726 * Y^2 * Z^7 - 40208808 * Y^2 * Z^6 + 21532348 * Y^2 * Z^5 + 26910314 * Y^2 * Z^4 + 6653686 * Y^2 * Z^3 - 133388 * Y^2 * Z^2 + 104976 * Y^2 * Z - 104976 * Y^2 + 373182 * Y * Z^19 + 751376 * Y * Z^18 - 1344852 * Y * Z^17 - 4556674 * Y * Z^16 + 201616 * Y * Z^15 + 5236534 * Y * Z^14 - 13720314 * Y * Z^13 - 33940378 * Y * Z^12 + 6467994 * Y * Z^11 + 77962850 * Y * Z^10 + 67373776 * Y * Z^9 - 30962138 * Y * Z^8 - 87379542 * Y * Z^7 - 40930240 * Y * Z^6 + 20745570 * Y * Z^5 + 27005570 * Y * Z^4 + 7185370 * Y * Z^3 - 469700 * Y * Z^2 - 62197 * Z^21 - 291088 * Z^20 - 1878962 * Z^19 - 5547434 * Z^18 - 3387640 * Z^17 + 17694533 * Z^16 + 36718052 * Z^15 + 1299572 * Z^14 - 76544146 * Z^13 - 84649877 * Z^12 + 28651966 * Z^11 + 134827431 * Z^10 + 88593549 * Z^9 - 46839364 * Z^8 - 100799218 * Z^7 - 42613627 * Z^6 + 21217046 * Z^5 + 26735354 * Z^4 + 7526542 * Z^3 - 650492 * Z^2 - 34992 * Z + 34992, X * Y^4 + X * Z^3 - X + Y^6 + 2 * Y^3 * Z^2 - 2 * Y^3 + Z^4 - 2 * Z^2 + 1, 69984 * X * Y * Z^2 - 139968 * X * Y * Z + 69984 * X * Y - 44425 * X * Z^20 - 327070 * X * Z^19 - 1278214 * X * Z^18 - 2698855 * X * Z^17 - 2572042 * X * Z^16 + 2619449 * X * Z^15 + 10650408 * X * Z^14 + 11493837 * X * Z^13 - 2616810 * X * Z^12 - 16744470 * X * Z^11 - 12049440 * X * Z^10 + 4801407 * X * Z^9 + 8854766 * X * Z^8 + 1892306 * X * Z^7 - 1980847 * X * Z^6 + 17496 * X * Z^5 - 34992 * X * Z^4 + 17496 * X * Z^3 - 69984 * X * Z^2 + 139968 * X * Z - 69984 * X - 44425 * Y^14 * Z^11 + 339305 * Y^14 * Z^10 + 1628711 * Y^14 * Z^9 + 3000105 * Y^14 * Z^8 + 2743338 * Y^14 * Z^7 + 437586 * Y^14 * Z^6 - 3228714 * Y^14 * Z^5 - 6067476 * Y^14 * Z^4 - 5393667 * Y^14 * Z^3 - 1569800 * Y^14 * Z^2 + 632812 * Y^14 * Z + 501226 * Y^14 + 444250 * Y^13 * Z^11 + 1671400 * Y^13 * Z^10 + 3140020 * Y^13 * Z^9 + 4046756 * Y^13 * Z^8 + 3960482 * Y^13 * Z^7 + 1782242 * Y^13 * Z^6 - 2836264 * Y^13 * Z^5 - 6324094 * Y^13 * Z^4 - 5404156 * Y^13 * Z^3 - 1661654 * Y^13 * Z^2 + 685300 * Y^13 * Z + 474982 * Y^13 + 266550 * Y^12 * Z^12 + 718520 * Y^12 * Z^11 + 910274 * Y^12 * Z^10 + 1263518 * Y^12 * Z^9 + 3116408 * Y^12 * Z^8 + 5071808 * Y^12 * Z^7 + 3440132 * Y^12 * Z^6 - 2194496 * Y^12 * Z^5 - 6620078 * Y^12 * Z^4 - 5499938 * Y^12 * Z^3 - 1622288 * Y^12 * Z^2 + 632812 * Y^12 * Z + 501226 * Y^12 - 88850 * Y^11 * Z^13 + 1744810 * Y^11 * Z^12 + 7686377 * Y^11 * Z^11 + 11626231 * Y^11 * Z^10 + 4404103 * Y^11 * Z^9 - 11359143 * Y^11 * Z^8 - 25510554 * Y^11 * Z^7 - 28425462 * Y^11 * Z^6 - 9426528 * Y^11 * Z^5 + 21880364 * Y^11 * Z^4 + 29810057 * Y^11 * Z^3 + 10350756 * Y^11 * Z^2 - 3181556 * Y^11 * Z - 2497382 * Y^11 + 44425 * Y^10 * Z^14 + 1881945 * Y^10 * Z^13 + 6728289 * Y^10 * Z^12 + 9990070 * Y^10 * Z^11 + 7801347 * Y^10 * Z^10 + 2153415 * Y^10 * Z^9 - 9140507 * Y^10 * Z^8 - 29133398 * Y^10 * Z^7 - 36482669 * Y^10 * Z^6 - 11662110 * Y^10 * Z^5 + 22936006 * Y^10 * Z^4 + 29956543 * Y^10 * Z^3 + 10775034 * Y^10 * Z^2 - 3478988 * Y^10 * Z - 2348666 * Y^10 + 888500 * Y^9 * Z^14 + 1921200 * Y^9 * Z^13 - 187950 * Y^9 * Z^12 - 1596036 * Y^9 * Z^11 + 7831314 * Y^9 * Z^10 + 19135710 * Y^9 * Z^9 + 5385232 * Y^9 * Z^8 - 31118752 * Y^9 * Z^7 - 46554784 * Y^9 * Z^6 - 15507324 * Y^9 * Z^5 + 24599634 * Y^9 * Z^4 + 30284550 * Y^9 * Z^3 + 10578204 * Y^9 * Z^2 - 3111572 * Y^9 * Z - 2532374 * Y^9 - 44425 * Y^8 * Z^15 + 2915955 * Y^8 * Z^14 + 11847046 * Y^8 * Z^13 + 15235952 * Y^8 * Z^12 - 1342215 * Y^8 * Z^11 - 26096155 * Y^8 * Z^10 - 40336258 * Y^8 * Z^9 - 38148698 * Y^8 * Z^8 - 1947773 * Y^8 * Z^7 + 58365386 * Y^8 * Z^6 + 63744949 * Y^8 * Z^5 + 662692 * Y^8 * Z^4 - 35221464 * Y^8 * Z^3 - 15349894 * Y^8 * Z^2 + 3269036 * Y^8 * Z + 2453642 * Y^8 + 88850 * Y^7 * Z^16 + 2697690 * Y^7 * Z^15 + 9160898 * Y^7 * Z^14 + 9782204 * Y^7 * Z^13 - 505866 * Y^7 * Z^12 - 8841150 * Y^7 * Z^11 - 16474014 * Y^7 * Z^10 - 39769140 * Y^7 * Z^9 - 41664378 * Y^7 * Z^8 + 21330064 * Y^7 * Z^7 + 86946000 * Y^7 * Z^6 + 61819454 * Y^7 * Z^5 - 20296984 * Y^7 * Z^4 - 53124800 * Y^7 * Z^3 - 20474824 * Y^7 * Z^2 + 5569880 * Y^7 * Z + 3756116 * Y^7 - 44425 * Y^6 * Z^17 + 783555 * Y^6 * Z^16 + 456911 * Y^6 * Z^15 - 7506655 * Y^6 * Z^14 - 12668822 * Y^6 * Z^13 + 10778914 * Y^6 * Z^12 + 40955979 * Y^6 * Z^11 + 11243399 * Y^6 * Z^10 - 68036522 * Y^6 * Z^9 - 80668677 * Y^6 * Z^8 + 18392944 * Y^6 * Z^7 + 105699982 * Y^6 * Z^6 + 68420946 * Y^6 * Z^5 - 23355948 * Y^6 * Z^4 - 52987825 * Y^6 * Z^3 - 20457328 * Y^6 * Z^2 + 4905032 * Y^6 * Z + 4088540 * Y^6 + 1954700 * Y^5 * Z^16 + 7105380 * Y^5 * Z^15 + 5800536 * Y^5 * Z^14 - 10997536 * Y^5 * Z^13 - 25975004 * Y^5 * Z^12 - 24957052 * Y^5 * Z^11 - 17808216 * Y^5 * Z^10 + 12529572 * Y^5 * Z^9 + 73310048 * Y^5 * Z^8 + 73580532 * Y^5 * Z^7 - 21170564 * Y^5 * Z^6 - 74140892 * Y^5 * Z^5 - 25675184 * Y^5 * Z^4 + 18268092 * Y^5 * Z^3 + 10504900 * Y^5 * Z^2 - 1388096 * Y^5 * Z - 941216 * Y^5 + 44425 * Y^4 * Z^18 + 1526545 * Y^4 * Z^17 + 4467129 * Y^4 * Z^16 + 2647468 * Y^4 * Z^15 - 3245086 * Y^4 * Z^14 + 1090138 * Y^4 * Z^13 + 899768 * Y^4 * Z^12 - 36144372 * Y^4 * Z^11 - 61462426 * Y^4 * Z^10 + 7525711 * Y^4 * Z^9 + 103064435 * Y^4 * Z^8 + 82980083 * Y^4 * Z^7 - 28598633 * Y^4 * Z^6 - 75995106 * Y^4 * Z^5 - 25336908 * Y^4 * Z^4 + 18247517 * Y^4 * Z^3 + 10793584 * Y^4 * Z^2 - 1738016 * Y^4 * Z - 766256 * Y^4 - 88850 * Y^3 * Z^19 - 32190 * Y^3 * Z^18 - 1842423 * Y^3 * Z^17 - 9605029 * Y^3 * Z^16 - 10602997 * Y^3 * Z^15 + 20587543 * Y^3 * Z^14 + 54430174 * Y^3 * Z^13 + 13274582 * Y^3 * Z^12 - 82735585 * Y^3 * Z^11 - 89174777 * Y^3 * Z^10 + 37559804 * Y^3 * Z^9 + 127272309 * Y^3 * Z^8 + 49867042 * Y^3 * Z^7 - 74430398 * Y^3 * Z^6 - 79475920 * Y^3 * Z^5 - 1372204 * Y^3 * Z^4 + 36291181 * Y^3 * Z^3 + 15564220 * Y^3 * Z^2 - 2796644 * Y^3 * Z - 2689838 * Y^3 + 444250 * Y^2 * Z^18 + 1227150 * Y^2 * Z^17 - 752630 * Y^2 * Z^16 - 7006014 * Y^2 * Z^15 - 8783974 * Y^2 * Z^14 - 1436450 * Y^2 * Z^13 + 4950830 * Y^2 * Z^12 + 13378064 * Y^2 * Z^11 + 30957924 * Y^2 * Z^10 + 21952328 * Y^2 * Z^9 - 30170622 * Y^2 * Z^8 - 52627432 * Y^2 * Z^7 - 9384858 * Y^2 * Z^6 + 26513908 * Y^2 * Z^5 + 15113990 * Y^2 * Z^4 - 2001554 * Y^2 * Z^3 - 2374910 * Y^2 * Z^2 + 266550 * Y * Z^19 + 451970 * Y * Z^18 - 1140996 * Y * Z^17 - 2972806 * Y * Z^16 + 1218640 * Y * Z^15 + 3837574 * Y * Z^14 - 11018460 * Y * Z^13 - 21334144 * Y * Z^12 + 12799086 * Y * Z^11 + 55234262 * Y * Z^10 + 29962348 * Y * Z^9 - 39724286 * Y * Z^8 - 56881602 * Y * Z^7 - 8218528 * Y * Z^6 + 26664768 * Y * Z^5 + 15232088 * Y * Z^4 - 2010302 * Y * Z^3 - 2436146 * Y * Z^2 + 139968 * Y * Z - 69984 * Y - 44425 * Z^21 - 193795 * Z^20 - 1274354 * Z^19 - 3527528 * Z^18 - 1109995 * Z^17 + 13565093 * Z^16 + 22302653 * Z^15 - 7954033 * Z^14 - 56030677 * Z^13 - 42908546 * Z^12 + 42041860 * Z^11 + 91874913 * Z^10 + 31327296 * Z^9 - 57432520 * Z^8 - 63266461 * Z^7 - 5375344 * Z^6 + 27268337 * Z^5 + 14641598 * Z^4 - 1214234 * Z^3 - 2619854 * Z^2 - 139968 * Z + 69984, X * Z^21 + 9 * X * Z^20 + 42 * X * Z^19 + 117 * X * Z^18 + 195 * X * Z^17 + 123 * X * Z^16 - 232 * X * Z^15 - 678 * X * Z^14 - 660 * X * Z^13 + 45 * X * Z^12 + 783 * X * Z^11 + 744 * X * Z^10 + 115 * X * Z^9 - 300 * X * Z^8 - 240 * X * Z^7 - 64 * X * Z^6 + Y^14 * Z^12 - 6 * Y^14 * Z^11 - 48 * Y^14 * Z^10 - 136 * Y^14 * Z^9 - 219 * Y^14 * Z^8 - 210 * Y^14 * Z^7 - 57 * Y^14 * Z^6 + 198 * Y^14 * Z^5 + 408 * Y^14 * Z^4 + 422 * Y^14 * Z^3 + 264 * Y^14 * Z^2 + 96 * Y^14 * Z + 16 * Y^14 - 10 * Y^13 * Z^12 - 54 * Y^13 * Z^11 - 144 * Y^13 * Z^10 - 256 * Y^13 * Z^9 - 342 * Y^13 * Z^8 - 336 * Y^13 * Z^7 - 168 * Y^13 * Z^6 + 132 * Y^13 * Z^5 + 384 * Y^13 * Z^4 + 418 * Y^13 * Z^3 + 264 * Y^13 * Z^2 + 96 * Y^13 * Z + 16 * Y^13 - 6 * Y^12 * Z^13 - 26 * Y^12 * Z^12 - 54 * Y^12 * Z^11 - 84 * Y^12 * Z^10 - 150 * Y^12 * Z^9 - 276 * Y^12 * Z^8 - 366 * Y^12 * Z^7 - 254 * Y^12 * Z^6 + 66 * Y^12 * Z^5 + 360 * Y^12 * Z^4 + 414 * Y^12 * Z^3 + 264 * Y^12 * Z^2 + 96 * Y^12 * Z + 16 * Y^12 + 2 * Y^11 * Z^14 - 36 * Y^11 * Z^13 - 235 * Y^11 * Z^12 - 590 * Y^11 * Z^11 - 750 * Y^11 * Z^10 - 308 * Y^11 * Z^9 + 711 * Y^11 * Z^8 + 1770 * Y^11 * Z^7 + 2019 * Y^11 * Z^6 + 922 * Y^11 * Z^5 - 792 * Y^11 * Z^4 - 1642 * Y^11 * Z^3 - 1240 * Y^11 * Z^2 - 480 * Y^11 * Z - 80 * Y^11 - Y^10 * Z^15 - 44 * Y^10 * Z^14 - 222 * Y^10 * Z^13 - 523 * Y^10 * Z^12 - 743 * Y^10 * Z^11 - 684 * Y^10 * Z^10 - 223 * Y^10 * Z^9 + 795 * Y^10 * Z^8 + 2058 * Y^10 * Z^7 + 2449 * Y^10 * Z^6 + 1232 * Y^10 * Z^5 - 672 * Y^10 * Z^4 - 1622 * Y^10 * Z^3 - 1240 * Y^10 * Z^2 - 480 * Y^10 * Z - 80 * Y^10 - 20 * Y^9 * Z^15 - 76 * Y^9 * Z^14 - 90 * Y^9 * Z^13 - 18 * Y^9 * Z^12 - 138 * Y^9 * Z^11 - 684 * Y^9 * Z^10 - 1018 * Y^9 * Z^9 - 88 * Y^9 * Z^8 + 1806 * Y^9 * Z^7 + 2738 * Y^9 * Z^6 + 1542 * Y^9 * Z^5 - 552 * Y^9 * Z^4 - 1602 * Y^9 * Z^3 - 1240 * Y^9 * Z^2 - 480 * Y^9 * Z - 80 * Y^9 + Y^8 * Z^16 - 64 * Y^8 * Z^15 - 373 * Y^8 * Z^14 - 856 * Y^8 * Z^13 - 877 * Y^8 * Z^12 + 88 * Y^8 * Z^11 + 1680 * Y^8 * Z^10 + 2968 * Y^8 * Z^9 + 2781 * Y^8 * Z^8 + 314 * Y^8 * Z^7 - 2900 * Y^8 * Z^6 - 3648 * Y^8 * Z^5 - 1472 * Y^8 * Z^4 + 718 * Y^8 * Z^3 + 1080 * Y^8 * Z^2 + 480 * Y^8 * Z + 80 * Y^8 - 2 * Y^7 * Z^17 - 64 * Y^7 * Z^16 - 308 * Y^7 * Z^15 - 630 * Y^7 * Z^14 - 622 * Y^7 * Z^13 - 156 * Y^7 * Z^12 + 558 * Y^7 * Z^11 + 1686 * Y^7 * Z^10 + 2916 * Y^7 * Z^9 + 2318 * Y^7 * Z^8 - 1112 * Y^7 * Z^7 - 4496 * Y^7 * Z^6 - 4116 * Y^7 * Z^5 - 656 * Y^7 * Z^4 + 1916 * Y^7 * Z^3 + 1872 * Y^7 * Z^2 + 768 * Y^7 * Z + 128 * Y^7 + Y^6 * Z^18 - 16 * Y^6 * Z^17 - 38 * Y^6 * Z^16 + 132 * Y^6 * Z^15 + 541 * Y^6 * Z^14 + 414 * Y^6 * Z^13 - 902 * Y^6 * Z^12 - 1874 * Y^6 * Z^11 - 26 * Y^6 * Z^10 + 3544 * Y^6 * Z^9 + 4061 * Y^6 * Z^8 - 270 * Y^6 * Z^7 - 4787 * Y^6 * Z^6 - 4584 * Y^6 * Z^5 - 848 * Y^6 * Z^4 + 1884 * Y^6 * Z^3 + 1872 * Y^6 * Z^2 + 768 * Y^6 * Z + 128 * Y^6 - 44 * Y^5 * Z^17 - 232 * Y^5 * Z^16 - 444 * Y^5 * Z^15 - 176 * Y^5 * Z^14 + 748 * Y^5 * Z^13 + 1712 * Y^5 * Z^12 + 2096 * Y^5 * Z^11 + 1356 * Y^5 * Z^10 - 1244 * Y^5 * Z^9 - 4336 * Y^5 * Z^8 - 4180 * Y^5 * Z^7 - 324 * Y^5 * Z^6 + 2748 * Y^5 * Z^5 + 2320 * Y^5 * Z^4 + 512 * Y^5 * Z^3 - 288 * Y^5 * Z^2 - 192 * Y^5 * Z - 32 * Y^5 - Y^4 * Z^19 - 36 * Y^4 * Z^18 - 158 * Y^4 * Z^17 - 265 * Y^4 * Z^16 - 160 * Y^4 * Z^15 - 32 * Y^4 * Z^14 - 25 * Y^4 * Z^13 + 770 * Y^4 * Z^12 + 2683 * Y^4 * Z^11 + 3037 * Y^4 * Z^10 - 565 * Y^4 * Z^9 - 5025 * Y^4 * Z^8 - 4922 * Y^4 * Z^7 - 497 * Y^4 * Z^6 + 2820 * Y^4 * Z^5 + 2368 * Y^4 * Z^4 + 520 * Y^4 * Z^3 - 288 * Y^4 * Z^2 - 192 * Y^4 * Z - 32 * Y^4 + 2 * Y^3 * Z^20 + 4 * Y^3 * Z^19 + 45 * Y^3 * Z^18 + 286 * Y^3 * Z^17 + 642 * Y^3 * Z^16 + 202 * Y^3 * Z^15 - 1587 * Y^3 * Z^14 - 2686 * Y^3 * Z^13 - 240 * Y^3 * Z^12 + 4030 * Y^3 * Z^11 + 4238 * Y^3 * Z^10 - 1108 * Y^3 * Z^9 - 5533 * Y^3 * Z^8 - 3486 * Y^3 * Z^7 + 1823 * Y^3 * Z^6 + 3882 * Y^3 * Z^5 + 1768 * Y^3 * Z^4 - 642 * Y^3 * Z^3 - 1080 * Y^3 * Z^2 - 480 * Y^3 * Z - 80 * Y^3 - 10 * Y^2 * Z^19 - 44 * Y^2 * Z^18 - 40 * Y^2 * Z^17 + 148 * Y^2 * Z^16 + 460 * Y^2 * Z^15 + 544 * Y^2 * Z^14 + 254 * Y^2 * Z^13 - 318 * Y^2 * Z^12 - 1258 * Y^2 * Z^11 - 2018 * Y^2 * Z^10 - 1108 * Y^2 * Z^9 + 1306 * Y^2 * Z^8 + 2552 * Y^2 * Z^7 + 1334 * Y^2 * Z^6 - 418 * Y^2 * Z^5 - 872 * Y^2 * Z^4 - 432 * Y^2 * Z^3 - 80 * Y^2 * Z^2 - 6 * Y * Z^20 - 20 * Y * Z^19 + 2 * Y * Z^18 + 94 * Y * Z^17 + 106 * Y * Z^16 - 42 * Y * Z^15 + 112 * Y * Z^14 + 784 * Y * Z^13 + 746 * Y * Z^12 - 1040 * Y * Z^11 - 2768 * Y * Z^10 - 1716 * Y * Z^9 + 1318 * Y * Z^8 + 2770 * Y * Z^7 + 1442 * Y * Z^6 - 398 * Y * Z^5 - 872 * Y * Z^4 - 432 * Y * Z^3 - 80 * Y * Z^2 + Z^22 + 6 * Z^21 + 37 * Z^20 + 132 * Z^19 + 191 * Z^18 - 156 * Z^17 - 927 * Z^16 - 972 * Z^15 + 822 * Z^14 + 2938 * Z^13 + 2097 * Z^12 - 1862 * Z^11 - 4500 * Z^10 - 2504 * Z^9 + 1617 * Z^8 + 3228 * Z^7 + 1614 * Z^6 - 378 * Z^5 - 872 * Z^4 - 432 * Z^3 - 80 * Z^2, Y^15 + 5 * Y^12 * Z^2 - 6 * Y^12 + 10 * Y^9 * Z^4 - 20 * Y^9 * Z^2 + 10 * Y^9 - 3 * Y^8 * Z^3 + 3 * Y^8 + 10 * Y^6 * Z^6 - 30 * Y^6 * Z^4 + 30 * Y^6 * Z^2 - 10 * Y^6 - 3 * Y^4 * Z^6 + 6 * Y^4 * Z^3 - 3 * Y^4 + 5 * Y^3 * Z^8 - 20 * Y^3 * Z^6 + 30 * Y^3 * Z^4 - 20 * Y^3 * Z^2 + 5 * Y^3 + Z^10 - Z^9 - 5 * Z^8 + 13 * Z^6 - 10 * Z^4 - 3 * Z^3 + 5 * Z^2 ]")
+
+(dribble)
+#+kcl(setf *evalhook* nil)
Index: /trunk/tests/ratpoly-tests.lisp
===================================================================
--- /trunk/tests/ratpoly-tests.lisp	(revision 14)
+++ /trunk/tests/ratpoly-tests.lisp	(revision 14)
@@ -0,0 +1,129 @@
+#|
+	$Id: ratpoly-tests.lisp,v 1.1 2009/01/19 18:19:46 marek Exp $	
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+;; Tests of the ratpoly package
+;; Example of exercise 3.6.1
+;; f = x^2*y-3*x*y^2+x^2-3*x*y
+;; g = x^3*y-4*y^2+y+x^3-4*y+1
+;;(require "parse")
+;;(require "monom")
+;;(require "printer")
+;;(require "ratpoly")
+;;(use-package '("parse" "monom" "printer" "ratpoly"))
+
+;; The value of this variable is a function that will do evaluation
+;; instead of eval; this one just prints what it is evaluating and calls eval
+(setf *evalhook* 
+      #'(lambda (form env)
+	  (format t "~&EVAL> ~a~%" form)
+	  (format t "~&VALUE--> ~a~2%" (eval form))
+	  ))
+
+(dribble "ratpoly-tests.output")
+(setf f (parse-string-to-sorted-alist "x^2*y-3*x*y^2+x^2-3*x*y" '(x y)))
+(setf g (parse-string-to-sorted-alist "x^3*y-4*y^2+y+x^3-4*y+1" '(x y)))
+
+(princ ";; Print the polynomials")
+(terpri)
+(poly-print f '(x y))
+(poly-print g '(x y))
+(terpri)
+
+(princ ";; Convert the polynomials to RATPOLY form")
+(terpri)
+(setf rf (poly-to-ratpoly f))
+(setf rg (poly-to-ratpoly g))
+
+(princ ";; Print converted polynomials")
+(terpri)
+(ratpoly-print rf '(x y))
+(ratpoly-print rg '(x y))
+(terpri)
+
+(princ ";; Calculate the resultant")
+(terpri)
+(setf res (ratpoly-resultant rf rg))
+(ratpoly-print res '(x y))
+(setf res (ratpoly-to-poly res))
+(poly-print res '(x y))
+(terpri)
+
+(princ ";; Calculate the discriminant of f")
+(terpri)
+(setf disc (ratpoly-discriminant rf))
+(ratpoly-print disc '(x y))
+(terpri)
+(setf disc (ratpoly-to-poly disc))
+(poly-print disc '(x y))
+(terpri)
+
+(princ ";; Exercise 3.6.4 of Cox-Little-O'Shea")
+(terpri)
+(setf f (parse-string-to-sorted-alist "x^2*y-3*x-1" '(x y)))
+(setf g (parse-string-to-sorted-alist "6*x^2+y^2-4" '(x y)))
+(setf rf (poly-to-ratpoly f))
+(setf rg (poly-to-ratpoly g))
+(setf res (ratpoly-resultant rf rg))
+(setf res (ratpoly-to-poly res))
+(poly-print res '(x y))
+(terpri)
+(setf res (poly-resultant f g))
+(poly-print res '(x y))
+(terpri)
+(princ ";; Check that the package works on poly's in 1 variable")
+(terpri)
+(princ ";; Exercise 3.6.8 of Cox-Little-O'Shea")
+(terpri)
+(princ ";; Maple answer:")
+(setf f (parse-string-to-sorted-alist "6*x^4-23*x^3+32*x^2-19*x+4" '(x)))
+(setf rf (poly-to-ratpoly f))
+(setf rg (ratpoly-diff rf))
+(setf g (ratpoly-to-poly rg))
+(setf res (ratpoly-resultant rf rg))
+(setf res (ratpoly-to-poly res))
+(poly-print res '(x))
+(terpri)
+(setf res (poly-resultant f g))
+(poly-print res '(x))
+(terpri)
+(princ ";; Yes! it works on one variable as well")
+(terpri)
+
+(princ ";; The previous exercise repeated for some random polynomial")
+(terpri)
+(princ ";; Exercise 3.6.8 of Cox-Little-O'Shea")
+(terpri)
+(princ ";; Maple answer:")
+(setf f (parse-string-to-sorted-alist "6*x^4+23*x^3-30*x^2-19*x+4" '(x)))
+(setf rf (poly-to-ratpoly f))
+(setf rg (ratpoly-diff rf))
+(setf g (ratpoly-to-poly rg))
+(setf res (ratpoly-resultant rf rg))
+(setf res (ratpoly-to-poly res))
+(poly-print res '(x))
+(terpri)
+(setf res (poly-resultant f g))
+(poly-print res '(x))
+(terpri)
+(princ ";; Maple answer: 13867656600")
+(terpri)
+(setf disc (ratpoly-discriminant rf))
+(ratpoly-print disc '(x y))
+(terpri)
+(setf disc (ratpoly-to-poly disc))
+(poly-print disc '(x y))
+(terpri)
+(princ ";; Maple equivalent is discrim(f,x)")
+(terpri)
+(princ ";; and yields: 2311276100")
+(terpri)
+
+(dribble)
+(setf *evalhook* nil)
Index: /trunk/tests/tests.lisp
===================================================================
--- /trunk/tests/tests.lisp	(revision 14)
+++ /trunk/tests/tests.lisp	(revision 14)
@@ -0,0 +1,135 @@
+#|
+  SccsId="@(#)tests.lisp, version 1.7 of 5/14/94(11:23:03)
+  *--------------------------------------------------------------------------*
+  |  Copyright (C) 1994, Marek Rychlik (e-mail: rychlik@math.arizona.edu)    |
+  |    Department of Mathematics, University of Arizona, Tucson, AZ 85721    |
+  |                                                                          |
+  | Everyone is permitted to copy, distribute and modify the code in this    |
+  | directory, as long as this copyright note is preserved verbatim.         |
+  *--------------------------------------------------------------------------*
+|#
+
+;;(load "grobner-front-end")
+
+(defun run (test) 
+  (format t "Test ~a ~:[failed~;succeeded~]...~%" test (time (funcall test))))
+
+(defun test-1 ()
+  (let* ((vars '(x y)))
+    (equalp
+     (mapcar #'(lambda (pred)
+		 (let* ((f (poly "4*x^2-3*x*y" vars pred))
+			(g (poly "4*x+5*y" vars pred)))
+		   (spoly f g pred)))
+	     (list #'lex> #'grlex> #'grevlex>))
+     (list
+      (poly "-32*x*y" vars #'lex>)
+      (poly "-32*x*y" vars #'grlex>)
+      (poly "-32*x*y" vars #'grevlex>)))))
+
+(defun test-2 ()
+  (let* ((vars '(x y z)))
+    (equalp
+     (mapcar #'(lambda (pred)
+		 (let* ((f (poly "4*x^5-3*x*y-z^2" vars pred))
+			(g (poly-list "[4*x^3+5*y+z^2,y^2+z]" vars pred)))
+		   (normal-form f g pred)))
+	     (list #'lex> #'grlex> #'grevlex>))
+     (list
+      (poly "-5*x^2*y-x^2*z^2-3*x*y-z^2" vars #'lex>)
+      (poly "-X^2*Z^2-5*X^2*Y-3*X*Y-Z^2" vars #'grlex>)
+      (poly "-X^2*Z^2-5*X^2*Y-3*X*Y-Z^2" vars #'grevlex>)))))
+
+
+;; Find the equation of the Enneper surface
+(defun test-3 ()
+  (let* ((vars '(u v x y z))
+	 (eqns (poly-list
+		"[x-3*u-3*u*v^2+u^3,y-3*v-3*u^2*v+v^3,z-3*u^2+3*v^2]"
+		vars))
+	 (ans (poly-list
+	       "[X^6 - 3 * X^4 * Y^2 + 5/9 * X^4 * Z^3 + 6 * X^4 * Z^2 - 3 *
+	       X^4 * Z + 3 * X^2 * Y^4 + 26/9 * X^2 * Y^2 * Z^3 + 6 * X^2 *
+	       Y^2 * Z + 16/243 * X^2 * Z^6 + 16/9 * X^2 * Z^5 + 80/9 * X^2 *
+	       Z^4 - 16 * X^2 * Z^3 - Y^6 + 5/9 * Y^4 * Z^3 - 6 * Y^4 * Z^2 -
+	       3 * Y^4 * Z - 16/243 * Y^2 * Z^6 + 16/9 * Y^2 * Z^5 - 80/9 *
+	       Y^2 * Z^4 - 16 * Y^2 * Z^3 - 64/19683 * Z^9 + 128/243 * Z^7 -
+	       64/3 * Z^5]"
+	       vars)))
+    (set-coefficient-ring nil)			;char=0
+    (equalp (elimination-ideal eqns 2) ans)))
+
+(defun test-4 ()
+  (let* ((vars '(x y))
+	 (id1 (poly-list "[x-y^2,y^2*x]" vars))
+	 (id2 (poly-list "[x^2-x*y^2,y^2]" vars))
+	 (ans (poly-list "[x^2,y^4,x*y^2]" vars)))
+    (equalp (ideal-intersection id1 id2) ans)))
+    
+(defun test-5 ()
+  (let* ((vars '(x y z))
+	 (f (poly-list "[x^5+y^4+z^3-1, x^3+y^2+z^2-1]" vars))
+	 (ans (poly-list
+	       "[ X^2 * Z^4 + X^2 * Z^3 - 2 * X^2 * Z^2 - 1/6 * X * Z^10 - 2/3
+	       * X * Z^9 - 1/4 * X * Z^8 + 7/6 * X * Z^7 - 1/12 * X * Z^6 - X
+	       * Z^5 + X * Z^4 + 1/2 * Y^10 * Z^2 + 1/3 * Y^10 * Z - 5/12 *
+	       Y^10 - 1/6 * Y^8 * Z^4 + 1/3 * Y^8 * Z^3 + 1/4 * Y^8 * Z^2 +
+	       1/2 * Y^8 + Y^6 * Z^5 - 5/3 * Y^6 * Z^4 - 17/6 * Y^6 * Z^3 +
+	       17/6 * Y^6 * Z^2 + 2/3 * Y^6 * Z - 1/3 * Y^6 - 1/3 * Y^4 * Z^7
+	       - 7/2 * Y^4 * Z^6 - 3 * Y^4 * Z^5 + 131/12 * Y^4 * Z^4 + 23/4 *
+	       Y^4 * Z^3 - 13 * Y^4 * Z^2 - 8/3 * Y^4 * Z + 29/6 * Y^4 - 17/6
+	       * Y^2 * Z^8 - 4 * Y^2 * Z^7 + 119/12 * Y^2 * Z^6 + 17/2 * Y^2 *
+	       Z^5 - 16 * Y^2 * Z^4 - 14/3 * Y^2 * Z^3 + 12 * Y^2 * Z^2 + 5/3
+	       * Y^2 * Z - 55/12 * Y^2 - 7/6 * Z^10 - 7/6 * Z^9 + 55/12 * Z^8
+	       + 21/4 * Z^7 - 31/4 * Z^6 - 15/2 * Z^5 + 83/12 * Z^4 + 41/12 *
+	       Z^3 - 31/12 * Z^2, X * Y^2 * Z - X * Y^2 - 1/8 * X * Z^10 -
+	       7/24 * X * Z^9 + 1/2 * X * Z^8 + 7/8 * X * Z^7 - 23/24 * X *
+	       Z^6 + 1/2 * X * Z^4 - 1/2 * X * Z^3 - X * Z + X + 3/8 * Y^10 *
+	       Z^2 - 3/8 * Y^10 * Z - 7/24 * Y^10 - 1/8 * Y^8 * Z^4 + 11/24 *
+	       Y^8 * Z^3 - 3/8 * Y^8 * Z^2 + 1/4 * Y^8 * Z - 1/4 * Y^8 + 3/4 *
+	       Y^6 * Z^5 - 5/2 * Y^6 * Z^4 + 5/6 * Y^6 * Z^3 + 31/12 * Y^6 *
+	       Z^2 - Y^6 * Z - 1/3 * Y^6 - 1/4 * Y^4 * Z^7 - 53/24 * Y^4 * Z^6
+	       + 11/6 * Y^4 * Z^5 + 113/12 * Y^4 * Z^4 - 55/8 * Y^4 * Z^3 -
+	       29/4 * Y^4 * Z^2 + 15/4 * Y^4 * Z + 19/12 * Y^4 - 17/8 * Y^2 *
+	       Z^8 + 13/24 * Y^2 * Z^7 + 239/24 * Y^2 * Z^6 - 59/12 * Y^2 *
+	       Z^5 - 151/12 * Y^2 * Z^4 + 85/12 * Y^2 * Z^3 + 43/8 * Y^2 * Z^2
+	       - 29/8 * Y^2 * Z + 7/24 * Y^2 - 7/8 * Z^10 + 7/12 * Z^9 + 31/8
+	       * Z^8 - 11/12 * Z^7 - 103/12 * Z^6 + 17/6 * Z^5 + 127/24 * Z^4
+	       - 3/2 * Z^3 - 17/24 * Z^2 + Z - 1, X * Z^11 + 4 * X * Z^10 + X
+	       * Z^9 - 10 * X * Z^8 - 4 * X * Z^7 + 8 * X * Z^6 - 3 * Y^10 *
+	       Z^3 - 2 * Y^10 * Z^2 + 4 * Y^10 * Z + 4 * Y^10 + Y^8 * Z^5 - 2
+	       * Y^8 * Z^4 - 2 * Y^8 * Z^3 - 6 * Y^6 * Z^6 + 10 * Y^6 * Z^5 +
+	       20 * Y^6 * Z^4 - 16 * Y^6 * Z^3 - 24 * Y^6 * Z^2 + 8 * Y^6 * Z
+	       + 8 * Y^6 + 2 * Y^4 * Z^8 + 21 * Y^4 * Z^7 + 17 * Y^4 * Z^6 -
+	       78 * Y^4 * Z^5 - 64 * Y^4 * Z^4 + 90 * Y^4 * Z^3 + 76 * Y^4 *
+	       Z^2 - 32 * Y^4 * Z - 32 * Y^4 + 17 * Y^2 * Z^9 + 24 * Y^2 * Z^8
+	       - 68 * Y^2 * Z^7 - 80 * Y^2 * Z^6 + 106 * Y^2 * Z^5 + 108 * Y^2
+	       * Z^4 - 77 * Y^2 * Z^3 - 70 * Y^2 * Z^2 + 20 * Y^2 * Z + 20 *
+	       Y^2 + 7 * Z^11 + 7 * Z^10 - 31 * Z^9 - 42 * Z^8 + 55 * Z^7 + 77
+	       * Z^6 - 39 * Z^5 - 62 * Z^4 + 8 * Z^3 + 20 * Z^2, Y^12 - Y^10 +
+	       3 * Y^8 * Z^3 - 5 * Y^8 * Z^2 + 2 * Y^8 - 10 * Y^6 * Z^4 + 20 *
+	       Y^6 * Z^2 - 10 * Y^6 - 7 * Y^4 * Z^6 + 30 * Y^4 * Z^4 - 6 * Y^4
+	       * Z^3 - 30 * Y^4 * Z^2 + 13 * Y^4 - 5 * Y^2 * Z^8 + 20 * Y^2 *
+	       Z^6 - 30 * Y^2 * Z^4 + 20 * Y^2 * Z^2 - 5 * Y^2 - Z^10 + Z^9 +
+	       5 * Z^8 - 13 * Z^6 + 10 * Z^4 + 3 * Z^3 - 5 * Z^2, X * Y^4 + X
+	       * Z^3 - X + Y^4 + 2 * Y^2 * Z^2 - 2 * Y^2 + Z^4 - 2 * Z^2 + 1,
+	       X^2 * Y^2 + X^2 * Z^2 - X^2 - Y^4 - Z^3 + 1, X^3 + Y^2 + Z^2 -
+	       1 ]" vars)))
+    (equalp (grobner f :reduce t) ans)))
+
+(defun test-6 ()
+  (let* ((vars '(x y z))
+	 (f (poly-list "[x^5+y^4+z^3-1,x^3+y^3+z^2-1]" vars))
+	 (ans (poly-list "[x]" vars)))		;unknown yet
+    (equalp (grobner f :reduce t) ans)))
+
+;;----------------------------------------------------------------
+
+(defun run-short-tests ()
+  (dolist (test '(test-1 test-2 test-4))
+    (run test)))
+
+(defun run-long-tests ()
+  (dolist (test '(test-3 test-5))
+    (run test)))
+
