load("gr")$
load("bfct")$

extern Order$
extern PaVa$
extern XXDD$
extern LENP$

/*-------------------------------------------------------------*/

def newcgsw(F,Para,VarOpe,Jun){
tstart();

ALL=cgsw_nabe(F,Para,VarOpe,Jun);

N=length(ALL);
CGB=ALL;
while(CGB!=[]){
	CB=car(CGB);
	CGB=cdr(CGB);
	print(CB[0],1);
	print(CB[1],1);
	print(" ", 1);
}

print("No. of segment is"); 
print(N);
return tstop();
}

/*-------------------------------------------------------------*/
/*見やすい表現。strata はgrで計算される*/

def newcgsw1(F,Para,VarOpe,Jun){
tstart();

ALL=cgsw_nabe1(F,Para,VarOpe,Jun);

N=length(ALL);
CGB=ALL;
while(CGB!=[]){
	CB=car(CGB);
	CGB=cdr(CGB);
	print(CB[0],1);
	print(CB[1],1);
	print(" ", 1);
}

print("No. of segment is"); 
print(N);
return tstop();
}

/*-------------------------------------------------------------*/
/*見やすい表現。strata はgrで計算される*/
/*条件付き*/

def sup_cgsw(Sup,F,Para,VarOpe,Jun){
tstart();

ALL=sup_cgsw1(Sup,F,Para,VarOpe,Jun);

N=length(ALL);
CGB=ALL;
while(CGB!=[]){
	CB=car(CGB);
	CGB=cdr(CGB);
	print(CB[0],1);
	print(CB[1],1);
	print(" ", 1);
}

print("No. of segment is"); 
print(N);
return tstop();
}


/*-------------------------------------------------------------*/

def cgsw_nabe(List,Para,VarOpe,Ord){

NEW=make_vari(Para,VarOpe[0],VarOpe[1],Ord); 

/*NEW[0] is symbols and NEW[1] is the order.*/

PaVa=NEW[0];
Order=NEW[1];
XXDD=append(VarOpe[0],VarOpe[1]);
if(NEW==0){
	return("ERROE. Plese input a correst order.");
}

G=groebnerbasisw(List,NEW[0],NEW[1]);


if(G[0]==1){
	return [[[[0],[1]],[1]]];
}
dp_ord(Ord);

GD=map(dp_ptod,G,XXDD);

MH=miniht_ka(GD,XXDD,Ord); /*kapur 戦略 */
/*MH[0]=MHT, MH[1]=[head coefs], MH[2]=[GB]*/

if(MH[1]!=[]){
	Kake=kake_mult(MH[1],Para);
}else{
Kake=[1,[]];
}

One=one_cgsw_make(MH[0],MH[2],Kake[0],Para,XXDD,Ord);

ALL=[One];


Pc=Kake[1]; /*掛け算の要素*/
NV=1;
while(Pc!=[]){
		Pc1=car(Pc);
		Pc=cdr(Pc);	
		AA=empty_check([[Pc1],[NV]],Para);
		if(AA!=0){
		ZA=cgsw_body(G,[[Pc1],[NV]],Para,Ord);}
		NV=NV*Pc1;
		ALL=append(ZA,ALL);}
return ALL;
}

/*-------------------------------------------------------------*/
/*見やすい表現。strata はgrで計算される*/

def cgsw_nabe1(List,Para,VarOpe,Ord){

NEW=make_vari(Para,VarOpe[0],VarOpe[1],Ord); 

/*NEW[0] is symbols and NEW[1] is the order.*/

PaVa=NEW[0];
Order=NEW[1];
XXDD=append(VarOpe[0],VarOpe[1]);
if(NEW==0){
	return("ERROE. Plese input a correst order.");
}

G=groebnerbasisw(List,NEW[0],NEW[1]);


if(G[0]==1){
	return [[[[0],[1]],[1]]];
}
dp_ord(Ord);

GD=map(dp_ptod,G,XXDD);

MH=miniht_ka(GD,XXDD,Ord); /*kapur 戦略 */
/*MH[0]=MHT, MH[1]=[head coefs], MH[2]=[GB]*/

if(MH[1]!=[]){
	Kake=kake_mult(MH[1],Para);
}else{
Kake=[1,[]];
}

One=one_cgsw_make(MH[0],MH[2],Kake[0],Para,XXDD,Ord);

ALL=[One];


Pc=Kake[1]; /*掛け算の要素*/
NV=1;
while(Pc!=[]){
		Pc1=car(Pc);
		Pc=cdr(Pc);	
		AA=empty_check([[Pc1],[NV]],Para);
		if(AA!=0){
		ZA=cgsw_body11(G,[[Pc1],[NV]],Para,Ord);}
		NV=NV*Pc1;
		ALL=append(ZA,ALL);}
return ALL;
}

/*-------------------------------------------------------------*/
/*条件付き見やすい表現。strata はgrで計算される*/

