(* ----------------------------------------------------------------------------
 * $Id: CGBSYS.mip,v 1.16 1996/06/08 16:47:15 pesch Exp $
 * ----------------------------------------------------------------------------
 * This file is part of MAS.
 * ----------------------------------------------------------------------------
 * Copyright (c) 1989 - 1996 Universitaet Passau
 * ----------------------------------------------------------------------------
 * $Log: CGBSYS.mip,v $
 * Revision 1.16  1996/06/08 16:47:15  pesch
 * Reformatted, removed obsolete procedures.
 *
 * Revision 1.15  1996/04/23 14:52:16  pesch
 * Corrected previous fix.
 *
 * Revision 1.14  1996/04/23 13:53:18  pesch
 * Fixed problems with zero polynomials for factorised GS, too.
 *
 * Revision 1.13  1996/04/16 19:18:25  pesch
 * Fixed three bugs, which caused zero (completely "green") polynomials
 * to be added to polynomial lists unneccessarily.
 *
 * Revision 1.12  1995/11/04 20:39:32  pesch
 * Renamed massignal.m? to massig.m? because of conflict with MASSIGNAL.m?
 * on certain OS.
 *
 * Revision 1.11  1995/09/12  17:35:57  pesch
 * Use massignal instead of mpsignal.
 *
 * Revision 1.10  1995/09/12  17:11:12  pesch
 * Fixed typos.
 *
 * Revision 1.9  1995/03/23  16:05:47  pesch
 * Added new data structure Colp for coloured polynomials.
 *
 * Revision 1.8  1995/03/06  15:49:38  pesch
 * Added new procedure GSYSF, Groebner system with factorization. This uses
 * the new procedures GBSYSF and CONSGBF (also added).
 *
 * Added new procedures DIP2AD, AD2DIP and DIPPFACTAV.
 *
 * Fixed error in CHECK.
 *
 * New option for factorization of conditions: factorize with optimization
 * of variable ordering.
 *
 * Revision 1.7  1994/04/14  16:46:13  dolzmann
 * Syntactical errors (founded by Mocka) corrected.
 *
 * Revision 1.6  1994/04/14  12:42:23  pesch
 * Defined Action according to POSIX.
 *
 * Revision 1.5  1994/04/12  13:41:57  pesch
 * Made signal handler for consgb a global procedure.
 * (Subprocedures cannot be used as arguments e.g. to signal.)
 *
 * Revision 1.4  1994/04/10  16:57:42  pesch
 * Modified CONSGB. Returns its result now. When a condition is ramified,
 * we continue with this new case distinction first. This is useful to
 * have the generic case computed first.
 *
 * Revision 1.3  1994/04/09  18:06:02  pesch
 * Reformatted parts of the CGB sources. Updated comments in CGB*.md.
 *
 * Revision 1.2  1994/03/14  16:43:00  pesch
 * Minor changes requested by A. Dolzmann
 *
 * Revision 1.1  1994/03/11  15:58:19  pesch
 * Major changes to CGB.
 * C-Preprocessor now used for .mip files. The corresponding .mi files have
 * been removed.
 * Many new CGB-Functions and fixes of old ones.
 *
 * Revision 1.2  1992/02/12  17:31:19  pesch
 * Moved CONST definition to the right place
 *
 * Revision 1.1  1992/01/22  15:09:31  kredel
 * Initial revision
 *
 * ----------------------------------------------------------------------------
 *)

#include "debug.h"

IMPLEMENTATION MODULE CGBSYS;

(* Comprehensive-Groebner-Bases System Implementation Module. *)

(* Derived from an ALDES program written by Elke Schoenfeld,
   Universitaet Passau, 1991. *)

(* Import lists and declarations. *)


FROM CGBDSTR	IMPORT	CdWrite, ColCons, ColConsCond, ColEmpty, ColIsEmpty,
			ColParts, ColWhite, ColpCol, ColpCons, ColpConsCond,
			ColpHT, ColpIsCnst, ColpIsZero, ColpParts, ColpPol,
			CondEmpty, CondIsEmpty, CondParts, CondWrite;

FROM CGBFUNC	IMPORT	ADDCON, AINB, CGBFRM, CGBLM, CGBLPM, DCLWR, DET,
			DETPOL, DWRIT, EQPLCL, FINDBC, FINDCP, FINDRM,
			GREPOL, MKPOL, REDSRT, SETCOL, VERIFY, WMEMB; 

FROM CGBMAIN	IMPORT	WRGBS;

FROM CGBMISC	IMPORT	CGBPAR, COLOUR, FLWRITE, PAR;

FROM DIPADOM	IMPORT	DIFIP, DILRD, DILWR, DIPBCP, DIPDIF, DIPEXP, DIPNEG,
			DIPROD, DIPSUM, DIREAD, DIWRIT;

FROM DIPC	IMPORT	DIPEVL, DIPFMO, DIPLBC, DIPLPM, DIPMAD, DIPMCP,
			DIPTDG, EVCOMP, EVDIF, EVLCM, EVMT, EVORD, EVSIGN,
			EVSUM, VALIS;

FROM DIPRNGB	IMPORT	EVPLM, EVPLSO;

FROM MASADOM	IMPORT	ADCNST, ADDDREAD, ADDDWRIT, ADDIF, ADEXP, ADFACT,
			ADFI, ADFIP, ADGCD, ADGCDC, ADINV, ADINVT, ADLCM,
			ADNEG, ADONE, ADPROD, ADQUOT, ADREAD, ADSIGN, ADSUM,
			ADTOIP, ADVLDD, ADWRIT, DomSummary;

FROM MASBIOS	IMPORT	BKSP, BLINES, CREAD, CREADB, CUNIT, DIGIT, LETTER,
			LISTS, MASORD, SOUNIT, SWRITE;

FROM MASERR	IMPORT	ERROR, fatal, harmless, severe, spotless;

FROM massig	IMPORT	Action, SIGUSR1, SIG_IGN, SIG_IGN, signal;

FROM MASSIGNAL  IMPORT	SigUsr1HandleDefault; (* MASSIGNAL must be
     	       	    	      	   	     	 initialized*)

FROM MASSTOR	IMPORT	ADV, COMP, FIRST, INV, LIST, LIST1, RED, SFIRST, SIL,
			SRED, TIME;

FROM SACLIST	IMPORT	ADV2, ADV3, AREAD, AWRITE, CINV, CLOUT, COMP2, COMP3,
			CONC, EQUAL, FIRST2, FIRST3, FIRST4, LAST, LIST2,
			LIST3, LIST4, LIST5, LWRITE, MEMBER, OWRITE, RED2,
			SECOND, THIRD;

FROM SYSTEM     IMPORT  ADR;

CONST rcsidi = "$Id: CGBSYS.mip,v 1.16 1996/06/08 16:47:15 pesch Exp $";
CONST copyrighti = "Copyright (c) 1989 - 1996 Universitaet Passau";


PROCEDURE GRED(COND,PCO,PCI,RE: LIST; VAR RCO,HA: LIST); 
(*Parametric reduction. COND is a condition, PCO and PCI are coloured
polynomials. PCI is determined by cond. RE is a term in PCO coloured
red or white by COND. RE is a multiple of the headterm (wrt cond) of PCI.
RCO is the result
of one step reduction of PCO ( by PCI ) to eliminate the term RE. HA
is the multiple factor of PCO. *)
VAR   AL, ALIST, AP, APP, C, EL, FCOL, FL, FPOL, GCOL, GPOL, HE,
      KEY, Q, RA, RAL, RAP, RCOLS, RPOL, TL: LIST; 
BEGIN
      DEB_BEGIN(GRED);
(*1*) (*Get polynomials and colours. Update colouring of PCI. *) 
      ColpParts(PCO, FPOL,FCOL);
      ColpParts(PCI, GPOL,GCOL); 
      IF NOT CondIsEmpty(COND) THEN GCOL:=SETCOL(COND,GCOL); END; 
      HE:=ColpHT(PCI);
      KEYCOL(RE,FCOL, KEY,ALIST);
      RCO:=SIL; Q:=SIL; 
(*2*) (*Prepare PCO and PCI for reduction. *)
      RA:=FINDBC(RE,FPOL); 
      IF HE = SIL THEN 	     	   (* ---to do---: ok? *)
        HA:=ADFI(RA,0);
     	EL:=RE;
      ELSE
        HA:=FINDBC(HE,GPOL);
	EL:=EVDIF(RE,HE);
      END;
      ADV(RA, RAL,RAP); 
      FL:=FIRST(RAP); 
      TL:=EVSIGN(EL); 
