/*
 * groebner basis package
 * Authors : T. Shimoyama and M. Noro
 */

#define RLEX 0
#define GLEX 1
#define LEX 2
#define BRLEX 3
#define BGLEX 4
#define BLEX 5
#define ERLEX 6
#define EGLEX 7
#define ELEX 8

struct gr_flags {
	Ord;
	Elim;
	Homo;
	Sugar;
	Reduce;
	Modular;
	CriB;
	Print;
}$

#define FIRST(L) (L[0])
#define SECOND(L) (L[1])
#define THIRD(L) (L[2])
#define FOURTH(L) (L[3])
#define FIFTH(L) (L[4])

#define HM(p) dp_hm(p)
#define RP(p) dp_rest(p)
#define HT(p) dp_ht(p)
#define CO(p) dp_hc(p)
#define TD(p) dp_td(p)
#define ZERO(p) (!(p))
#define LCM(l) THIRD(l)
#define CPSUGAR(l) FOURTH(l)
#define MAX(a,b) ((a)>(b)?(a):(b))
#define CPUTIME (time()[0])

#define TIMING(a,t) (t)=CPUTIME; (a); (t)=CPUTIME-(t)
#define TIMING_SUM(a,t,v) (t)=CPUTIME; (a); (t)=CPUTIME-(t); (v) += (t)

extern Ord$
extern PS,PSM,PSH,PSS$
extern PSN,PSLen$
extern PRINT$
extern NOREDUCE,NOSUGAR,NOCRIB$
extern NOMC,NOGC$
extern MINDEX$
extern TOPREDUCE$

def allon() { PRINT=1$ NOREDUCE=0$ NOSUGAR=0$ }

def alloff() { PRINT=0$ NOREDUCE=1$ NOSUGAR=1$ }

def gr(F,V) { return gr_main(F,V,0,0); }

def hgr(F,V) { return gr_main(F,V,1,0); }

def grm(F,V) { return gr_main(F,V,0,1); }

def hgrm(F,V) { return gr_main(F,V,1,1); }

def gr_inner(B,V,F)
{
	struct gr_flags F;
	
	Ord = F->Ord;
	if ( Ord >= ERLEX )
		dp_nelim(F->Elim);
	NOSUGAR = !(F->Sugar);
	NOCRIB = !(F->CriB);
	NOREDUCE = !(F->Reduce);
	PRINT = F->Print;
	return gr_main(B,V,F->Homo,F->Modular);
}

def gr_main(F,V,HOMO,MODULAR) {
	if ( type(F) != 4 || type(V) != 4 )
		error("gr_main : invalid inputs");
	VC = setminus(vars(F),V);
	dp_ord(Ord);
	if ( HOMO ) {
		Ord1 = Ord == 0 ? 0 
			:(Ord == 2 ? 1 : error("gr_main : invalid order type"));
		for ( I = length(F)-1, Fd = []; I >= 0; I-- )
			Fd = cons(dp_homo(dp_ptod(F[I],V)),Fd);
		dp_ord(Ord1);
	} else
		for ( I = length(F)-1, Fd = []; I >= 0; I-- )
			Fd = cons(dp_ptod(F[I],V),Fd);
	M = MODULAR ? lprime(MINDEX) : 0;
	SUBST = makesubst(VC);
	S = setup_arrays(Fd,SUBST);
	while ( 1 ) {
		if ( PRINT && MODULAR )
			print(["M",M,"EVAL",SUBST]);
		X = gb(S,M,SUBST);
		if ( X ) {
			if ( HOMO )
				X = reducebase_dehomo(X);
			dp_ord(Ord);
			X = reduceall(X,SUBST);
			if ( MODULAR ) {
				if ( membercheck(S,X,HOMO) && gbcheck(X) )
					break;
			} else
				break;
		}
		if ( MODULAR ) {
			MINDEX++; M = lprime(MINDEX);
		}
		SUBST = makesubst(VC);
		PSN = length(S);
		for ( I = PSN; I < PSLen; I++ )
			PSS[I] = PSH[I] = PS[I] = 0;
	}
	for ( T = [], TX = X; TX != []; TX = cdr(TX) )
		T = cons(dp_dtop(PS[car(TX)],V),T);
	return T;
}