def sup_cgsw1(Sup,List,Para,VarOpe,Ord){

NEW=make_vari(Para,VarOpe[0],VarOpe[1],Ord); 

/*NEW[0] is symbols and NEW[1] is the order.*/

PaVa=NEW[0];
Order=NEW[1];
XXDD=append(VarOpe[0],VarOpe[1]);
if(NEW==0){
	return("ERROE. Plese input a correst order.");
}
dp_ord(Ord);

ZA=cgsw_body55(List,Sup,Para,Ord,1);
return ZA;

/*---------以下いらない
SG2=gr(Sup[1],Para,0);
if(length(Sup[0])==1){
Kake=kake_mult(Sup[0],Para);
Pc=Kake[1];
ALL=[];
while(Pc!=[]){
		Pc1=car(Pc);
		Pc=cdr(Pc);	
		AA=empty_check([[Pc1],SG2],Para);
		if(AA!=0){
		ZA=cgsw_body55(List,[[Pc1],SG2],Para,Ord);}
		ALL=append(ZA,ALL);}
return ALL;
}
AA=empty_check([Sup[0],SG2],Para);
if(AA!=0){
ZA=cgsw_body55(List,Sup,Para,Ord);
ALL=append(ZA,ALL);}
return ALL;
----------*/

}

/*-----------------------------------------------------*/
/*-----------------------------------------------------*/
/*----  CGS computation Main in Weyl algebra   --------*/
/*-----------------------------------------------------*/
/*-----------------------------------------------------*/
/*-------------------------------------------------------------*/


def cgsw_body(F,Sup,Para,Jun){

FA=append(F,Sup[0]);

G=groebnerbasisw(FA,PaVa,Order);


if(G==[1]){
	return [[Sup,G]];}

dp_ord(Jun);
GD=map(dp_ptod,G,XXDD);
/*GDからパラメタのみの多項式を引く*/
GZ=minu_para(GD,XXDD,Jun);
GG=map(dp_dtop,GZ,XXDD);


if(GZ==[]){
	return [[Sup,G]];}
MH=miniht_ka(GZ,XXDD,Jun); /*kapur 戦略 */

/*MH[0]=MHT, MH[1]=[MHT coefs], MH[2]=[GB]*/

if(MH[1]!=[]){
	Kake=kake_mult(MH[1],Para);
}else{
Kake=[1,[]];
}
One=one_cgsw_make22(MH[0],Sup,MH[2],Kake[0],Para,XXDD,Jun);
  if(One==0){
	ALL=[];}else{
  ALL=[One];}

Pc=Kake[1]; /*１つづつの元*/

NV=1;
while(Pc!=[]){
		Pc1=car(Pc);
		Pc=cdr(Pc);
/*SU1=variety_refine(cons(Pc1,Sup[0]),Para);*/
SU1=gr(cons(Pc1,Sup[0]),Para,0);
SU2=Sup[1][0]*NV;
		AA=empty_check([SU1,[SU2]],Para);
		if(AA!=0){
		ZA=cgsw_body(GG,[SU1,[SU2]],Para,Jun);
		ALL=append(ZA,ALL);}
		NV=NV*Pc1;}
return ALL;
}

/*-------------------------------------------------------------*/

def cgsw_body11(F,Sup,Para,Jun){

FA=append(F,Sup[0]);

G=groebnerbasisw(FA,PaVa,Order);


if(G==[1]){
	return [[Sup,G]];}

dp_ord(Jun);
GD=map(dp_ptod,G,XXDD);
/*GDからパラメタのみの多項式を引く*/
GZ=minu_para(GD,XXDD,Jun);
GG=map(dp_dtop,GZ,XXDD);


if(GZ==[]){
	return [[Sup,G]];}
MH=miniht_ka(GZ,XXDD,Jun); /*kapur 戦略 */

/*MH[0]=MHT, MH[1]=[MHT coefs], MH[2]=[GB]*/

if(MH[1]!=[]){
	Kake=kake_mult(MH[1],Para);
}else{
Kake=[1,[]];
}
One=one_cgsw_makenew22(MH[0],Sup,MH[2],Kake[0],Para,XXDD,Jun);
  if(One==0){
	ALL=[];}else{
  ALL=[One];}

Pc=Kake[1]; /*１つづつの元*/
NV=1;
while(Pc!=[]){
		Pc1=car(Pc);
		Pc=cdr(Pc);
/*SU1=variety_refine(cons(Pc1,Sup[0]),Para);*/
SU1=gr(cons(Pc1,Sup[0]),Para,0);
SU2=Sup[1][0]*NV;
		AA=empty_check([SU1,[SU2]],Para);
		if(AA!=0){
		ZA=cgsw_body11(GG,[SU1,[SU2]],Para,Jun);
		ALL=append(ZA,ALL);}
		NV=NV*Pc1;}
return ALL;
}

/*--------------------------------------*/