(*3*) (*If RA is coloured red reduce with gcd of RA and HA.
        If RA is coloured white reduce with product of RA and HA. *) 
      IF ALIST <> SIL THEN
        AP:=DIPFMO(RA,EL);
        APP:=DIPROD(GPOL,AP); 
        FPOL:=DIPBCP(FPOL,HA);
        GCOL:=WHSRT(GCOL,EL,ALIST);
       ELSE
         ADGCDC(RA,HA, C,RA,HA);
         AP:=DIPFMO(RA,EL); 
         (* Note: if gcd is not defined for the current domain, AL and BL
            remain unchanged by definiton of ADGCDC *)
         APP:=DIPROD(GPOL,AP);
         FPOL:=DIPBCP(FPOL,HA); 
         IF TL <> 0 THEN GCOL:=COLPRD(GCOL,EL); END; 
       END; 
       GBDIFF(COND,FPOL,FCOL,APP,GCOL, RPOL,RCOLS); 
       IF RPOL <> 0 THEN
         AL:=DIPLBC(RPOL);
         IF ADSIGN(AL) = -1 THEN RPOL:=DIPNEG(RPOL); END; 
         IF NOT ColIsEmpty(RCOLS) THEN RCO:=ColpCons(RPOL,RCOLS); END; 
       END; 
(*6*) RETURN;
END GRED; 


PROCEDURE GBDIFF(COND,A,ACOLS,B,BCOLS: LIST; VAR C,CCOLS: LIST); 
(*Parametric difference. COND is a condition. A and B are polynomials.
ACOLS is the colouring of A wrt cond, BCOLS is the colouring of B wrt
COND. C=A-B. CCOLS is the colouring of C wrt COND. *)
VAR   AKEY, AL, ALIST, APP, BKEY, BL, BLIST, CL, CP,
      CPP, EL, FL, R, SL, W: LIST; 
BEGIN
      DEB_BEGIN(GBDIFF);
(*1*) (*A or B zero. *) 
      IF A = 0 THEN C:=B; CCOLS:=BCOLS; RETURN; END; 
      IF B = 0 THEN C:=A; CCOLS:=ACOLS; RETURN; END; 
(*2*) (*Match coefficients. *)
      CP:=SIL; R:=SIL; W:=SIL; 
      REPEAT
            EL:=DIPEVL(A);
            FL:=DIPEVL(B);
            SL:=EVCOMP(EL,FL); 
            IF SL = 1 THEN
                 DIPMAD(A, AL,EL,A); 
                 COLDIF(EL,ACOLS,R,W, R,W);
                 CP:=DIPMCP(EL,AL,CP);
            ELSIF SL = -1 THEN
                 DIPMAD(B, BL,FL,B); 
                 COLDIF(FL,BCOLS,R,W, R,W);
                 CL:=ADNEG(BL); 
                 CP:=DIPMCP(FL,CL,CP);
            ELSE 
                 DIPMAD(A, AL,EL,A); 
                 DIPMAD(B, BL,FL,B);
                 CL:=ADDIF(AL,BL); 
                 IF ADSIGN(CL) <> 0 THEN
                   CP:=DIPMCP(EL,CL,CP); 
                   KEYCOL(EL,ACOLS, AKEY,ALIST); 
                   KEYCOL(FL,BCOLS, BKEY,BLIST); 
                   IF (AKEY <> 0) AND (BKEY = 0) THEN
                     MKACOL(ALIST,EL,R,W, R,W); END; 
                   IF (AKEY = 0) AND (BKEY <> 0) THEN
                     MKACOL(BLIST,EL,R,W, R,W); END; 
                   IF (AKEY <> 0) AND (BKEY <> 0) THEN
                      MKCOL(COND,CL,EL,R,W, R,W); END; 
                 END; 
            END; 
      UNTIL (A = SIL) OR (B = SIL); 
(*3*) (*Finish. *) 
      APP:=A; 
      IF A <> SIL THEN FINCOL(A,ACOLS,R,W, R,W); END; 
      IF B <> SIL THEN FINCOL(B,BCOLS,R,W, R,W); END; 
      IF A = SIL THEN IF B <> SIL THEN APP:=DIPNEG(B); END; END; 
      IF CP = SIL THEN C:=APP; ELSE CPP:=CP; C:=INV(CP); SRED(CPP,APP); END; 

(*4*)(* IF C = SIL THEN
        C:=0;
        CCOLS:=SIL;
      ELSE
        IF (R <> SIL) OR (W <> SIL) THEN
          IF R <> SIL THEN R:=INV(R); END;
          IF W <> SIL THEN W:=INV(W); END;
          CCOLS:=LIST2(R,W); ELSE CCOLS:=SIL;
        END;
      END;

*)
(*4*) IF C = SIL THEN 
        C:=0;
        CCOLS:=ColEmpty(); (* ---CHANGED--- *)
      ELSE
          IF R <> SIL THEN R:=INV(R); END; (* ---CHANGED--- *)
          IF W <> SIL THEN W:=INV(W); END; 
          CCOLS:=ColCons(R,W);
      END; 

(*7*) RETURN;
END GBDIFF; 


PROCEDURE COLPRD(COL1,TTERM: LIST): LIST; 
(*Colour product. COL1 contains a list of red terms and a list of white
terms. TTERM is a term. Every term in COL1 is multiplied with TTERM.*)
VAR   CRED, CWHITE: LIST; 
BEGIN
      DEB_BEGIN(COLPRD);
(*1*) (*Case COL1 empty. *)
      IF ColIsEmpty(COL1) THEN RETURN(ColEmpty()); END; 
(*2*) (*Multiplication. *)
      ColParts(COL1, CRED,CWHITE); 
      IF CRED <> SIL THEN CRED:=CMULT(CRED,TTERM,1); END; 
      IF CWHITE <> SIL THEN CWHITE:=CMULT(CWHITE,TTERM,2); END; 
(*3*) (*Finish. *) 
      RETURN(ColCons(CRED,CWHITE));
END COLPRD; 


PROCEDURE CMULT(ONECL,TTERM,B: LIST): LIST; 
(*Colour multiplication.
If B=1 then ONECL is a list of (red) terms.
If B=2 then ONECL is a list of pairs, each containing a (white) term
and the white part of its coefficient.
TTERM is a term. Every term in ONECL is multiplicated with TTERM.
CCOL is the result. *)
VAR   CCOL, CELEM, QLIST, T, TELEM: LIST; 
BEGIN
      DEB_BEGIN(CMULT);
(*1*) CCOL:=SIL; 
(*2*) (*Multiplication of terms. *) 
      WHILE ONECL <> SIL DO
           ADV(ONECL, TELEM,ONECL); 
           IF B = 2 THEN FIRST2(TELEM, T,QLIST); ELSE T:=TELEM; END; 
           T:=EVSUM(TTERM,T); 
           IF B = 2 THEN CELEM:=LIST2(T,QLIST); CCOL:=COMP(CELEM,CCOL);
                    ELSE CCOL:=COMP(T,CCOL); END; 
      END; 
(*6*) RETURN(INV(CCOL));
END CMULT; 


PROCEDURE WHSRT(COL,TTERM,ALIST: LIST): LIST; 
(*White sort. COL contains a list of red terms and a list of white terms.
The form of COL is
((r1,... ,rn),((w1,(wp11,; ,wp1s)),... ,(wm,(wpm1,; ,wpms)))).
TTERM is a term. ALIST is a list of coefficients.
The form of ALIST is (a1,... ,at).
Every term of COL is multiplied with TTERM. The resulting terms are
coloured white by adding ALIST to its white part. The list of red terms
is empty. The list of white terms z is as follows
( (r1*tterm,(a1,... ,at)),... ,(rn*tterm,(a1,... ,at)),
(w1*tterm,(a1,... ,at,wp11,... ,wp1s)),... ,
(wm*tterm,(a1,... ,at,wpm1,... ,wpms)) ).
CWHIT0  contains the same terms as z in a nondecreasing order.
COLS is pair containg an empty list of red terms and the list CWHIT0. *)
VAR   AL, BL, BLIST, CP, CRED, CWHIT0, CWHITE, CWHITP, SL: LIST; 
BEGIN
      DEB_BEGIN(WHSRT);
(*1*) (*Get red and white terms. *)
      IF ColIsEmpty(COL) THEN RETURN(ColEmpty()); END;
      FIRST2(COL, CRED,CWHITE);
      CWHIT0:=SIL; 
(*2*) (*Match terms. *) 
      IF (CWHITE <> SIL) AND (CRED <> SIL) THEN (* --- to do ---: OK? *)
        REPEAT
              ADV(CRED, AL,CRED);
              REPEAT
                    ADV(CWHITE, CP,CWHITP);
                    FIRST2(CP, BL,BLIST); 
                    SL:=EVCOMP(AL,BL); 
                    IF SL = 1 THEN
                      CWHIT0:=COMP(LIST2(EVSUM(TTERM,AL),ALIST),CWHIT0);
                    ELSE
                      CWHIT0:=COMP(LIST2(EVSUM(TTERM,BL),WUPD(ALIST,BLIST)),
                                   CWHIT0);
                      CWHITE:=CWHITP;
                    END; 
              UNTIL (SL = 1) OR (CWHITE = SIL); 
              IF SL <= 0
                THEN CWHIT0:=COMP(LIST2(EVSUM(TTERM,AL),ALIST),CWHIT0); END; 
         UNTIL (CRED = SIL) OR (CWHITE = SIL); 
      END; 
(*3*) (*No more terms left. *) 
      IF (CWHITE=SIL) AND (CRED=SIL) THEN RETURN(LIST2(SIL,INV(CWHIT0))); END; 