def setup_arrays(Fd,SUBST) {
	Fd = dp_sort(Fd,1);
	PSN = length(Fd); PSLen = 2*PSN;
	PS = newvect(PSLen); PSH = newvect(PSLen); PSS = newvect(PSLen);
	for ( I = 0; I < PSN; I++, Fd = cdr(Fd) ) {
		PS[I] = prim_part(car(Fd),SUBST); PSH[I] = dp_ht(PS[I]);
		PSS[I] = dp_sugar(PS[I]);
	}
	for ( S = [], I = PSN - 1; I >= 0; I-- )
		S = cons(I,S);
	return S;
}

def reducebase_dehomo(X)
{
	N = length(X);
	W = newvect(N);
	for ( I = 0; I < N; I++ )
		W[I] = dp_dehomo(PSH[X[I]]);
	for ( I = 0, Y = []; I < N; I++ ) {
		for ( J = 0, D = W[I]; J < N; J++ )
			if ( (I != J) && dp_redble(D,W[J]) )
				break;
		if ( J == N )
			Y = cons(newps(dp_dehomo(PS[X[I]]),0,[]),Y);
	}
	return Y;
}

def membercheck(L,X,HOMO)
{
	if ( NOMC )
		return 1;
	T0 = CPUTIME;
	for ( T = L; T != []; T = cdr(T) ) {
		TIMING(NF = dp_nf(X,HOMO?dp_dehomo(PS[car(T)]):PS[car(T)],PS,1),T1);
		if ( PRINT )
			print(["NF of ",car(T),T1,NF?"failed":"ok"]);
		if ( NF )
			return 0;
	}
	if ( PRINT )
		print(["MEMBERCHECK",CPUTIME-T0]);
	return 1;
}

def gbcheck(F)
{
	if ( NOGC )
		return 1;
	T0 = CPUTIME;
	G=[]; GALL = [];D = [];
	for (R = F; R != []; R = cdr(R)) {
		T = car(R);
		D = updpairs(D,G,T,0);
		G = updbase(G,T);
		GALL = append(GALL,[T]);
	}
	while ( D != [] ) {
		L = car(D); D = cdr(D);
		H = dp_sp(PS[FIRST(L)],PS[SECOND(L)]);
		if( PRINT )
			print([FIRST(L),SECOND(L)]);
		H = dp_nf(GALL,H,PS,1);
		if ( !ZERO(H) )
			return 0;
	}
	if ( PRINT )
		print(["GBCHECK",CPUTIME-T0]);
	return 1;
}

def gb(F,M,SUBST)
{
	NFMOD = 0;
	if ( M ) {
		PSM = newvect(PSLen);
		for ( I = 0; I < PSLen; I++ )
			if ( PSH[I] && !validhc(PS[I],M,SUBST) )
				return 0;
			else
				PSM[I] = dp_mod(PS[I],M,SUBST);
	}
	G=[]; GALL = [];D = [];
	for (R = F; R != []; R = cdr(R)) {
		T = car(R);
		TIMING_SUM(D = updpairs(D,G,T,NOCRIB),T0,Updatep);
		G = updbase(G,T); GALL = append(GALL,[T]);
	}
	while ( D != [] ) {
		L1 = dp_minp(D,NOSUGAR); L = L1[0]; D = L1[1];
		if ( M ) {
			TIMING(H = dp_sp_mod(PSM[L[0]],PSM[L[1]],M),T0);
			TIMING(H = dp_nf_mod(GALL,H,PSM,M),T1);
			NFMOD += (T0 + T1);
		} else {
			H = 1; T1 = 0;
		}
		if ( H ) {
			TIMING_SUM(H = dp_sp(PS[L[0]],PS[L[1]]),T0,Spoly);
			TIMING(H = dp_nf(GALL,H,PS,!TOPREDUCE),T0);
			T1 += T0;
		}
		Nftime += T1;
		if ( H ) {
			TIMING_SUM(NH = newps(prim_part(H,SUBST),M,SUBST),T0,Ptozp);
			if ( NH < 0 )
				return 0;
			TIMING_SUM(D = updpairs(D,G,NH,NOCRIB),T0,Updatep);
			G = updbase(G,NH); GALL = append(GALL,[NH]);
		}
		if ( PRINT )
			print([L[0],L[1],"NFT",T1,"NB",length(G),
				"NAB",length(GALL),"RP",length(D),H?PSH[NH]:0]);
		if ( !TD(PSH[NH]) )
			break;
	}
	if ( PRINT ) {
		print(["PZ",Ptozp,"UP",Updatep, "SP",Spoly,
		"NF",Nftime-NFMOD, "NFMOD",NFMOD]);
	}
	return G;
}