def cgsw_body55(F,Sup,Para,Jun,Flag){

FA=append(F,Sup[0]);

G=groebnerbasisw(FA,PaVa,Order);

if(G==[1]){
	return [[Sup,G]];}

dp_ord(Jun);
GD=map(dp_ptod,G,XXDD);
/*GDからパラメタのみの多項式を引く*/
GZ=minu_para22(GD,XXDD,Jun);
GG=map(dp_dtop,GZ[0],XXDD);
GZ2=map(dp_dtop,GZ[1],XXDD);

SSUU=make_sup_cond(Sup,GZ2,Para);
Sup=SSUU[0];

if(GZ[0]==[]){
	return [[Sup,G]];}
MH=miniht_ka(GZ[0],XXDD,Jun); /*kapur 戦略 */

/*MH[0]=MHT, MH[1]=[MHT coefs], MH[2]=[GB]*/

if(MH[1]!=[]){
	Kake=kake_mult(MH[1],Para);
}else{
Kake=[1,[]];
}
if(Sup[0][0]==0 && GZ2!=[]){
One=one_cgsw_makenew2255(Sup,Kake[0]);
}else{
One=one_cgsw_makenew2244(Flag,MH[0],Sup,MH[2],Kake[0],Para,XXDD,Jun);
}
  if(One==0){
	ALL=[];}else{
  ALL=[One];}

Pc=Kake[1]; /*１つづつの元*/
NV=1;
while(Pc!=[]){
		Pc1=car(Pc);
		Pc=cdr(Pc);
/*SU1=variety_refine(cons(Pc1,Sup[0]),Para);*/
SU1=gr(cons(Pc1,Sup[0]),Para,0);
SU2=Sup[1][0]*NV;
		AA=empty_check([SU1,[SU2]],Para);
		if(AA!=0){
		ZA=cgsw_body55(GG,[SU1,[SU2]],Para,Jun,2);
		ALL=append(ZA,ALL);}
		NV=NV*Pc1;}
if(length(SSUU)!=1){
ZA=cgsw_body55(F,SSUU[1],Para,Jun,2);
return append(ZA,ALL);}else{
return ALL;}

}

/*---------------------*/

def make_sup_cond(Sup,Ze,Para){

if(Sup[0][0]==0){
	return [Sup];
	}

A=gb_comp(Sup[0],Ze);
if(A==1){
	return [Sup];
}

N1=idealq(Sup[0],Ze,Para);
if(Sup[1][0]!=1){
	N2=gr(append(Sup[1],Ze),Para,0);
}else{
	N2=Ze;}
return [[Ze,Sup[1]],[N1,gr(append(N1,N2),Para,0)]];

}

/*--------------------------------------*/

def groebnerbasisw(List,V,Ord){

G=dp_weyl_gr_main(List,V,0,1,Ord);

return G;
}



/*-------------------------------------------------------------*/

def kake_mult(MH,Para){
A=1;
while(MH!=[]){
	M1=car(MH);
	MH=cdr(MH);
	A=A*M1;
}

if(type(A)==1){
		return [1,[]];}
L=[];
K=fctr(A);
N=length(K);
for(I=1;I<=N-1;I++){
	L=cons(K[I][0],L);
}
B=1;
LL=L;
while(L!=[]){
	L1=car(L);
	L=cdr(L);
	B=B*L1;
}
return [B,LL];
}

/*-------------------------------------------------------------*/
/* computation of minimal head terms */
/*outputs [[M1,M2,...minimal head terms],[MHTの係数(定数なし)],[MHTをもつ多項式たち]]*/

def miniht_ka(G,Va,Jun){
dp_ord(Jun);
F=[];
HG=G;
while(HG!=[]){
	F1=car(HG);
	HG=cdr(HG);
	Ht=dp_ht(F1);
	F=cons(Ht,F);
}
MT=dp_gr_main(map(dp_dtop,F,Va),Va,0,1,Jun);
/*G=sort_degmini(G,Jun);*/
MD=sort_degmini(map(dp_ptod,MT,Va),Jun);

P=G;
LL=[];
while(MD!=[]){
	M1=car(MD);
	MD=cdr(MD);
	K=P;
	P=[];
	L=[];
	while(K!=[]){
		K1=car(K);
		if(M1==dp_ht(K1)){
			L=cons(K1,L);
			K=cdr(K);
		}else{
			K=cdr(K);
			P=cons(K1,P);
		}
}
LL=cons(L,LL);
}
CO=[];
EM=[];
while(LL!=[]){
	LP=car(LL);
	LL=cdr(LL);
	while(LP!=[]){
		U1=car(LP);
		if(constant(U1,Va)!=1){
			EM=cons(U1,EM);
			CO=cons(keisu_para(U1,Va,Jun),CO);
			break;
		}else if(length(LP)==1){
			EM=cons(U1,EM);
			break;
		}else{
			LP=cdr(LP);}
}
}
return [MT,CO,EM];
}



/*-------------------------------------------------------------*/

def constant(K,Va){

while(K!=0){
	HT=dp_ht(K);
	HC=dp_hc(K);
	P=K-HT*HC;
	if(dp_ht(P)!=HT){
		break;
	}else{
	K=P;}
}
if(type(HC)==1){
	return 1;
}
return 0;
}

/*-------------------------------------------------------------*/
/*R!=0となるもの、１つだけ*/

def one_cgsw_make(MH,F,R,Para,Vari,Jun){

if(MH[0]==1){
return [[[0],[R]],[1]];
}

return [[[0],[R]],map(dp_dtop,F,Vari)];

}



/*-------------------------------------------------------------*/

/*Rはひとつだけ*/

def one_cgsw_make22(HM,Sup,F,R,Para,Vari,Jun){

AA=empty_check([Sup[0],[Sup[1][0]*R]], Para);

if(AA!=0){
if(HM[0]==1){
	return [[Sup[0],[Sup[1][0]*R]],[1]];
	}

return [[Sup[0],[Sup[1][0]*R]],map(dp_dtop,F,Vari)];
}else{
return 0;
}
}

/*-------------------------------------------------------------*/

/*Rはひとつだけ*/