(*4*) (*Red terms left. *) 
      WHILE CRED <> SIL DO 
           ADV(CRED, AL,CRED);
           CWHIT0:=COMP(LIST2(EVSUM(TTERM,AL),ALIST),CWHIT0);
      END; 
(*5*) (*White terms left. *) 
      WHILE CWHITE <> SIL DO
           ADV(CWHITE, CP,CWHITE);
           FIRST2(CP, BL,BLIST);
           CWHIT0:=COMP(LIST2(EVSUM(TTERM,BL),WUPD(ALIST,BLIST)),CWHIT0);
       END; 
(*9*) RETURN(LIST2(SIL,INV(CWHIT0)));
END WHSRT; 


PROCEDURE WUPD(ALIST,BLIST: LIST): LIST; 
(*White part update. ALIST and BLIST are sets of coefficients.
Returns the union of ALIST and BLIST. *)
VAR   A, CLIST, SL: LIST; 
BEGIN
      DEB_BEGIN(WUPD);
(*1*) IF ALIST = BLIST THEN RETURN(BLIST); END; 
      IF BLIST = SIL THEN RETURN(ALIST) END;
      CLIST:=BLIST;
(*2*) WHILE ALIST <> SIL DO
           ADV(ALIST, A,ALIST);
           IF MEMBER(A,BLIST) = 0 THEN CLIST:=COMP(A,CLIST); END; 
      END; 
(*5*) RETURN(CLIST);
END WUPD; 


PROCEDURE COLDIF(T,ACOLS,COLR,COLW: LIST; VAR CRED,CWHITE: LIST); 
(*Colour difference. T is term. ACOLS contains a list of red terms
and a list of white terms. COLR is a list of red terms. COLW is
a list of white terms.
If T is member of the red terms in ACOLS, it is added to COLR. The
result is CRED.
If T is member of the white terms in ACOLS, it is added to COLW with
its white part. The result is CWHITE. *)
VAR   ACRED, ACWHIT, CP: LIST; 
BEGIN
      DEB_BEGIN(COLDIF);
(*1*) FIRST2(ACOLS, ACRED,ACWHIT);
      CRED:=COLR;
      CWHITE:=COLW; 
(*2*) IF MEMBER(T,ACRED)=1 THEN CRED:=COMP(T,CRED); RETURN; END;
      CP:=FINDCP(T,ACWHIT);
      IF CP <> SIL THEN CWHITE:=COMP(CP,CWHITE); END; 
(*5*) RETURN;
END COLDIF; 


PROCEDURE KEYCOL(EL,ACOLS: LIST; VAR KEY,ALIST: LIST); 
(*Key colour. EL is a term.
ACOLS contains a list of red terms and a list of white terms.
If EL is member of the red terms in ACOLS then KEY=1 and ALIST is empty.
If EL is member of the white terms in ACOLS then KEY=2 and ALIST is
the white part of EL.
If EL is not in ACOLS (EL is coloured green) then KEY=0 and ALIST is empty. *)
VAR   ACRED, ACWHIT, CP: LIST; 
BEGIN
      DEB_BEGIN(KEYCOL);
(*1*) ALIST:=SIL; KEY:=0; 
(*2*) FIRST2(ACOLS, ACRED,ACWHIT);
      IF MEMBER(EL,ACRED) = 1 THEN KEY:=1; RETURN; END;
      CP:=FINDCP(EL,ACWHIT); 
      IF CP <> SIL THEN KEY:=2; ALIST:=SECOND(CP); END; 
(*5*) RETURN;
END KEYCOL; 


PROCEDURE MKACOL(ALIST,EL,COLR,COLW: LIST; VAR CRED,CWHITE: LIST); 
(*Make colour. ALIST is a list of coefficients. EL is a term.
COLR is a list of red terms. COLW is a list of white terms.
If ALIST is empty, EL is added to COLR. The result is CRED.
If ALIST is not empty, the pair of EL and ALIST is added to COLW. the
result is CWHITE. *)
BEGIN
      DEB_BEGIN(MKACOL);
(*1*) CRED:=COLR; CWHITE:=COLW; 
(*2*) IF ALIST = SIL THEN CRED:=COMP(EL,CRED); RETURN; END;
      CWHITE:=COMP(LIST2(EL,ALIST),CWHITE);
(*5*) RETURN;
END MKACOL; 


PROCEDURE MKCOL(COND,CA,CE,COLR,COLW: LIST; VAR CRED,CWHITE: LIST); 
(*Make new colour. COND is a condition. CA is a coefficient. CE is
a term. COLR is a list of red terms. COLW is a list of white terms.
If CA is coloured red by COND, CE is added to COLR. the result is CRED.
If CA is coloured white by COND, the pair with CE and the white factors
of CA are added to COLW. the result is CWHITE. *)
VAR   A, CL, PACK, QALIST, WFACTS: LIST;
      C: COLOUR;
BEGIN
      DEB_BEGIN(MKCOL);
(*1*) CRED:=COLR; CWHITE:=COLW; 
(*2*) (*CA is a constant. *)
      IF PAR.IsCnst(CA) THEN CRED:=COMP(CE,CRED); RETURN; END; 
(*3*) (*Factorization of CA. *) 
      QALIST:=PAR.Factorize(CA);
      WFACTS:=SIL; CL:=0; 
(*4*) (*Check factors of CA. *) 
      WHILE (QALIST <> SIL) AND (CL = 0) DO
            ADV(QALIST, A,QALIST); 
            IF NOT PAR.IsCnst(A) THEN 
	      C:=PAR.CondEval(COND,A);
     	      IF    C=unknown THEN WFACTS:=COMP(A,WFACTS);
     	      ELSIF C=zero    THEN CL:=1;  END;
            END; 
      END; 
(*5*) (*Finish. *) 
      IF CL = 0 THEN
         IF WFACTS = SIL 
           THEN CRED:=COMP(CE,CRED);
           ELSE PACK:=LIST2(CE,WFACTS); CWHITE:=COMP(PACK,CWHITE); END; 
      END; 
(*8*) RETURN;
END MKCOL; 


PROCEDURE FINCOL(APP,ACOLS,COLR,COLW: LIST; VAR CRED,CWHITE: LIST); 
(*Finish colouring. APP is a polynomial.
ACOLS contains a list of red terms and a list of white terms.
COLR is a list of red terms. COLW is a list of white terms.
The red terms of APP are added to COLR. the result is CRED.
The white terms of APP are added to COLW with their white part.
The result is CWHITE. *)
VAR   AL, EL: LIST; 
BEGIN
      DEB_BEGIN(FINCOL);
(*1*) CRED:=COLR; CWHITE:=COLW; 
(*2*) WHILE APP <> SIL DO
            DIPMAD(APP, AL,EL,APP); 
            COLDIF(EL,ACOLS,CRED,CWHITE, CRED,CWHITE);
      END; 
(*5*) RETURN;
END FINCOL; 


PROCEDURE NFORM(GA,FCO,P: LIST; VAR N0,N1: LIST); 
(*Parametric normalform.
GA is a condition. FCO is a polynomial coloured wrt GA.
P is a list of polynomials coloured wrt GA.
FCO is reduced modulo P wrt GA. N0 is the set of tripel of the form
(cond,pco,c), where cond is a condition, pco is a normalform of fco
coloured completely green by cond and c is a multiplicative factor.
N1 is the set of tripel of the form
(cond,pco,c), where cond is a condition, pco is a normalform of fco
not coloured completely green by cond and c is a multiplicative
factor. *)
(* ---to do---: this "multiplicative factor" is useless, remove! *)
VAR   C, CCL, COL, COND, D, DCOND, DL, F, PCI, PCO, POL, QC, RE: LIST; 
BEGIN
      DEB_BEGIN(NFORM);
(*1*) (*Prepare c=1. *)
      N0:=SIL; N1:=SIL;
      IF FCO = SIL THEN RETURN; END; 
      COND:=GA; 
      F:=ColpPol(FCO); 
      C:=ADFI(DIPLBC(F),1);
(*2*) (*Case FCO is zero (completely coloured green) or P is empty. *) 
      IF ColpIsZero(FCO) THEN N0:=LIST3(COND,FCO,C); RETURN; END; 
      IF P = SIL THEN N1:=LIST3(COND,FCO,C); RETURN; END; 
      PCO:=FCO;
(*4*) (*Reduction. *) 
      LOOP
          IF ColpIsZero(PCO) THEN N0:=LIST3(COND,PCO,C); EXIT; END;
          FINDPI(PCO,P, PCI,RE); 
          IF PCI = SIL THEN EXIT; END;
          GRED(COND,PCO,PCI,RE, PCO,QC); 
          C:=ADPROD(C,QC);
      END;
      IF N0 <> SIL THEN RETURN END;
(*4*) (*Get headterm wrt. COND. *) 
      IF ColpHT(PCO) <> SIL THEN N1:=LIST3(COND,PCO,C); RETURN; END;
(*5*) (*Determine. *)
      ColpParts(PCO, POL,COL);
      DETPOL(COND,POL,COL, DL,CCL); 
      WHILE CCL <> SIL DO
           ADV2(CCL, DCOND,PCO,CCL); 
     	       	    	      	     (* ---to do---: OK? *)
           IF ColpIsZero(PCO) THEN N0:=COMP3(DCOND,PCO,C,N0); 
                              ELSE N1:=COMP3(DCOND,PCO,C,N1); END;
      END;