def newps(A,M,SUBST)
{
	if ( M && !validhc(A,M,SUBST) )
		return -1;
	if ( PSN == PSLen ) {
		PSLen *= 2;
		PS = realloc_array(PS,PSN,PSLen);
		PSH = realloc_array(PSH,PSN,PSLen);
		PSS = realloc_array(PSS,PSN,PSLen);
		if ( M )
			PSM = realloc_array(PSM,PSN,PSLen);
	}
	PS[PSN] = A;
	PSH[PSN] = dp_ht(A);
	PSS[PSN] = dp_sugar(A);
	if ( M )
		PSM[PSN] = dp_mod(A,M,SUBST);
	return PSN++;
}

def realloc_array(A,N,L)
{
	T = newvect(L);
	for ( I = 0; I < N; I++ )
		T[I] = A[I];
	return T;
}

def dp_sort(A,DEC)
{
	for ( T = [], L = A; L != []; L = cdr(L) )
		T = sort_by_hd(T,car(L));
	return DEC ? T : reverse(T);
}

def sort_by_hd(A,E) {
	if ( A == [] )
		return [E];
	else if ( E > car(A) )
		return cons(E,A);
	else
		return cons(car(A),sort_by_hd(cdr(A),E));
}

def dpi_sort(A,DEC)
{
	for ( T = [], L = A; L != []; L = cdr(L) )
		T = sort_by_hdi(T,car(L));
	return DEC ? T : reverse(T);
}

def sort_by_hdi(A,E) {
	if ( A == [] )
		return [E];
	else if ( PSH[E] > PSH[car(A)] )
		return cons(E,A);
	else
		return cons(car(A),sort_by_hdi(cdr(A),E));
}

def criM(D1)
{
	for ( E = D1, DD = []; E != []; E = D3 ) {
		IT = car(E);
		if ( length(E) == 1 ) {
			DD = cons(IT,DD); break;
		}
		for ( D2 = cdr(E), D3 = []; D2 != []; D2 = cdr(D2) ) {
			JT = car(D2); TIT = LCM(IT); TJT = LCM(JT);
			if (TIT != TJT) {
				if (dp_redble(TJT,TIT) == 1)
					continue; /* delete JT */
				else if (dp_redble(TIT,TJT) == 1) {
					IT = -1;
					D3 = cdr(E);
					break; /* delete IT */
				}
			}
			D3 = cons(JT,D3);
		}
		if (IT >= 0)
			DD = cons(IT,DD);
	}
	return DD;
}

def blockd(D1)
{
	for ( D2 = [], R = []; D1 != []; D1 = R, R = [] ) {
		LI = car(D1); TI = LCM(LI); W = [LI];
		for ( S = cdr(D1); S != []; S = cdr(S) ) {
			LJ = car(S); TJ = LCM(LJ);
			if (TI == TJ)
				W = cons(LJ,W);
			else
				R = cons(LJ,R);
		}
		D2 = cons(W,D2);
	}
	return D2;
}