def one_cgsw_makenew22(HM,Sup,F,R,Para,Vari,Jun){

AA=empty_check([Sup[0],[Sup[1][0]*R]], Para);

if(AA!=0){
if(HM[0]==1){
	return [[Sup[0],gr(cons(Sup[1][0]*R,Sup[0]),Para,0)],[1]];
	}
return [[Sup[0],gr(cons(Sup[1][0]*R,Sup[0]),Para,0)],map(dp_dtop,F,Vari)];
}else{
return 0;
}
}

/*-------------------------------------------------------------*/

def one_cgsw_makenew2244(Flag, HM,Sup,F,R,Para,Vari,Jun){

AA=empty_check([Sup[0],[Sup[1][0]*R]], Para);

if(AA!=0){
if(HM[0]==1){
	return [[Sup[0],gr(cons(Sup[1][0]*R,Sup[0]),Para,0)],[1]];
	}
if(Flag==1){
N2=gr(cons(Sup[1][0]*R,Sup[0]),Para,0);

IQ=idealq(Sup[0],N2,Para);
FA=append(map(dp_dtop,F,Vari),IQ);
G=groebnerbasisw(FA,PaVa,Order);
dp_ord(Jun);
GD=map(dp_ptod,G,XXDD);
GZ=minu_para22(GD,XXDD,Jun);
GG=map(dp_dtop,GZ[0],Vari);
return [[IQ,gr(append(IQ,N2),Para,0)],GG];
}else{
return [[Sup[0],gr(cons(Sup[1][0]*R,Sup[0]),Para,0)],map(dp_dtop,F,Vari)];
}

}else{
return 0;
}
}

/*-------------------------------------------------------------*/

def one_cgsw_makenew2255(Sup,R){
return [[[0],Sup[1][0]*R],[1]];
}

/*--------------------*/
/*   sort 関係の関数  */
/*--------------------*/
/*left small, right big*/

def sort_degmini(H,Jun){

if(length(H)==1) return(H);
if(H==[]) return(H);
dp_ord(Jun);
H1=car(H);
H0=dp_ht(H1);
H=cdr(H);
L=[];
S=[];
while(H!=[]){
	H2=car(H);
	H=cdr(H);
	if(H0>dp_ht(H2)){
		S=cons(H2,S);
	}else{
		L=cons(H2,L);
}}
S=sort_degmini(S,Jun);
L=sort_degmini(L,Jun);
Sor=append(S,cons(H1,L));
return(Sor);
}

/*-------------------------------------------------------------*/

def keisu_para(K1,Va,Jun){
dp_ord(Jun);

HT=dp_ht(K1);
HC=dp_hc(K1);
K1=K1-HC*HT;
	while(dp_ht(K1)==HT){
		HC1=dp_hc(K1);
		HC=HC+HC1;
		K1=K1-HC1*HT;
		}
return HC;
}

/*-------------------------------------------------------------*/

def minu_para(G,Va,Jun){
dp_ord(Jun);

L=[];
while(G!=[]){
	G1=car(G);
	G=cdr(G);
	if(dp_dtop(dp_ht(G1),Va)!=1){
		L=cons(G1,L);
	}
}
return L;
}

/*-------------------------------------------------------------*/

def minu_para22(G,Va,Jun){
dp_ord(Jun);

L=[];
R=[];/*パラメータのリスト*/
while(G!=[]){
	G1=car(G);
	G=cdr(G);
	if(dp_dtop(dp_ht(G1),Va)!=1){
		L=cons(G1,L);
	}else{
	R=cons(G1,R);}
}
return [L,R];
}


/*-----------------------------------------------------*/
/*-----------------------------------------------------*/
/*---------Matrix orders and fake parameters-----------*/
/*-----------------------------------------------------*/
/*-----------------------------------------------------*/

def make_vari(Para,Var,Ope,Ord){

FakeV=make_fake(Para);
/*FakeV[0] is the list of fake variables. 
   FakeV[1] is the number of parameters.*/

NV1=append(Var,FakeV[0]);
NO1=append(Ope,Para);
ALLV=append(NV1,NO1);
VN=length(Var);

if(Ord==0 || Ord ==1 || Ord ==2){
	Num=FakeV[1]+2*VN;
	NOrder=[[Ord,Num],[0,FakeV[1]]];
	return [ALLV,NOrder];

} else if(type(Ord)==6){ /* matrix orders */

	MA=matrix_make(FakeV[1],VN,Ord);
	return [ALLV,newmat(2*FakeV[1]+2*VN,2*FakeV[1]+2*VN,MA)];

} else if(type(Ord)==4){ /* block orders */
	MA1=block_matrix(VN,Ord);
	MAT=matrix_make(FakeV[1],VN,MA1);
	return [ALLV,newmat(2*FakeV[1]+2*VN,2*FakeV[1]+2*VN,MAT)];

} else {
	return 0;}

}

/*--------------------------------------*/

def make_fake(Para){

N=length(Para);
A=rtostr(fa);
M=[];
for(I=N;I>=1;I--){
	B2=strtov(A+rtostr(I));
	M=cons(B2,M);
}
return [M,N];
}

/*--------------------------------------*/

def matrix_make(PN,VN,Mat){

	AB=divid_m(Mat,VN);
	CD=make_grlx(PN); /*逆*/
	MAT=[];
	MAT=make_mat_cd(MAT,CD,PN,VN);
	MAT=make_mat_ab(MAT,AB,PN,VN);

return MAT;
}