(*7*) RETURN;
END NFORM; 


PROCEDURE NFTOP(GA,FCO,P: LIST; VAR N0,N1: LIST); 
(*Normalform by topreduction.
GA is a condition. FCO is a polynomial coloured wrt GA.
P is a list of polynomials coloured wrt GA.
FCO is reduced modulo P wrt GA. N0 is the set of tripel of the form
(cond,pco,c), where cond is a condition, pco is a normalform of fco
coloured completely green by cond and c is a multiplicative factor.
N1 is the set of tripel of the form
(cond,pco,c), where cond is a condition, pco is a normalform of fco
not coloured completely green by cond and c is a multiplicative
factor. *)
(* ---to do---: this "multiplicative factor" is useless, remove! *)
VAR   AL, C, CCL, COL, D, DCOND, DL, F, N, NL, PCI, PCO, 
      POL, QC, RE: LIST; 
BEGIN
      DEB_BEGIN(NFTOP);
(*1*) (*Prepare c=1. *) 
      N0:=SIL; N1:=SIL;
      IF FCO = SIL THEN RETURN; END; 
      F:=ColpPol(FCO);
      C:=ADFI(DIPLBC(F),1);
(*2*) (*Case FCO is zero (completely coloured green) or P is empty. *) 
      IF ColpIsZero(FCO) THEN N0:=LIST3(GA,FCO,C); RETURN; END; 
      IF P = SIL THEN N1:=LIST3(GA,FCO,C); RETURN; END; 
(*3*) N:=LIST2(C,LIST2(GA,FCO)); 
(*4*) (*Reduction. *) 
      WHILE N <> SIL DO
           ADV2(N, C,NL,N); 
           WHILE NL <> SIL DO
                ADV2(NL, GA,PCO,NL); 
                LOOP
                    IF ColpIsZero(PCO) THEN N0:=COMP3(GA,PCO,C,N0); EXIT; END;
                    FINDPITOP(PCO,P, PCI,RE); 
                    IF PCI <> SIL THEN
                      GRED(GA,PCO,PCI,RE, PCO,QC);
                      C:=ADPROD(C,QC);
                    ELSE
                      IF ColpHT(PCO) <> SIL
                        THEN N1:=COMP3(GA,PCO,C,N1);
                        ELSE ColpParts(PCO, POL,COL);
			     DETPOL(GA,POL,COL, DL,CCL);
                             N:=COMP2(C,CCL,N);
                      END; 
                      EXIT;
                    END; 
                END;
           END; 
      END; 
(*7*) RETURN;
END NFTOP; 


PROCEDURE FINDPI(PCO,P: LIST; VAR PCI,RE: LIST); 
(*Find polynomial.
PCO is a coloured polynomial.
P is a list of coloured polynomials. 
A polynomial for the reduction over all terms of PCO modulo P
is searched.
PCI is emtpy if no polynomial is found, else PCI is the found
polynomial and RE is the term of PCO to be eliminated. *)
VAR   ALIST, COL, HE, KEY, POL, PP, RA: LIST; 
BEGIN
     DEB_BEGIN(FINDPI);
     ColpParts(PCO, POL,COL);
     WHILE (POL <> SIL) DO
          DIPMAD(POL, RA,RE,POL);
          KEYCOL(RE,COL, KEY,ALIST); 
          IF KEY <> 0 THEN (* RE not zero (green) *)
     	    PP:=P;
            REPEAT
                  ADV(PP, PCI,PP);
                  HE:=ColpHT(PCI);
                  IF HE <> SIL THEN IF EVMT(RE,HE)=1 THEN RETURN; END;
     	       	    	       ELSE ERROR(severe,
			           "Error in FINDPI, this cannot happen.");
     	                      (* --- to do ---: HE=SIL cannot happen ?? *)
                  END;
            UNTIL PP = SIL; 
           END; 
      END; 
      PCI:=SIL;
END FINDPI; 

PROCEDURE FINDPITOP(PCO,P: LIST; VAR PCI,RE: LIST); 
(*Find polynomial.
PCO is a non-zero coloured polynomial.
P is a list of coloured polynomials.
A polynomial for the topreduction of PCO modulo P is searched.
PCI is emtpy if no polynomial is found, else PCI is the found
polynomial and RE is the term of PCO to be eliminated. *)
VAR   ALIST, HE, PI, RA: LIST; 
BEGIN
     DEB_BEGIN(FINDPITOP);
     RE:=ColpHT(PCO); 
     IF RE = SIL THEN RE:=FIRST(FIRST(ColWhite(ColpCol(PCO)))); END; 
     REPEAT
           ADV(P, PCI,P);
           HE:=ColpHT(PCI); 
           IF HE <> SIL THEN IF EVMT(RE,HE)=1 THEN RETURN; END;
     	       	    	ELSE ERROR(severe,
			           "Error in FINDPITOP, this cannot happen.");
     	       	    	 (* --- to do ---: HE=SIL cannot happen ?? *)
     	   END;
     UNTIL(P = SIL); 
     PCI:=SIL;
END FINDPITOP; 


PROCEDURE SPOL(COND,HA,HB: LIST): LIST; 
(*Parametric s-polynomial.
COND is a condition.
HA and HB are coloured polynomials.
Return SIL if the spolynomial of HA, HB need not be considered else returns
the s-polynomial of HA and HB with colouring. *)
VAR   A, ACOL, AL, APP, B, BCOL, BL, BPP, CL, DL, DL1, EL, EL1,
      GL, H, HCOLS, RAL, RAP, SL: LIST; 
BEGIN
      DEB_BEGIN(SPOL);
      IF (HA = SIL) OR (HB = SIL) THEN RETURN SIL; END; 
      ColpParts(HA, A,ACOL); ColpParts(HB, B,BCOL);
(*3*) EL:=ColpHT(HA);
      DL:=ColpHT(HB);
      GL:=EVLCM(EL,DL);
      IF EQUAL(GL,EVSUM(EL,DL)) = 1 THEN RETURN SIL; END;
        (* Buchbergers first criterion: disjoint head terms *)
(*4*) ACOL:=SETCOL(COND,ACOL); AL:=FINDBC(EL,A); ADV(AL, RAL,RAP); 
      BCOL:=SETCOL(COND,BCOL); BL:=FINDBC(DL,B);
(*5*) ADGCDC(AL,BL, CL,AL,BL);
      (* Note: if gcd is not defined for the current domain, AL and BL
         remain unchanged by definiton of ADGCDC *)
      EL1:=EVDIF(GL,EL); DL1:=EVDIF(GL,DL);
      APP:=DIPFMO(BL,EL1);
      BPP:=DIPFMO(AL,DL1);
      IF EVSIGN(EL1) <> 0 THEN ACOL:=COLPRD(ACOL,EL1); END; 
      APP:=DIPROD(A,APP);
      IF EVSIGN(DL1) <> 0 THEN BCOL:=COLPRD(BCOL,DL1); END; 
      GBDIFF(COND,APP,ACOL,DIPROD(B,BPP),BCOL, H,HCOLS); 
      IF H <> 0 THEN 
         IF ADSIGN(DIPLBC(H)) = -1 THEN H:=DIPNEG(H); END; 
         IF NOT ColIsEmpty(HCOLS) THEN RETURN ColpCons(H,HCOLS); END; 
      END; 
(*8*) RETURN SIL;
END SPOL; 


PROCEDURE GBSYS(CNDS,P: LIST): LIST;
(*Groebner system.
CNDS is a case distinction.
P is a list of polynomials.
Returns a Groebner-system for P relative to CNDS. *)
VAR   BB, COND, CONDS, GSYS, PAIRS, PCO, PELEM, PL, PP: LIST; 
BEGIN
      DEB_BEGIN(GBSYS);
(*1*) (*Case P is empty. *)
      IF P = SIL THEN RETURN(SIL); END; 
(*2*) (*Determine P relative to CNDS. *)
      DET(CNDS,P, CONDS,PL); 
      IF PAR.outputlevel>0 THEN
	SWRITE("The polynomial system is determined by: "); BLINES(0); 
        DWRIT(CONDS); BLINES(1);
      END;
(*3*) (*Check degree of polynomials and construct pairs. *)
      BB:=SIL; GSYS:=SIL;
      WHILE PL <> SIL DO
           ADV(PL, PELEM,PL); FIRST2(PELEM, COND,PP); 
           PCO:=CHDEGL(PP); 
           IF PCO <> SIL THEN
             GSYS:=GBUPD(COND,LIST1(PCO),GSYS);
           ELSE
             PAIRS:=MKPAIR(PP); 
(*             IF PAIRS <> SIL THEN BB:=COMP3(COND,PP,PAIRS,BB); *)
             IF PAIRS <> SIL THEN BB:=COMP3(COND,REXTP(PP),PAIRS,BB); 
     	       (* ---to do---: Removing extraneous polynomials should be
     	       	    	       done here, too??? *)
                             ELSE GSYS:=GBUPD(COND,PP,GSYS); END; 
           END; 
      END; 