def criF(D1)
{
	if (length(D1) == 1)
		return D1;
	D2 = [];
	for (A = blockd(D1);A != []; A = cdr(A)) {
		W = car(A);
		if (length(W) == 1)
			R = car(W);
		else
			for (R = car(W),S=CPSUGAR(R),W = cdr(W); W != [];W = cdr(W)) {
				U = car(W);
				if (dp_cri2(PSH[FIRST(U)],PSH[SECOND(U)])) {
					R = U; break;
				}
				T = CPSUGAR(U);
				if (T < S)
					R = U;
			}
		D2 = cons(R,D2);
	}
}

def updpairs(D,G,T,NCRIB)
{
	if (G == [])
		return (D);
	if (!NCRIB && D != [])
		D = dp_criB(D,T,PS); 
	D1 = newpairs(G,T);
	if (length(D1) != 1) {
		D1 = criM(D1);
		D1 = criF(D1);
	}
	for (DD = D1,D1 = [];DD != []; DD = cdr(DD)) {
		U = car(DD);
		if (!dp_cri2(PSH[FIRST(U)],PSH[SECOND(U)]))
			D1 = cons(U,D1);
	}
	D = append(D,D1);
	return D;
}

def updbase(G,T)
{
	for ( GL = reverse(G), W = [T], DT = PSH[T]; GL != []; GL = cdr(GL) ) {
		I = car(GL); DI = PSH[I];
		if ( dp_redble(DI,DT) <= 0 )
			W = cons(I,W);
	}
	return W;
}

def newpairs(G,T)
{
	for (D1 = [],R = G;R != [];R = cdr(R)) {
		I = car(R);
		M = dp_lcm(PSH[I],PSH[T]);
		A = PSS[I]-TD(PSH[I]);
		B = PSS[T]-TD(PSH[T]);
		S = MAX(A,B)+TD(M);
		D1 = cons([I,T,M,S],D1);
	}
	return D1;
}

def validhc(A,M,SUBST)
{
	return (A && (subst(dp_hc(A),SUBST) % M)) ? 1 : 0;
}

def reduceall(G,SUBST)
{
	if ( NOREDUCE )
		return G;
	R = dpi_sort(G,0);
	for (B = []; R != []; ) {
		A = car(R); R = cdr(R);
		TIMING(NF = dp_nf(append(B,R),PS[A],PS,1),T0);
		if ( PRINT )
			print(["NF of ",A,T0]);
		B = append(B,[newps(prim_part(NF,SUBST),0,[])]);
	}
	return B;
}

def p_nf(P,B,V,O) {
	dp_ord(O); DP = dp_ptod(P,V);
	N = length(B); DB = newvect(N);
	for ( I = N-1, IL = []; I >= 0; I-- ) {
		DB[I] = dp_ptod(B[I],V);
		IL = cons(I,IL);
	}
	return dp_dtop(dp_nf(IL,DP,DB,1),V);
}

def p_terms(D,V)
{
	for ( L = [], T = dp_ptod(D,V); T; T = dp_rest(T) )
		L = cons(dp_dtop(dp_ht(T),V),L);
	return reverse(L);
}

def dp_terms(D,V)
{
	for ( L = [], T = D; T; T = dp_rest(T) )
		L = cons(dp_dtop(dp_ht(T),V),L);
	return reverse(L);
}

def gb_comp(A,B)
{
	for ( T = A; T != []; T = cdr(T) ) {
		for ( S = B, M = car(T), N = -M; S != []; S = cdr(S) )
			if ( car(S) == M || car(S) == N )
				break;
		if ( S == [] )
			break;
	}
	return T == [] ? 1 : 0;
}

def setminus(A,B) {
	for ( T = reverse(A), R = []; T != []; T = cdr(T) ) {
		for ( S = B, M = car(T); S != []; S = cdr(S) )
			if ( car(S) == M )
				break;
		if ( S == [] )
			R = cons(M,R);
	}
	return R;
}

def makesubst(VL)
{
	for ( T = reverse(VL), R = []; T != []; T = cdr(T) )
		R = cons(car(T),cons(random(),R));
	return R;
}

def prim_part(A,SUBST)
{
	if ( SUBST != [] )
		return dp_prim(A);
	else
		return dp_ptozp(A);
}
end$