/*--------------------------------------*/

def divid_m(M,N){
	A=[];
	B=[];
	for(I=0;I<=2*N-1;I++){
		AA=[];
		A1=vtol(M[I]);
		for(J=0;J<=N-1;J++){
			AA=cons(car(A1),AA);
			A1=cdr(A1);
			}
		A=cons(AA,A);
		B=cons(A1,B);
	}
return [A,B];
}

/*--------------------------------------*/

def make_grlx(N){
A1=[];
for(I=0;I<=N-1;I++){
	A1=cons(1,A1);
}
H=[A1];
for(U=0;U<=N-2;U++){
	B1=[];
	for(J=0;J<=N-1;J++){
		if(U==J){
		B1=cons(-1,B1);
		}else{
		B1=cons(0,B1);
		}
	}
	H=cons(B1,H);
}
return H;
}

/*--------------------------------------*/

def make_mat_cd(MAT,CD,PN,VN){

CD1=CD;
while(CD1!=[]){
	A=car(CD1);
	CD1=cdr(CD1);
	for(I=0;I<=PN+2*VN-1;I++){
		A=cons(0,A);
	}
	MAT=cons(A,MAT);
}
ZE=vtol(newvect(PN+VN));
while(CD!=[]){
	B=car(CD);
	CD=cdr(CD);
	for(J=0;J<=VN-1;J++){
		B=cons(0,B);
		}
	MAT=cons(append(B,ZE),MAT);
}
return MAT;

}

/*--------------------------------------*/

def make_mat_ab(MAT,AB,PN,VN){
G=AB[1];
YO=[];
ZE=vtol(newvect(PN));
while(G!=[]){
	B=car(G);
	G=cdr(G);
	K1=append(append(ZE,B),ZE);
	YO=cons(K1,YO);
	}
L=reverse(YO);
H=AB[0];
while(H!=[]){
	H1=car(H);
	F=car(L);
	L=cdr(L);
	while(H1!=[]){
		F=cons(car(H1),F);
		H1=cdr(H1);
	}
	MAT=cons(F,MAT);
	H=cdr(H);
}
return MAT;
}

/*--------------------------------------*/

def block_matrix(VN,Ord){

OMA=[];
R=reverse(Ord);
R1=car(R);
H1=select_order(R1[0],R1[1]);
LS=R1[1];
W=2*VN-LS;

while(H1!=[]){
	A=car(H1);
	H1=cdr(H1);
	for(I=0;I<=W-1;I++){
		A=cons(0,A);
	}
	OMA=cons(A,OMA);
}

R=cdr(R);

while(R!=[]){
	R1=car(R);
	H1=select_order(R1[0],R1[1]);
	OMA=list_ord_mat(2*VN-R1[1]-LS,H1,LS,OMA);
	LS=LS+R1[1];
	R=cdr(R);
}
	return newmat(2*VN,2*VN,OMA);
}

/*--------------------------------------*/

def list_ord_mat(F,M,B,OMA){

FF=vtol(newvect(F));
BB=vtol(newvect(B));
while(M!=[]){
	M1=car(M);
	M=cdr(M);
	OMA=cons(append(FF,append(M1,BB)),OMA);
}
return OMA;
}

/*--------------------------------------*/

def make_lex(N){

H=[];
for(U=N-1;U>=0;U--){
	B1=[];
	for(J=0;J<=N-1;J++){
		if(U==J){
		B1=cons(1,B1);
		}else{
		B1=cons(0,B1);
		}
	}
	H=cons(B1,H);
}
return H;
}

/*--------------------------------------*/

def make_glex(N){
A1=[];
for(I=0;I<=N-1;I++){
	A1=cons(1,A1);
}
H=[A1];
for(U=N-1;U>=1;U--){
	B1=[0];
	for(J=1;J<=N-1;J++){
		if(U==J){
		B1=cons(1,B1);
		}else{
		B1=cons(0,B1);
		}
	}
	H=cons(B1,H);
}
return H;
}

/*--------------------------------------*/

def select_order(N,K){

if(N==0){
	return make_grlx(K);}
else if(N==1){
	return make_glex(K);}
else if(N==2){
	return make_lex(K);}
else{
    	return "Plese input the correst order.";
}
}




/*---------------------------*/
/*---------------------------*/
/*---------------------------*/
/*---------------------------*/
/*---------------------------*/
/*---------------------------*/
/*---------------------------*/
/*---------------------------*/
/*---------------------------*/
/*---------------------------*/
/*以下empty_checkのプログラム*/
/*---------------------------*/
/*Sup=[[G],[L]]*/
/*G is a GB */

def empty_check(Sup,Para){
LENP=length(Para);
if(Sup[0][0]==1){
	return 0;}

if(Sup[1][0]==1){
	return 1;}
if(Sup[0][0]==0){
	return 1;}

G=Sup[0];
L=Sup[1];

dp_ord(0);
DG=map(dp_ptod,G,Para);
VG=newvect(length(G),DG);
Leg=length(G);
LG=make_indexp(Leg);
I=1;
while(L!=[]){
	L1=car(L);
	L=cdr(L);
N=single_empty_nabe(L1,dp_ptod(L1,Para),VG,DG,G,LG,Para);
	if(N==1){
		return 1;
	}
}
return 0;
}