(*4*) (*Construct groebner-system. *)
(*7*) RETURN(CONSGB(BB,GSYS));
END GBSYS;

VAR pGSYS, pCOND: POINTER TO LIST;

PROCEDURE SigUsr1HandleCONSGB(signo:INTEGER);
(* Handler for sigusr1 in CONSGB. *)
VAR dummy: Action;
    Dummy: LIST;
BEGIN
     dummy:=signal(SIGUSR1,SIG_IGN);
     Dummy:=SOUNIT("CON:x");
     BLINES(0);
     SWRITE("______________________________________________________________________________"); BLINES(0);
     SWRITE("SIGUSR1 received in CONSGB:"); BLINES(1);
     SWRITE("Groebner system at the moment:"); BLINES(1);
     WRGBS(pGSYS^); BLINES(1);
     SWRITE("Actual condition:"); BLINES(1);
     CondWrite(pCOND^); BLINES(0);
     SWRITE("______________________________________________________________________________"); BLINES(0);
     Dummy:=CUNIT("CON:x");
     dummy:=signal(SIGUSR1,SigUsr1HandleCONSGB);
END SigUsr1HandleCONSGB;


PROCEDURE CONSGB(BB,GSYS: LIST): LIST;
(*Construct groebner-system. BB is a list of the form
(cond1,p1,pairs1,... ,condn,pn,pairsn),
where condi is a condition, pi is a polynomials list determined by condi
and pairsi is the polynomials pairs list of pi for i= 1; n.
GSYS is the actual groebner-system.
GSYS is completed. The result is returned. *)
VAR   COND, GS1, HCO, HCOL, N0, N1, P, PAIR, PAIRS, PLIST,
      PRSL: LIST; 
VAR sighandleold: Action;

BEGIN
     DEB_BEGIN(CONSGB);
     PLIST:=BB;
     COND:=CondEmpty(); (* Initialization necessary for signal handler only *)
     pGSYS:=ADR(GSYS);
     pCOND:=ADR(COND);
     sighandleold:=signal(SIGUSR1,SigUsr1HandleCONSGB);
(*2*) (*S-polynomials and normalforms. *) 
      WHILE PLIST <> SIL DO
           ADV3(PLIST, COND,P,PAIRS,PLIST); 
           WHILE PAIRS <> SIL DO
                ADV(PAIRS, PAIR,PAIRS); 
                PRSL:=SIL; GS1:=SIL;
                HCO:=SPOL(COND,SECOND(PAIR),THIRD(PAIR));
                IF HCO = SIL THEN (* s-polynomial is zero. *)
                  IF PAIRS = SIL THEN GSYS:=GBUPD(COND,P,GSYS); END;
                ELSE
                  IF ColpIsCnst(HCO) THEN (* s-polynomial is a constant *)
                    PAIRS:=SIL; 
                    GSYS:=GBUPD(COND,LIST1(HCO),GSYS); 
                  ELSE
     	       	    PAR.NormalForm(COND,HCO,P, N0,N1); 
                    VRNORM(COND,P,N0,N1,PAIRS, P,PAIRS,PRSL,GS1);
                  END; 
                END; 
     	        IF PRSL<>SIL THEN PLIST:=CONC(PRSL,PLIST); END;
     	       	    	      	   	 (* PRSL first, we want ramifications
     	       	    	      	   	    of COND to be treated first, esp.
					    to have the generic case first. *)
                GSYS:=CONC(GSYS,GS1);
           END; 
      END; 
      sighandleold:=signal(SIGUSR1,sighandleold);
      RETURN(GSYS);
END CONSGB; 

(**********************************************************************
FACTORIZING
**********************************************************************)

PROCEDURE GBSYSF(CNDS,P: LIST): LIST;
(*Groebner system with factorization.
CNDS is a case distinction.
P is a list of polynomials.
Returns a Groebner-system for P relative to CNDS. *)
VAR   BB, COND, CONDS, GSYS, PAIRS, PCO, PELEM, PL, PP, p, FL, F, f, tmpFL, tmpF, fl, pl: LIST; 
BEGIN
      DEB_BEGIN(GBSYSF);
(*1*) (*Case P is empty. *)
      IF P = SIL THEN RETURN(SIL); END; 
      FL:=SIL;
      WHILE P<>SIL DO
      	   ADV(P, p,P);
     	   F:=PAR.Factors(p);
     	   IF FL=SIL THEN
     	       WHILE F<>SIL DO ADV(F, f,F); FL:=COMP(LIST1(f),FL); END;
     	   ELSE
     	       tmpFL:=FL;
     	       FL:=SIL;
     	       WHILE tmpFL<>SIL DO
	            ADV(tmpFL, fl,tmpFL);
		    tmpF:=F;
		    WHILE tmpF<>SIL DO
		    	 ADV(tmpF, f,tmpF); FL:=COMP(COMP(f,fl),FL); END;
     	       END;
     	    END;
      END;
     	   
(*2*) (*Determine P relative to CNDS. *)
      PL:=SIL;
      WHILE FL<>SIL DO
      	   ADV(FL, fl,FL);
	   DET(CNDS,fl, CONDS,pl); 
     	   PL:=CONC(pl,PL);
      END;
 
      IF PAR.outputlevel>0 THEN
	SWRITE("The polynomial system is determined by: "); BLINES(0); 
        CdWrite(CONDS); BLINES(1);
      END;
(*3*) (*Check degree of polynomials and construct pairs. *)
      BB:=SIL; GSYS:=SIL;
      WHILE PL <> SIL DO
           ADV(PL, PELEM,PL); FIRST2(PELEM, COND,PP); 
           PCO:=CHDEGL(PP); 
           IF PCO <> SIL THEN
             GSYS:=GBUPD(COND,LIST1(PCO),GSYS);
           ELSE
             PAIRS:=MKPAIR(PP); 
             IF PAIRS <> SIL THEN BB:=COMP3(COND,REXTP(PP),PAIRS,BB); 
     	       (* ---to do---: Removing extraneous polynomials should be
     	       	    	       done here, too??? *)
                             ELSE GSYS:=GBUPD(COND,PP,GSYS); END; 
           END; 
      END; 
(*4*) (*Construct groebner-system. *)
(*7*) RETURN(CONSGBF(BB,GSYS));
END GBSYSF;

PROCEDURE SigUsr1HandleCONSGBF(signo:INTEGER);
(* Handler for sigusr1 in CONSGBF. *)
VAR dummy: Action;
    Dummy: LIST;
BEGIN
     dummy:=signal(SIGUSR1,SIG_IGN);
     Dummy:=SOUNIT("CON:x");
     BLINES(0);
     SWRITE("______________________________________________________________________________"); BLINES(0);
     SWRITE("SIGUSR1 received in CONSGB:"); BLINES(1);
     SWRITE("Groebner system at the moment:"); BLINES(1);
     WRGBS(pGSYS^); BLINES(1);
     SWRITE("Actual condition:"); BLINES(1);
     CondWrite(pCOND^); BLINES(0);
     SWRITE("______________________________________________________________________________"); BLINES(0);
     Dummy:=CUNIT("CON:x");
     dummy:=signal(SIGUSR1,SigUsr1HandleCONSGBF);
END SigUsr1HandleCONSGBF;


PROCEDURE CONSGBF(BB,GSYS: LIST): LIST;
(*Construct groebner-system. BB is a list of the form
(cond1,p1,pairs1,... ,condn,pn,pairsn),
where condi is a condition, pi is a polynomials list determined by condi
and pairsi is the polynomials pairs list of pi for i= 1; n.
GSYS is the actual groebner-system.
GSYS is completed. The result is returned. *)
VAR   COND, GS1, HCO, HCOL, N0, N1, P, PAIR, PAIRS, PLIST,
      PRSL, tmpN1, con, cond, pcol, c, p, col, FL, f, CD, CL, con, pol : LIST; 
VAR sighandleold: Action;

BEGIN
     DEB_BEGIN(CONSGBF);
     PLIST:=BB;
     COND:=CondEmpty(); (* Initialization necessary for signal handler only *)
     pGSYS:=ADR(GSYS);
     pCOND:=ADR(COND);
     sighandleold:=signal(SIGUSR1,SigUsr1HandleCONSGBF);
(*2*) (*S-polynomials and normalforms. *) 
      WHILE PLIST <> SIL DO
           ADV3(PLIST, COND,P,PAIRS,PLIST); 
           WHILE PAIRS <> SIL DO
                ADV(PAIRS, PAIR,PAIRS); 
                PRSL:=SIL; GS1:=SIL;
                HCO:=SPOL(COND,SECOND(PAIR),THIRD(PAIR));
                IF HCO = SIL THEN (* s-polynomial is zero. *)
                  IF PAIRS = SIL THEN GSYS:=GBUPD(COND,P,GSYS); END;
                ELSE
                  IF ColpIsCnst(HCO) THEN (* s-polynomial is a constant. *)
                    PAIRS:=SIL; 
                    GSYS:=GBUPD(COND,LIST1(HCO),GSYS); 
                  ELSE
     	       	    PAR.NormalForm(COND,HCO,P, N0,N1); 
     	       	    tmpN1:=N1;
     	       	    N1:=SIL;
		    WHILE tmpN1<>SIL DO
		    	 ADV3(tmpN1, cond,pcol,c,tmpN1);
     	       	    	 FIRST2(pcol, p,col);
     	       	    	 FL:=PAR.Factors(p);
			 WHILE FL<>SIL DO
			      ADV(FL, f,FL);
(*			      DETPOL(COND,f,INICOL(COND,f), CD,CL);*)
			      DETPOL(COND,f,ColConsCond(f,COND), CD,CL);
     	       	    	      WHILE CL<>SIL DO
			      	   ADV2(CL, con,pol,CL);
     	       	    	      	   IF ColpIsZero(pol)
				      THEN N0:=COMP3(con,pol,1, N0);
     	       	    	      	      ELSE N1:=COMP3(con,pol,1, N1);
     	       	    	      	   END;
     	       	    	      END;
     	       	    	 END;
	       	    END;

                    VRNORM(COND,P,N0,N1,PAIRS, P,PAIRS,PRSL,GS1);
                  END; 
                END; 
     	        IF PRSL<>SIL THEN PLIST:=CONC(PRSL,PLIST); END;
     	       	    	      	   	 (* PRSL first, we want ramifications
     	       	    	      	   	    of COND to be treated first, esp.
					    to have the generic case first. *)
                GSYS:=CONC(GSYS,GS1);
           END; 
      END; 
      sighandleold:=signal(SIGUSR1,sighandleold);
      RETURN(GSYS);
END CONSGBF; 

(**********************************************************************
END FACTORIZING
**********************************************************************)

PROCEDURE VRNORM(COND,PP,N0,N1,PPAIRS: LIST;
                 VAR P,PAIRS,PAIRSL,GSYS: LIST);
(*Verify normalforms. 
COND is a condition.
PP is a polynomials list determined by COND.
N0 is a set of tripel (ga,pco,c), where ga is
a condition, pco is a normalform determined and coloured completely
green (=0) by ga and c is a multiplicative factor.
N1 is a set of tripel
(ga,pco,c), where ga is a condition, pco is a normalform determined and
not coloured completely green (=0) by ga and c is a multiplicative factor.
PPAIRS is the polynomials pairs list of PP.
The normalforms are checked.
PP is updated to P.
PPAIRS is updated to PAIRS. 
PAIRSL is a list of the form
(cond1,p1,pairs1,... ,condn,pn,pairsn) constructed from the information
of the N0 and N1.
GSYS is a list of pairs, each containing a condition and a groebner
base wrt. this condition. *)
VAR   C, GSYS0, GSYS1, N1P, NCO, NPCOND, PRS0, PRS1: LIST; 
BEGIN
      DEB_BEGIN(VRNORM);
(*1*) PAIRSL:=SIL; GSYS:=SIL; PRS0:=SIL; PRS1:=SIL; 
      GSYS0:=SIL; GSYS1:=SIL; P:=PP; PAIRS:=SIL; 
(*2*) IF N1 = SIL THEN (* all normal forms are zero *)
     	IF PPAIRS = SIL THEN (* no more pairs *)
     	  GSYS:=GBUPD(COND,P,GSYS);  (* this case is finished, add to GSYS *)
     	ELSE
          PAIRS:=PPAIRS;
     	END;
        RETURN;
      END; 
(*3*) (*Check N0. *) 
      IF N0 <> SIL THEN (* there are zero and non-zero normal forms *)
        IF PPAIRS = SIL (* no more pairs *)
          THEN GSYSN0(N0,P, GSYS0); (* this cases are finished,
     	       	    	      	       add them to GSYS0 *)
          ELSE MKN0(N0,P,PPAIRS, PRS0); (* generate new pairs lists *)
        END; 
      END; 
(*4*) (*Check N1 (<>SIL here). *) 
      ADV3(N1, NPCOND,NCO,C,N1P); 
      IF (N1P = SIL) AND (N0 = SIL) THEN (* Only one normal form which is 
                                            not zero *)
        
        IF ColpIsCnst(NCO) THEN (* It is a constant. *)
     	  GSYS:=GBUPD(COND,LIST1(NCO),GSYS); RETURN; (* Case closed *)
        ELSE (* It is not a constant. *)
          PAIRS:=MKNEWP(P,NCO,PPAIRS); 
          P:=MINPP(P,NCO);
        END; 
      ELSE (* There are more then one normal forms *)
        MKN1(N1,P,PPAIRS, PRS1,GSYS1);
      END; 
(*5*) (*Update PAIRSL. *)
      PAIRSL:=CONC(PRS0,PRS1);
(*6*) (*Update GSYS. *)
      GSYS:=CONC(GSYS0,GSYS1);
      RETURN;
END VRNORM; 

PROCEDURE CHDEGL(PLIST: LIST): LIST; 
(* Check degree of polynomial list.
PLIST is a list of coloured polynomials. 
Returns an element of PLIST, such that the degree wrt the colouring of
the polynomial is 0, or emtpy if no such polynomial exists. *)
VAR   PCO: LIST; 
BEGIN
     DEB_BEGIN(CHDEGL);
     IF PLIST = SIL THEN RETURN(SIL); END; 
     REPEAT
           ADV(PLIST, PCO,PLIST);
           IF ColpIsCnst(PCO) THEN RETURN(PCO); END;
     UNTIL (PLIST = SIL);
     RETURN(SIL);
END CHDEGL; 


PROCEDURE MKN1(NN1,P,PAIRS: LIST; VAR PPLIST,GSYS: LIST); 
(* Make n1.
NN1 is a set of tripel of the form
(ga,pco,c), where ga is a condition, pco is a normalform determined and
not coloured completely green by ga and c is a multiplicative
factor.
P is a list of coloured polynomials.
PAIRS is the polynomials pairs list of P.
PPLIST is a list of the form
(cond1,p1,pairs1,... ,condn,pn,pairsn) constructed from the information
of the NN1.
GSYS is a list of pairs, each containing a condition and a groebner
basis wrt this condition. *)
VAR   C, NPCOND, PCO, PP: LIST; 
BEGIN
      DEB_BEGIN(MKN1);
(*1*) PPLIST:=SIL; GSYS:=SIL; 
(*2*) (*Check degree of normalforms. Update Groebner-System and pairslist. *)
      WHILE NN1 <> SIL DO
           ADV3(NN1, NPCOND,PCO,C,NN1);
           IF ColpIsCnst(PCO) THEN
             GSYS:=GBUPD(NPCOND,LIST1(PCO),GSYS);
           ELSE
             PP:=MINPP(P,PCO);
             PPLIST:=COMP3(NPCOND,PP,MKNEWP(P,PCO,PAIRS),PPLIST); 
             IF PAR.outputlevel = 1 THEN 
     	       SWRITE("New case"); BLINES(0); CondWrite(NPCOND);
               BLINES(1); DCLWR(PP,0); END; 
           END; 
      END; 
(*5*) RETURN;
END MKN1; 


PROCEDURE MKN0(NN0,P,PAIRS: LIST; VAR PPLIST: LIST); 
(*Make n0.
NN0 is a set of tripel of the form
(ga,pco,c), where ga is a condition, pco is a normalform determined and
coloured completely green by ga and c is a multiplicative
factor.
P is a list of coloured polynomials.
PAIRS is the polynomials pairs list of P.
PPLIST is a list of the form
(cond1,p1,pairs1,... ,condn,pn,pairsn) constructed from the information
of the NN0. *)
VAR   C, NPCOND, PCO: LIST; 
BEGIN
      DEB_BEGIN(MKN0);
(*1*) PPLIST:=SIL;
(*2*) WHILE NN0 <> SIL DO
           ADV3(NN0, NPCOND,PCO,C,NN0); 
           PPLIST:=COMP3(NPCOND,P,PAIRS,PPLIST);
      END; 
(*5*) RETURN;
END MKN0; 


PROCEDURE GSYSN0(NN0,P: LIST; VAR GSYS: LIST); 
(*Groebner-System n0 update.
NN0 is a set of tripel of the form
(ga,pco,c), where ga is a condition, pco is a normalform determined and
coloured completely green by ga and c is a multiplicative
factor.
P is a list of coloured polynomials.
for each GA in NN0, the pair of the form (ga,p) is added to GSYS. *)
VAR   C, NPCOND, PCO: LIST; 
BEGIN
      DEB_BEGIN(GSYSN0);
(*1*) GSYS:=SIL; 
(*2*) (*Update GSYS. *)
      WHILE NN0 <> SIL DO
           ADV3(NN0, NPCOND,PCO,C,NN0); 
           GSYS:=GBUPD(NPCOND,P,GSYS);
      END; 
(*5*) RETURN;
END GSYSN0; 


PROCEDURE MINPP(PP,PCO: LIST): LIST; 
(*Minimize polynomials list. PP is a list of coloured polynomials.
PCO is a coloured polynomial.
P is a list of PCO and those polynomials in PP, such that their
headterms wrt the colouring can not be divided by the headterm of PCO
relative to its colouring. *)
VAR  EI, P, PCI: LIST; 
BEGIN
      DEB_BEGIN(MINPP);