/*==============================*/
/*------------------------------*/
/*S0=Sup[0], S1=Sup[1],Co,R1=R[1]=[setのset]*/

def set_kuu_check(S0,S1,Co,R1,Para){
dp_ord(0);
DG=map(dp_ptod,S0,Para);
VG=newvect(length(S0),DG);
Leg=length(S0);
LG=make_indexp(Leg);

if(Co!=[]){
U1=unifirst_nabe(S0,S1,Co,DG,VG,Leg,LG,Para);
if(U1==0){
	return 0;}
}else{
	U1=[];}

if(R1!=[]){
UU=uniseco_nabe(S0,R1,DG,VG,Leg,LG,Para);
	if(UU==0){
	return 0;}
}else{
	UU=[];}

Uni=append(U1,UU);
A=set_loop_check(S0,Uni,DG,VG,Leg,LG,Para);
return A;
}

/*------------------------------*/

def unifirst_nabe(S0,S1,Co,DG,VG,Leg,LG,Para){
L=[];
while(S1!=[]){
	K1=car(S1);
	S1=cdr(S1);
	L=cons(Co[0]*K1,L);
}

U=[];
while(L!=[]){
	L1=car(L);
	L=cdr(L);
N=single_empty_nabe(L1,dp_ptod(L1,Para),VG,DG,S0,LG,Para);
	if(N==1){
		U=cons(L1,U);}
}
if(U==[]){return 0;}
}

/*---------------------------*/

def uniseco_nabe(S0,R1,DG,VG,Leg,LG,Para){

W=[];
while(R1!=[]){
	K1=car(R1);
	R1=cdr(R1);
	if(R1!=[]){
		K2=car(R1);
		R1=cdr(R1);
		L=cup_two_set(K1,K2);
		U=[];
		while(L!=[]){
			L1=car(L);
			L=cdr(L);
N=single_empty_nabe(L1,dp_ptod(L1,Para),VG,DG,S0,LG,Para);
	if(N==1){
		U=cons(L1,U);}
		}
		if(U==[]){return 0;}
		W=cons(U,W);
		}else{
		W=cons(K1,W);}
}
return W;
}

/*---------------------*/
def cup_two_set(K,M){
L=[];
while(K!=[]){
	K1=car(K);
	K=cdr(K);
	S=M;
	while(S!=[]){
		S1=car(S);
		S=cdr(S);
		L=cons(S1*K1,L);
	}
}
return L;
}

/*---------------------*/

def set_loop_check(S0,Uni,DG,VG,Leg,LG,Para){
if(length(Uni)==1){
		return set_loop_check2211(S0,Uni,DG,VG,Leg,LG,Para);}

if(length(Uni)==2){
		return set_loop_check22(S0,Uni,DG,VG,Leg,LG,Para);}
W=[];
while(Uni!=[]){
	K1=car(Uni);
	Uni=cdr(Uni);
	if(Uni!=[]){
		K2=car(Uni);
		Uni=cdr(Uni);
		L=cup_two_set(K1,K2);
		U=[];
		while(L!=[]){
			L1=car(L);
			L=cdr(L);
N=single_empty_nabe(L1,dp_ptod(L1,Para),VG,DG,S0,LG,Para);
	if(N==1){
		U=cons(L1,U);}
		}
		if(U==[]){return 0;}
		W=cons(U,W);
		}else{
		W=cons(K1,W);}
}
return set_loop_check(S0,W,DG,VG,Leg,LG,Para);
}

/*----------------*/
def set_loop_check22(S0,Uni,DG,VG,Leg,LG,Para){
L=cup_two_set(Uni[0],Uni[1]);

while(L!=[]){
	L1=car(L);
	L=cdr(L);
N=single_empty_nabe(L1,dp_ptod(L1,Para),VG,DG,S0,LG,Para);
	if(N==1){
		return 1;}
}
return 0;
}
def set_loop_check2211(S0,L,DG,VG,Leg,LG,Para){
L=car(L);
while(L!=[]){
	L1=car(L);
	L=cdr(L);
N=single_empty_nabe(L1,dp_ptod(L1,Para),VG,DG,S0,LG,Para);
	if(N==1){
		return 1;}
}
return 0;
}

/*==============================*/
/*==============================*/




/*---------------------------*/
/*メインの計算*/
/*VG:vec のGB*/
/*DG:dp のGB*/
/*G:pの GB*/
/*0:空、1:空ではない*/

def single_empty_nabe(S,DS,VG,DG,G,Leg,Para){

N1=check_first_nabe(DS,VG,Leg,Para);

/*return N1;*//*これでいいかも*/
	if(N1==0){
		return 0;
	}
if(zero_dim(G,Para,0)==1){
N2=check_second_nabe(DS,VG,DG,Leg,Para);
		return N2;
}else{
N3=check_third_nabe(S,DG,G,Para);
	if(N3==1){
		return 1;}
}
N4=check_fourth_nabe(S,G,Para);
return N4;
}

/*---------------------------*/
/*第一*/
/*0:空で確定, 1:確定しない*/

def check_first_nabe(DS,VG,Leg,Para){
dp_ord(0);
if(dp_nf(Leg,DS,VG,1)!=0){
	return 1;
	}
return 0;
}