(*1*) (*Get headterm of PCO. *)
      P:=SIL; 
      EI:=ColpHT(PCO); 
      IF EI=SIL THEN ERROR(severe,
		           "Error in MINPP, this cannot happen."); END;
     	                   (* --- to do ---: EI=SIL cannot happen ?? *)

      (* RETURN (INV(COMP(PCO,PP))); END;*) (* ---CHANGED--- *)
(*2*) (*Check headterms of PP. *) 
      WHILE PP <> SIL DO
           ADV(PP, PCI,PP);
           IF EVMT(ColpHT(PCI),EI) = 0 THEN P:=COMP(PCI,P); END; 
      END; 
(*3*) (*Get PCO. *) 
(*6*) RETURN(INV(COMP(PCO,P)));
END MINPP;


PROCEDURE UPDPP(COND,P: LIST): LIST; 
(*Update polynomials. COND is a condition. P is a list of polynomials
determined and coloured wrt a predecessor of COND. The colouring of
each polynomial is updated. The result is the polynomial-list PP. *)
VAR   COL, PCO, POL, PP: LIST; 
BEGIN
      DEB_BEGIN(UPDPP);
(*1*) IF P = SIL THEN RETURN(SIL); END; 
      PP:=SIL;
(*2*) (*Update. *) 
      REPEAT
            ADV(P, PCO,P);
            FIRST2(PCO, POL,COL); 
            PP:=COMP(LIST2(POL,SETCOL(COND,COL)),PP);
      UNTIL P=SIL;
(*6*) RETURN(INV(PP));
END UPDPP; 


PROCEDURE GBUPD(COND,P,GBSYS: LIST): LIST; 
(*Groebner-system update. COND is a condition. P is a list of polynomials
determined and coloured wrt a predecessor of COND. GBSYS is the actual
Groebner-system. The colouring of each polynomial
in P is updated relative to COND. Extraneous polynomials are eliminated.
The condititon and the resulting polynomials list are added to GBSYS.
The result is GSYS. *)
VAR   ELEM, PP: LIST; 
BEGIN
      DEB_BEGIN(GBUPD);
(*1*) (* PP:=UPDPP(COND,REXTP(P)); *)
      PP:=REXTP(UPDPP(COND,P));
     	  (* ---to do---: Colouring should be updated before extraneous
                          polynomials are removed ... correct???
                          What happens if PP is SIL ??? *)
      GBSYS:=COMP(LIST2(COND,PP),GBSYS); 
      IF PAR.outputlevel = 1 THEN 
        SWRITE("New Groebner-Basis: "); BLINES(0); CondWrite(COND); BLINES(1);
        DCLWR(PP,0);
      END; 
(*4*) RETURN(GBSYS);
END GBUPD; 


PROCEDURE MKPAIR(PP: LIST): LIST; 
(*Make pairs. PP is a list of coloured polynomials. The polynomials
pairs list is constructed containing those polynomials whose headterm
relative to the colouring is defined. The list pairs is in a
nondecreasing order. *)
VAR   ELI, ELJ, PI, PJ, QP, PAIRS: LIST; 
BEGIN
      DEB_BEGIN(MKPAIR);
(*1*) IF (PP = SIL) THEN RETURN(SIL); END;
      IF (RED(PP) = SIL) THEN RETURN(SIL); END;
      PAIRS:=SIL;
(*2*) (*Construct pairs. *) 
      REPEAT
            ADV(PP, PI,QP);
            ELI:=ColpHT(PI); 
            IF ELI <> SIL THEN
              WHILE QP <> SIL DO 
                   ADV(QP, PJ,QP);
                   ELJ:=ColpHT(PJ); 
                   IF ELJ <> SIL THEN
                     PAIRS:=COMP(LIST3(EVLCM(ELI,ELJ),PI,PJ),PAIRS); 
                   END; 
              END; 
           END; 
           PP:=RED(PP); 
      UNTIL PP = SIL; 
(*3*) (*Merge. *) 
      IF PAIRS <> SIL THEN RETURN(EVPLSO(PAIRS)); END; 
(*6*) RETURN(SIL);
END MKPAIR; 


PROCEDURE PRSCOP(PAIRS: LIST): LIST; 
(*Pairs copy. PAIRS is a polynomials pairs list. PPAIRS is a copy of PAIRS. *)
VAR   PAIR, PPAIRS: LIST; 
BEGIN
      DEB_BEGIN(PRSCOP);
(*1*) IF PAIRS = SIL THEN RETURN(SIL); END; 
      PPAIRS:=SIL;
(*2*) WHILE PAIRS <> SIL DO
           ADV(PAIRS, PAIR,PAIRS); 
           PPAIRS:=COMP(PAIR,PPAIRS);
      END; 
(*5*) RETURN(INV(PPAIRS));
END PRSCOP; 


PROCEDURE MKNEWP(P,POL,PRS: LIST): LIST; 
(*Make new pairs. P is a list of coloured polynomials. POL is a
coloured polynomial. PRS is the polynomials pairslist of P. The new
pairs between POL and P are constructed and added to PRS. The result
is PPAIRS. *)
VAR   ELI, ELJ, PLI, PPAIRS: LIST; 
BEGIN
      DEB_BEGIN(MKNEWP);
(*1*) (*Prepare input. *) 
      PPAIRS:=SIL;
(*2*) (*Update pairs. *)
      ELI:=ColpHT(POL); 
      WHILE P <> SIL DO
           ADV(P, PLI,P);
           ELJ:=ColpHT(PLI); 
           IF ELJ <> SIL THEN
             PPAIRS:=COMP(LIST3(EVLCM(ELI,ELJ),POL,PLI),PPAIRS);
           END; 
      END;
(*3*) (*Copy and merge. *)
      PPAIRS:=EVPLSO(PPAIRS); 
      IF PRS <> SIL THEN RETURN(EVPLM(PRSCOP(PRS),PPAIRS)); END; 
(*6*) RETURN(PPAIRS);
END MKNEWP; 


PROCEDURE MKCGB(PL: LIST; VAR X,I: LIST); 
(*Make Comprehensive-Groebner-Basis. PL is a Groebner-System.
X is the Comprehensive-Groebner-Basis from PL. I is the number of
conditions in PL. *)
VAR   PCO, PELEM, PLIST: LIST; 
BEGIN
      DEB_BEGIN(MKCGB);
(*1*) X:=SIL; I:=0; 
      IF PL = SIL THEN RETURN; END; 
      ADV(PL, PELEM,PL); 
(*2*) (*Get first groebner basis. *)
      PLIST:=SECOND(PELEM); 
      WHILE PLIST <> SIL DO
           ADV(PLIST, PCO,PLIST);
           X:=COMP(FIRST(PCO),X);
      END; 
      I:=1; 
(*3*) (*Get other bases of PL. *) 
      WHILE PL <> SIL DO
           ADV(PL, PELEM,PL);
           X:=ADDCGB(SECOND(PELEM),X);
           I:=I+1;
       END;
(*4*) (*Merge. *) 
      IF X <> SIL THEN X:=INV(DIPLPM(X)) END; 
(*7*) RETURN;
END MKCGB; 


PROCEDURE ADDCGB(PLIST,P: LIST): LIST; 
(*Add polynomials to comprehensive-groebner-basis. PLIST is
list of coloured polynomials. P is a list of polynomials.
Those polynomials that are not in P, are added to P without their
colouring. the result is PP. *)
VAR   APCO, APOL: LIST; 
BEGIN
      DEB_BEGIN(ADDCGB);
(*1*) IF PLIST = SIL THEN RETURN(P); END; 
(*2*) REPEAT
           ADV(PLIST, APCO,PLIST);
	   APOL:=FIRST(APCO);
           IF MEMBER(APOL,P) = 0 THEN P:=COMP(APOL,P); END; 
      UNTIL PLIST=SIL;
(*5*) RETURN(P);
END ADDCGB; 


PROCEDURE GSRED(GS: LIST): LIST; 
(*Groebner-System reduction. GS is a groebner-system. 
Returns the reduced groebner-system. *)
VAR   PELEM, RS: LIST; 
BEGIN
      DEB_BEGIN(GSRED);
(*1*) IF GS = SIL THEN RETURN(SIL); END; 
      RS:=SIL;
(*2*) REPEAT
           ADV(GS, PELEM,GS); 
           RS:=COMP(REDUCT(PELEM),RS);
      UNTIL GS=SIL;
(*5*) RETURN(RS);
END GSRED; 


PROCEDURE REDUCT(PELEM: LIST): LIST; 
(*Reduct. PELEM is a pair containing a condition and a polynomials
list determined and coloured wrt the condition.
The polynomials list is to be reduced.
The result together with the condition is R. *)
VAR   COND, J1Y, NCO, PCO, PLIST, QP, RLIST: LIST; 
BEGIN
      DEB_BEGIN(REDUCT);
(*1*) (*Get polynomials list. *)
      FIRST2(PELEM, COND,PLIST);	(* --- to do --- : <>SIL ?*)
      IF PLIST = SIL THEN RETURN(LIST2(COND,SIL)); END; 
                                        (* --- to do --- : =PELEM?*)