/*---------------------------*/
/*第二 zero-dim*/
/*0,1:確定*/

def check_second_nabe(DS,VG,DG,Leg,Para){

MB=dp_mbase(DG);

B=sort_leftl(MB);  /*大きいものから並べる*/
Le=length(B);

MM=make_matrixsd(Le,DS,VG,B,Leg,Para); /*SにMBの要素をかけ行列を作る。*/
CP=det(MM-make_ttt(Le));
De=deg(CP,t);
if(CP!=t^De){
	return 1;}
else{
	return 0;}

}

/*---------------------------*/
/*第三 positive-dim*/
/*1:空でない確定, 0:分からない*/

def check_third_nabe(S,DG,G,Para){

MV=max_indep(DG,Para,0);
for(I=0;I<length(MV);I++){
	G=map(subst,G,MV[I],1);
	S=subst(S,MV[I],1);
}
G=gr(G,Para,0);
LS=setminus(Para,MV);
if(zero_dim(G,LS,0)==1){
DG1=map(dp_ptod,G,LS);
VG=newvect(length(G),DG1);

Leg=make_indexp(length(G));

N3=check_second_nabe(dp_ptod(S,LS),VG,DG1,Leg,LS);
if(N3==1){
return 1;
}}
return 0;
}

/*-----------------------------------------------*/
/*第四 ラヴィノビッチトリック*/
/*1:空でない確定, 0:空確定*/

def check_fourth_nabe(S,G,Para){

T1=strtov("t"+rtostr(1)); 
G=cons(S*T1-1,G);
RG=gr(G,cons(T1,Para),0);
if(RG[0]==1){
	return 1;
}else{
	return 0;
}
}

/*-----------------------------------------------*/

def make_matrixsd(Le,DS,VG,B,Leg,Para){
dp_ord(0);
R=B;

L=[];
while(R!=[]){
	R1=car(R);
	R=cdr(R);
	L1=dp_nf(Leg,R1*DS,VG,1);

	Row=make_row_nabe(L1,B);
	L=cons(Row,L);
}
M=tenchi(Le,L);
return M;
}

/*-----------------------------------------------*/

def make_row_nabe(Po,B){
L=[];
dp_ord(0);
while(B!=[]){
	B1=car(B);
	B=cdr(B);
	if(dp_ht(Po)==B1){
		HC=dp_hc(Po);
		L=cons(HC,L);
		Po=Po-HC*dp_ht(Po);
	}else{
		L=cons(0,L);}
}

return L;
}

/*-----------------------------------------------*/

def tenchi(Le,L){

A=newmat(Le,Le);

for(I=0;I<Le;I++){
	for(J=0;J<Le;J++){
		A[I][J]=L[J][I];
	}
}
return A;
}

/*-----------------------------------------------*/
/*分散表現の項, 左が大*/

def sort_leftl(W){
dp_ord(0);
if(W==[]){ return W;}
L=[];
S=[];
W1=car(W);
W=cdr(W);

while(W!=[]){
	W2=car(W);
	W=cdr(W);
	if(W1<W2){
		L=cons(W2,L);
	}else if(W1>W2){
		S=cons(W2,S);
	}
}
S=sort_leftl(S);
L=sort_leftl(L);

return append(L,cons(W1,S));
}

/*-----------------------------------------------*/

def make_indexp(Le){
L=[];
for(I=0;I<Le;I++){
	L=cons(I,L);
	}
return L;
}

/*-----------------------------------------------*/

def make_ttt(Le){

T=strtov("t");
L=[];
for(I=0;I<Le;I++){
	A=[T];
	for(J=0;J<I;J++){
		A=cons(0,A);
	}
	L=cons(A,L);
}
return newmat(Le,Le,reverse(L));
}











/*-------------------------------------------------------------*/

def max_indep(Gb,V,Do){

HS=head_set11(Gb,V,Do);

S=term2dp_list(HS,V);
M=dim_naibu(S[0],S[1],[],[]);
Ma=max_length11(M);
return erabu_ma(V,reverse(Ma));
}

/*-------------------------------------------------------------*/

def dime_term(T,V){

S=term2num_list(T,V);
M=dim_naibu(S[0],S[1],[],[]);


return max_length(M);
}

/*-------------------------------------------------------------*/

def dim_naibu(S,N,U,M){

for(I=N;I>0;I--){
	K=cons(I,U);
	if(inter_list(K,S)==0){
		M=dim_naibu(S,I-1,K,M);}
	}
if(contain_u(U,M)==0){
	M=cons(U,M);
}
return M;
}

/*-------------------------------------------------------------*/

def head_set11(Gb,V,Do){
dp_ord(Do);

return map(dp_ht,Gb);

}

/*-------------------------------------------------------------*/

def contain_u(U,M){

while(M!=[]){
	M1=car(M);
	M=cdr(M);
	if(U==M1){
		return 1;
	}
return 0;
}
}

/*-------------------------------------------------------------*/

def term2num_list(T,V){

/*単項のリスト*/
/*変数のリスト*/
F=[];
N=length(V);
T=map(dp_ptod,T,V);
V1=map(dp_ptod,reverse(V),V);

while(T!=[]){
	T1=car(T);
	T=cdr(T);
	H=num_oneterm(T1,V1,N);
	F=cons(H,F);
}
return [F,N];
}