(*2*) (*Check degree and remove extraneous polynomials. *) 
      PCO:=CHDEGL(PLIST); 
      IF PCO <> SIL THEN RETURN(LIST2(COND,LIST1(PCO)));
                    ELSE PLIST:=REXTP(PLIST); END; 
      IF (PLIST = SIL) THEN RETURN(LIST2(COND,PLIST)); END; 
      IF (RED(PLIST) = SIL) THEN RETURN(LIST2(COND,PLIST)); END; 
      QP:=PLIST; RLIST:=SIL; 
(*3*) (*Reduction. *) 
      REPEAT
            ADV(PLIST, PCO,PLIST); 
            RDNORM(COND,PCO,QP, NCO); 
            IF NCO <> SIL THEN RLIST:=COMP(NCO,RLIST); END; 
      UNTIL PLIST=SIL;
(*7*) RETURN(LIST2(COND,INV(RLIST)));
END REDUCT; 


PROCEDURE REXTP(P: LIST): LIST; 
(*Remove extraneous polynomials. P is a list of coloured polynomials.
extraneous polynomials relative to their colouring are to be removed.
PP is the resulting list. *)
VAR   EI, EJ, PB, PCI, PCO, PS, QP, TL: LIST;
BEGIN
      DEB_BEGIN(REXTP);
(*1*) (*Length P <= 1. *)
      IF (P = SIL) THEN RETURN(P); END; 
      (* IF (RED(P) = SIL) THEN RETURN(P); END;*)
         (* ---to do---: This single pol. could be 
                         zero wrt. the new condition!
                         Is this beeing handled correctly??*)
(*2*) (*Remove extraneous polynomials. *) 
      QP:=SIL; 
      REPEAT 
            ADV(P, PCO,P);
            EI:=ColpHT(PCO); 
            IF EI <> SIL THEN
              PB:=P; TL:=0; 
              WHILE (PB <> SIL) AND (TL = 0) DO 
                   ADV(PB, PCI,PB);
                   EJ:=ColpHT(PCI); 
(* --- to do ---: check EVMT, case EJ=SIL *)
                   IF EJ <> SIL THEN TL:=EVMT(EI,EJ); END; 
              END; 
              PB:=QP; 
              WHILE (PB <> SIL) AND (TL = 0) DO
                   ADV(PB, PCI,PB);
                   EJ:=ColpHT(PCI); 
                   IF EJ <> SIL THEN TL:=EVMT(EI,EJ); END;
              END; 
              IF TL = 0 THEN QP:=COMP(PCO,QP); END; 
            END; 
      UNTIL P = SIL; 
(*5*) RETURN(INV(QP));
END REXTP; 


PROCEDURE RDNORM(COND,FCO,P: LIST; VAR NCO: LIST);
(*Reduction normalform. COND is a condition. FCO is a coloured
polynomial. P is a list of polynomials determined and coloured by COND.
NCO is the normalform of fco modulo P relative to COND. *)
VAR   PCI, QC, RE: LIST; 
BEGIN
      DEB_BEGIN(RDNORM);
(*1*) NCO:=FCO;
      LOOP
          REFIND(NCO,P, PCI,RE); 
          IF PCI = SIL THEN EXIT; END;
          GRED(COND,NCO,PCI,RE, NCO,QC);
      END;
(*4*) RETURN;
END RDNORM; 


PROCEDURE REFIND(PCO,P: LIST; VAR PLI,RE: LIST); 
(*Reduction find polynomial. PCO is a coloured polynomial.
P is a list of determined and coloured polynomials.
A polynomial for the reduction of PCO modulo P is searched.
PLI is emtpy if no polynomial is found. Else PLI is the found
polynomial and RE is the term of PCO to be eliminated. *)
VAR   ALIST, HE, HT, KEY, POL, PP, RA, SL: LIST;
BEGIN
     DEB_BEGIN(REFIND);
     RE:=SIL; PLI:=SIL; 
     IF (PCO = SIL) OR (P = SIL) THEN RETURN; END; 
     POL:=ColpPol(PCO);
     (*Get headterm of PCO. *)
     HT:=ColpHT(PCO); 
     (*Find PLI. *) 
     SL:=0;
     WHILE (POL <> SIL) AND (SL = 0) DO
          DIPMAD(POL, RA,RE,POL);
          KEYCOL(RE,ColpCol(PCO), KEY,ALIST); 
          IF (KEY<>0) AND (EQUAL(HT,RE)=0) THEN (* RE not zero (green)
     	       	    	      	   	     	   and not headterm *)
            PP:=P;
            REPEAT
                  ADV(PP, PLI,PP);
                  HE:=ColpHT(PLI); 
                  IF HE<>SIL THEN IF EVMT(RE,HE)=1 THEN RETURN; END; END;
            UNTIL (PP=SIL); 
          END; 
     END; 
     PLI:=SIL;
END REFIND; 


PROCEDURE RMGRT(COND,PP: LIST): LIST; 
(*Remove green terms. COND is a condition. PP is a list of polynomials
determined and coloured relative to COND. If COND contains coefficients
to be zero, all green monomials of the polynomials in PP are removed.
P is the resulting polynomials list. *)
VAR   COL, COND0, COND1, P, PCO, PPCO, PPOL: LIST; 
BEGIN
      DEB_BEGIN(RMGRT);
(*1*) (*Check condition. *)
      IF CondIsEmpty(COND) THEN RETURN(PP); END; 
      CondParts(COND, COND0,COND1); 
      IF COND0 = SIL THEN RETURN(PP); END; 
      P:=SIL; 
(*2*) (*Remove green monomials. *) 
      WHILE PP <> SIL DO
           ADV(PP, PCO,PP);
           COL:=SECOND(PCO); 
           PPOL:=MKPOL(PCO);
           BLINES(0); 		(* --- to do --- ??? *)
           IF NOT ColIsEmpty(COL) THEN P:=COMP(LIST2(PPOL,COL),P); END; 
      END; 
(*6*) RETURN(INV(P));
END RMGRT; 


PROCEDURE GLOBRE(COND,P: LIST): LIST; 
(*Global reduction. COND is a condition. P is a list of polynomials.
CGB is the coloured polynomials list after global reduction. *)
VAR   CGB, COL, NCO, PCO, PLIST, POL, QP: LIST; 
BEGIN
      DEB_BEGIN(GLOBRE);
(*1*) IF P = SIL THEN RETURN(SIL); END; 
(*2*) (*Colour P relative to COND. *)
      PLIST:=SIL; 
      REPEAT
            ADV(P, POL,P);
            PLIST:=COMP(ColpConsCond(POL,COND),PLIST);
      UNTIL P=SIL;
      PLIST:=INV(PLIST); 
(*3*) (*Check degree and remove green monomials. *)
      PCO:=CHDEGL(PLIST); 
      IF PCO <> SIL THEN RETURN(LIST1(PCO)); END; 
(*4*) (*Remove extraneous polynomials. *)
      PLIST:=GLEXTP(RMGRT(COND,PLIST)); 
      IF (PLIST = SIL) THEN RETURN(SIL); END; 
      IF (RED(PLIST) = SIL) THEN RETURN(PLIST); END; 
      QP:=PLIST; 
(*5*) (*Global reduction. *) 
      CGB:=SIL; 
      WHILE PLIST <> SIL DO
           ADV(PLIST, PCO,PLIST); 
           RDNORM(COND,PCO,QP, NCO);
           RDNORM(COND,NCO,CGB, NCO); 
           IF (NCO <> SIL) AND (WMEMB(ColpPol(NCO),CGB) = 0)
             THEN CGB:=COMP(NCO,CGB); END; 
      END;
(*6*) (*Merge. *) 
      RETURN(CGBLPM(CGB)); 
END GLOBRE; 


PROCEDURE GLEXTP(P: LIST): LIST; 
(*Global extraneous polynomials remove. P is a list of
coloured polynomials. Determined polynomials that are extraneous, are
removed. The resulting polynomials list is PP. *)
VAR   EI, EJ, PB, PCI, PCO, PP, TL: LIST; 
BEGIN
      DEB_BEGIN(GLEXTP);
(*1*) (*Length P <= 1. *)
      IF (P = SIL)  THEN RETURN(P); END; 
      IF (RED(P) = SIL) THEN RETURN(P); END; 
      PP:=SIL; 
(*2*) (*Remove extraneous polynomials. *) 
      REPEAT
            ADV(P, PCO,P);
            EI:=ColpHT(PCO); 
            TL:=0; 
            IF EI <> SIL THEN 
              PB:=P; 
              WHILE (PB <> SIL) AND (TL = 0) DO
                   ADV(PB, PCI,PB);
                   EJ:=ColpHT(PCI); 
                   IF EJ <> SIL THEN TL:=EVMT(EI,EJ); END; 
              END; 
              PB:=PP;
              WHILE (PB <> SIL) AND (TL = 0) DO
                   ADV(PB, PCI,PB);
                   EJ:=ColpHT(PCI); 
                   IF EJ <> SIL THEN TL:=EVMT(EI,EJ); END; 
             END; 
           END; 
           IF TL = 0 THEN PP:=COMP(PCO,PP); END; 
      UNTIL P = SIL; 
(*6*) RETURN(INV(PP));
END GLEXTP; 


END CGBSYS.

(* -EOF- *)