/*-------------------------------------------------------------*/

def term2dp_list(T,V){

/*単項のリスト内部表現*/
/*変数のリスト*/
F=[];
K=[];
N=length(V);
V1=map(dp_ptod,reverse(V),V);

while(T!=[]){
	T1=car(T);
	T=cdr(T);
	H=num_oneterm(T1,V1,N);
K=cons(T1,K);
	F=cons(H,F);
}

return [F,N];
}

/*-------------------------------------------------------------*/

def max_length11(L){
K=0;
S=0;
while(L!=[]){
	L1=car(L);
	L=cdr(L);
	B=length(L1);
	if(K<=B){
		K=B;
		S=L1;}
}
return S;
}

/*-------------------------------------------------------------*/

def num_oneterm(T,R,N){
F=[];
for(I=N;I>0;I--){
	R1=car(R);
	R=cdr(R);
	if(dp_redble(T,R1)==1){
		F=cons(I,F);
	}
}
return F;
}

/*-------------------------------------------------------------*/

def inter_list(Mon,S){

while(S!=[]){
	S1=car(S);
	S=cdr(S);
	if(intersec_nabe(Mon,S1)==1){
		return 1;
	}
}
return 0;
}

/*-------------------------------------------------------------*/

def intersec_nabe(Mon,S){
M1=car(Mon);
S1=car(S);
while(S!=[]){
	S1=car(S);
	M1=car(Mon);
	if(M1<S1){
		Mon=cdr(Mon);
		if(Mon==[]){
			return 0;}
	}else if(M1>S1){
		return 0;
	}else{
S=cdr(S);
}
}
return 1;
}

/*-------------------------------------------------------------*/

def max_length(L){
K=0;
while(L!=[]){
	L1=car(L);
	L=cdr(L);
	B=length(L1);
	if(K<=B){
		K=B;}
}
return K;
}

/*-------------------------------------------------------------*/

def erabu_ma(V,Ma){
L=[];
while(Ma!=[]){
	M1=car(Ma);
	Ma=cdr(Ma);
	L=cons(V[M1-1],L);
}
return L;
}

/*---------------------------*/
/*Sup=[[G],[L]]*/
/*G is a GB */

def empty_check77(Sup,Para){
if(Sup[1][0]==1){
	return 1;}
if(Sup[0][0]==0){
	return 1;}

G=Sup[0];
L=Sup[1];
DG=map(dp_ptod,G,Para);
VG=newvect(length(G),DG);
Leg=length(G);
LG=make_indexp(Leg);
L=[];
while(L!=[]){
	L1=car(L);
	L=cdr(L);
N=single_empty_nabe77(L1,dp_ptod(L1,Para),VG,DG,G,LG,Para);
	if(N!=0){
		L=cons(N,L);
	}
}
if(L==[]){
return 0;}
return L;
}
/*---------------------------*/
/*メインの計算*/
/*VG:vec のGB*/
/*DG:dp のGB*/
/*G:pの GB*/
/*0:空、1:空ではない*/

def single_empty_nabe77(S,DS,VG,DG,G,Leg,Para){

N1=check_first_nabe77(DS,VG,Leg,Para);

return N1;
}

/*---------------------------*/
/*第一*/
/*0:空で確定, 1:確定しない*/

def check_first_nabe77(DS,VG,Leg,Para){
dp_ord(0);
K=dp_nf(Leg,DS,VG,1);
if(K==0){
	return 0;
}else{
return dp_dtop(K,Para);
}
}



/*イデアル商の計算*/
/*イデアル商の計算*/
/*イデアル商の計算*/
/*イデアル商の計算*/
/*イデアル商の計算*/

/*I、J:ideal, V:variables*/

def idealq(I,J,V){
B=[1];
while(J!=[]){
	J1=car(J);
	J=cdr(J);
	One=idealone(I,J1,V);
	B=intersection(B,One,V);
}
return B;
}

/*-------------------------------*/
def intersection(B,A,V){
T=strtov("t1");
L=[];
while(B!=[]){
	B1=car(B);
	B=cdr(B);

	L=cons(T*B1,L);}
while(A!=[]){
	A1=car(A);
	A=cdr(A);

	L=cons((1-T)*A1,L);
}
Gro=gr(L,cons(T,V),2);
S=[];
while(Gro!=[]){
	G1=car(Gro);
	Gro=cdr(Gro);

	P=vari_check(G1,T);
	if(P!=0){
		S=cons(P,S);
	}
}
return S;
}

/*-------------------------------*/

def idealone(I,G,V){

T=strtov("t1");
L=[];
while(I!=[]){
	I1=car(I);
	I=cdr(I);
	L=cons(T*I1,L);
}
L=cons((1-T)*G,L);

Gro=gr(L,cons(T,V),2);

S=[];
while(Gro!=[]){
	G1=car(Gro);
	Gro=cdr(Gro);
	P=vari_check(G1,T);
	if(P!=0){
		S=cons(P,S);
	}
}
U=[];
while(S!=[]){
	S1=car(S);
	S=cdr(S);
	U=cons(red(S1/G),U);
}

return U;
}


/*-------------------------------*/

def vari_check(Poly,T){

PV=vars(Poly);
while(PV!=[]){
	P1=car(PV);
	PV=cdr(PV);
	if(P1==T){
		return 0;
	}
}
return Poly;
}