===================================================================
RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/dp.c,v
retrieving revision 1.51
retrieving revision 1.62
diff -u -p -r1.51 -r1.62
--- OpenXM_contrib2/asir2000/builtin/dp.c	2004/04/30 08:25:38	1.51
+++ OpenXM_contrib2/asir2000/builtin/dp.c	2006/06/05 08:11:10	1.62
@@ -45,16 +45,18 @@
  * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
  * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
  *
- * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.50 2004/04/15 08:27:42 noro Exp $ 
+ * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.61 2005/11/12 09:43:01 noro Exp $ 
 */
 #include "ca.h"
 #include "base.h"
 #include "parse.h"
 
+extern int dp_fcoeffs;
 extern int dp_nelim;
 extern int dp_order_pair_length;
 extern struct order_pair *dp_order_pair;
 extern struct order_spec *dp_current_spec;
+extern struct modorder_spec *dp_current_modspec;
 
 int do_weyl;
 
@@ -79,6 +81,7 @@ void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_md
 void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
 void Pdp_cont();
 void Pdp_gr_checklist();
+void Pdp_ltod(),Pdpv_ord(),Pdpv_ht(),Pdpv_hm(),Pdpv_hc();
 
 void Pdp_weyl_red();
 void Pdp_weyl_sp();
@@ -90,7 +93,8 @@ void Pdp_weyl_set_weight();
 void Pdp_set_weight();
 void Pdp_nf_f(),Pdp_weyl_nf_f();
 void Pdp_lnf_f();
-void Pnd_gr(),Pnd_gr_trace(),Pnd_f4();
+void Pnd_gr(),Pnd_gr_trace(),Pnd_f4(),Pnd_f4_trace();
+void Pnd_gr_postproc();
 void Pnd_weyl_gr(),Pnd_weyl_gr_trace();
 void Pnd_nf();
 void Pdp_initial_term();
@@ -143,6 +147,8 @@ struct ftab dp_tab[] = {
 	{"nd_f4",Pnd_f4,4},
 	{"nd_gr",Pnd_gr,4},
 	{"nd_gr_trace",Pnd_gr_trace,5},
+	{"nd_f4_trace",Pnd_f4_trace,5},
+	{"nd_gr_postproc",Pnd_gr_postproc,5},
 	{"nd_weyl_gr",Pnd_weyl_gr,4},
 	{"nd_weyl_gr_trace",Pnd_weyl_gr_trace,5},
 	{"nd_nf",Pnd_nf,5},
@@ -186,13 +192,14 @@ struct ftab dp_supp_tab[] = {
 	/* setting flags */
 	{"dp_sort",Pdp_sort,1},
 	{"dp_ord",Pdp_ord,-1},
+	{"dpv_ord",Pdpv_ord,-2},
 	{"dp_set_kara",Pdp_set_kara,-1},
 	{"dp_nelim",Pdp_nelim,-1},
 	{"dp_gr_flags",Pdp_gr_flags,-1},
 	{"dp_gr_print",Pdp_gr_print,-1},
 
 	/* converters */
-	{"dp_ptod",Pdp_ptod,2},
+	{"dp_ptod",Pdp_ptod,-2},
 	{"dp_dtop",Pdp_dtop,2},
 	{"dp_homo",Pdp_homo,1},
 	{"dp_dehomo",Pdp_dehomo,1},
@@ -202,6 +209,7 @@ struct ftab dp_supp_tab[] = {
 	{"dp_mdtod",Pdp_mdtod,1},
 	{"dp_mod",Pdp_mod,3},
 	{"dp_rat",Pdp_rat,1},
+	{"dp_ltod",Pdp_ltod,-2},
 
 	/* criteria */
 	{"dp_cri1",Pdp_cri1,2},
@@ -214,6 +222,9 @@ struct ftab dp_supp_tab[] = {
 	{"dp_hm",Pdp_hm,1},
 	{"dp_ht",Pdp_ht,1},
 	{"dp_hc",Pdp_hc,1},
+	{"dpv_hm",Pdpv_hm,1},
+	{"dpv_ht",Pdpv_ht,1},
+	{"dpv_hc",Pdpv_hc,1},
 	{"dp_rest",Pdp_rest,1},
 	{"dp_initial_term",Pdp_initial_term,1},
 	{"dp_order",Pdp_order,1},
@@ -432,11 +443,11 @@ Obj *rp;
 	int modular;
 	
 	f.id = O_LIST; f.body = 0;
-	if ( !arg )
+	if ( !arg && !current_option )
 		*rp = dp_current_spec->obj;
 	else {
-		if ( ARG0(arg) && OID(ARG0(arg)) == O_OPTLIST )
-			parse_gr_option(&f,BDY((OPTLIST)ARG0(arg)),&v,&homo,&modular,&spec);
+		if ( current_option )
+			parse_gr_option(&f,current_option,&v,&homo,&modular,&spec);
 		else if ( !create_order_spec(0,(Obj)ARG0(arg),&spec) )
 			error("dp_ord : invalid order specification");
 		initd(spec); *rp = spec->obj;
@@ -447,12 +458,31 @@ void Pdp_ptod(arg,rp)
 NODE arg;
 DP *rp;
 {
+	P p;
 	NODE n;
 	VL vl,tvl;
+	struct oLIST f;
+	int ac;
+	LIST v;
+	Num homo;
+	int modular;
+	struct order_spec *ord;
 
 	asir_assert(ARG0(arg),O_P,"dp_ptod");
-	asir_assert(ARG1(arg),O_LIST,"dp_ptod");
-	for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
+	p = (P)ARG0(arg);
+	ac = argc(arg);
+	if ( ac == 1 ) {
+		if ( current_option ) {
+			f.id = O_LIST; f.body = mknode(1,p);
+			parse_gr_option(&f,current_option,&v,&homo,&modular,&ord);
+			initd(ord);
+		} else
+			error("dp_ptod : invalid argument");
+	} else {
+		asir_assert(ARG1(arg),O_LIST,"dp_ptod");
+		v = (LIST)ARG1(arg);
+	}
+	for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
 		if ( !vl ) {
 			NEWVL(vl); tvl = vl;
 		} else {
@@ -462,9 +492,58 @@ DP *rp;
 	}
 	if ( vl )
 		NEXT(tvl) = 0;
-	ptod(CO,vl,(P)ARG0(arg),rp);
+	ptod(CO,vl,p,rp);
 }
 
+void Pdp_ltod(arg,rp)
+NODE arg;
+DPV *rp;
+{
+	NODE n;
+	VL vl,tvl;
+	LIST f,v;
+	int sugar,i,len,ac,modular;
+	Num homo;
+	struct order_spec *ord;
+	DP *e;
+	NODE nd,t;
+
+	ac = argc(arg);
+	asir_assert(ARG0(arg),O_LIST,"dp_ptod");
+	f = (LIST)ARG0(arg);
+	if ( ac == 1 ) {
+		if ( current_option ) {
+			parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
+			initd(ord);
+		} else
+			error("dp_ltod : invalid argument");
+	} else {
+		asir_assert(ARG1(arg),O_LIST,"dp_ptod");
+		v = (LIST)ARG1(arg);
+	}
+	for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
+		if ( !vl ) {
+			NEWVL(vl); tvl = vl;
+		} else {
+			NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
+		}
+		VR(tvl) = VR((P)BDY(n));
+	}
+	if ( vl )
+		NEXT(tvl) = 0;
+
+	nd = BDY(f);
+	len = length(nd);
+	e = (DP *)MALLOC(len*sizeof(DP));
+	sugar = 0;
+	for ( i = 0, t = nd; i < len; i++, t = NEXT(t) ) {
+		ptod(CO,vl,(P)BDY(t),&e[i]);
+		if ( e[i] )
+			sugar = MAX(sugar,e[i]->sugar);
+	}
+	MKDPV(len,e,*rp);
+}
+
 void Pdp_dtop(arg,rp)
 NODE arg;
 P *rp;
@@ -491,10 +570,42 @@ extern LIST Dist;
 
 void Pdp_ptozp(arg,rp)
 NODE arg;
-DP *rp;
+Obj *rp;
 {
+	Q t;
+    NODE tt,p;
+    NODE n,n0;
+    char *key;
+	DP pp;
+	LIST list;
+    int get_factor=0;
+
 	asir_assert(ARG0(arg),O_DP,"dp_ptozp");
-	dp_ptozp((DP)ARG0(arg),rp);
+
+    /* analyze the option */
+    if ( current_option ) {
+      for ( tt = current_option; tt; tt = NEXT(tt) ) {
+        p = BDY((LIST)BDY(tt));
+        key = BDY((STRING)BDY(p));
+        /*  value = (Obj)BDY(NEXT(p)); */
+        if ( !strcmp(key,"factor") )  get_factor=1;
+        else {
+          error("ptozp: unknown option.");
+        }
+      }
+    }
+
+	dp_ptozp3((DP)ARG0(arg),&t,&pp);
+
+    /* printexpr(NULL,t); */
+	/* if the option factor is given, then it returns the answer
+       in the format [zpoly, num] where num*zpoly is equal to the argument.*/
+    if (get_factor) {
+	  n0 = mknode(2,pp,t);
+      MKLIST(list,n0);
+	  *rp = (Obj)list;
+    } else
+      *rp = (Obj)pp;
 }
 	
 void Pdp_ptozp2(arg,rp)
@@ -559,7 +670,7 @@ DP *rp;
 	DP g;
 	int full;
 
-	do_weyl = 0;
+	do_weyl = 0; dp_fcoeffs = 0;
 	asir_assert(ARG0(arg),O_LIST,"dp_nf");
 	asir_assert(ARG1(arg),O_DP,"dp_nf");
 	asir_assert(ARG2(arg),O_VECT,"dp_nf");
@@ -684,7 +795,7 @@ LIST *rp;
 	P dn;
 	int full;
 
-	do_weyl = 0;
+	do_weyl = 0; dp_fcoeffs = 0;
 	asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
 	asir_assert(ARG1(arg),O_DP,"dp_true_nf");
 	asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
@@ -1033,13 +1144,7 @@ DP *rp;
 	MP m,mr;
 
 	p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
-	if ( !p )
-		*rp = 0;
-	else {
-		m = BDY(p);
-		NEWMP(mr); mr->dl = m->dl; mr->c = (P)ONE; NEXT(mr) = 0;
-		MKDP(p->nv,mr,*rp); (*rp)->sugar = mr->dl->td;	/* XXX */
-	}
+	dp_ht(p,rp);
 }
 
 void Pdp_hc(arg,rp)
@@ -1107,9 +1212,10 @@ Obj *rp;
 		n = mknode(1,f); MKLIST(l,n); f = l;
 		is_list = 0;
 	}
-	if ( argc(arg) == 2 && OID(ARG1(arg)) == O_OPTLIST )
-		parse_gr_option(f,BDY((OPTLIST)ARG1(arg)),&v,&homo,&modular,&ord);
-	else
+	if ( current_option ) {
+		parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
+		initd(ord);
+	} else
 		ord = dp_current_spec;
 	initiallist = dp_initial_term(f,ord);		
 	if ( !is_list )
@@ -1135,9 +1241,10 @@ Obj *rp;
 		n = mknode(1,f); MKLIST(l,n); f = l;
 		is_list = 0;
 	}
-	if ( argc(arg) == 2 && OID(ARG1(arg)) == O_OPTLIST )
-		parse_gr_option(f,BDY((OPTLIST)ARG1(arg)),&v,&homo,&modular,&ord);
-	else
+	if ( current_option ) {
+		parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
+		initd(ord);
+	} else
 		ord = dp_current_spec;
 	ordlist = dp_order(f,ord);		
 	if ( !is_list )
@@ -1527,7 +1634,7 @@ LIST *rp;
 	if ( !BDY(f) ) {
 		*rp = f; return;
 	}
-	if ( argc(arg) == 5 ) {
+	if ( (ac = argc(arg)) == 5 ) {
 		asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
 		asir_assert(ARG2(arg),O_N,"dp_gr_main");
 		asir_assert(ARG3(arg),O_N,"dp_gr_main");
@@ -1541,8 +1648,8 @@ LIST *rp;
 		else
 			modular = QTOS(m);
 		create_order_spec(0,ARG4(arg),&ord);
-	} else if ( (ac=argc(arg)) == 2 && OID(ARG1(arg)) == O_OPTLIST )
-		parse_gr_option(f,BDY((OPTLIST)ARG1(arg)),&v,&homo,&modular,&ord);
+	} else if ( current_option )
+		parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
 	else if ( ac == 1 )
 		parse_gr_option(f,0,&v,&homo,&modular,&ord);
 	else
@@ -1727,6 +1834,29 @@ LIST *rp;
 	nd_gr(f,v,m,0,ord,rp);
 }
 
+void Pnd_gr_postproc(arg,rp)
+NODE arg;
+LIST *rp;
+{
+	LIST f,v;
+	int m,do_check;
+	struct order_spec *ord;
+
+	do_weyl = 0;
+	asir_assert(ARG0(arg),O_LIST,"nd_gr");
+	asir_assert(ARG1(arg),O_LIST,"nd_gr");
+	asir_assert(ARG2(arg),O_N,"nd_gr");
+	f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
+	f = remove_zero_from_list(f);
+	if ( !BDY(f) ) {
+		*rp = f; return;
+	}
+	m = QTOS((Q)ARG2(arg));
+	create_order_spec(0,ARG3(arg),&ord);
+	do_check = ARG4(arg) ? 1 : 0;
+	nd_gr_postproc(f,v,m,ord,do_check,rp);
+}
+
 void Pnd_gr_trace(arg,rp)
 NODE arg;
 LIST *rp;
@@ -1748,9 +1878,33 @@ LIST *rp;
 	homo = QTOS((Q)ARG2(arg));
 	m = QTOS((Q)ARG3(arg));
 	create_order_spec(0,ARG4(arg),&ord);
-	nd_gr_trace(f,v,m,homo,ord,rp);
+	nd_gr_trace(f,v,m,homo,0,ord,rp);
 }
 
+void Pnd_f4_trace(arg,rp)
+NODE arg;
+LIST *rp;
+{
+	LIST f,v;
+	int m,homo;
+	struct order_spec *ord;
+
+	do_weyl = 0;
+	asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
+	asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
+	asir_assert(ARG2(arg),O_N,"nd_gr_trace");
+	asir_assert(ARG3(arg),O_N,"nd_gr_trace");
+	f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
+	f = remove_zero_from_list(f);
+	if ( !BDY(f) ) {
+		*rp = f; return;
+	}
+	homo = QTOS((Q)ARG2(arg));
+	m = QTOS((Q)ARG3(arg));
+	create_order_spec(0,ARG4(arg),&ord);
+	nd_gr_trace(f,v,m,homo,1,ord,rp);
+}
+
 void Pnd_weyl_gr(arg,rp)
 NODE arg;
 LIST *rp;
@@ -1839,7 +1993,7 @@ LIST *rp;
 	if ( !BDY(f) ) {
 		*rp = f; return;
 	}
-	if ( argc(arg) == 5 ) {	
+	if ( (ac = argc(arg)) == 5 ) {	
 		asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
 		asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
 		asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
@@ -1853,8 +2007,8 @@ LIST *rp;
 		else
 			modular = QTOS(m);
 		create_order_spec(0,ARG4(arg),&ord);
-	} else if (  (ac=argc(arg)) == 2 && OID(ARG1(arg)) == O_OPTLIST )
-		parse_gr_option(f,BDY((OPTLIST)ARG1(arg)),&v,&homo,&modular,&ord);
+	} else if ( current_option )
+		parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
 	else if ( ac == 1 )
 		parse_gr_option(f,0,&v,&homo,&modular,&ord);
 	else
@@ -1959,7 +2113,7 @@ LIST *rp;
 	do_weyl = 0;
 }
 
-static VECT current_dl_weight_vector_obj;
+VECT current_dl_weight_vector_obj;
 int *current_dl_weight_vector;
 
 void Pdp_set_weight(arg,rp)
@@ -2062,5 +2216,126 @@ int get_field_type(P p)
 				return -1;
 		}
 		return type;
+	}
+}
+
+void Pdpv_ord(NODE arg,Obj *rp)
+{
+	int ac,id;
+	LIST shift;
+
+	ac = argc(arg);
+	if ( ac ) {
+		id = QTOS((Q)ARG0(arg));
+		if ( ac > 1 && ARG1(arg) && OID((Obj)ARG1(arg))==O_LIST )
+			shift = (LIST)ARG1(arg);
+		else
+			shift = 0;
+		create_modorder_spec(id,shift,&dp_current_modspec);
+	}
+	*rp = dp_current_modspec->obj;
+}
+
+void Pdpv_ht(NODE arg,LIST *rp)
+{
+	NODE n;
+	DP ht;
+	int pos;
+	DPV p;
+	Q q;
+
+	asir_assert(ARG0(arg),O_DPV,"dpv_ht");
+	p = (DPV)ARG0(arg);
+	pos = dpv_hp(p);
+	if ( pos < 0 )
+		ht = 0;
+	else
+		dp_ht(BDY(p)[pos],&ht);
+	STOQ(pos,q);
+	n = mknode(2,q,ht);
+	MKLIST(*rp,n);
+}
+
+void Pdpv_hm(NODE arg,LIST *rp)
+{
+	NODE n;
+	DP ht;
+	int pos;
+	DPV p;
+	Q q;
+
+	asir_assert(ARG0(arg),O_DPV,"dpv_hm");
+	p = (DPV)ARG0(arg);
+	pos = dpv_hp(p);
+	if ( pos < 0 )
+		ht = 0;
+	else
+		dp_hm(BDY(p)[pos],&ht);
+	STOQ(pos,q);
+	n = mknode(2,q,ht);
+	MKLIST(*rp,n);
+}
+
+void Pdpv_hc(NODE arg,LIST *rp)
+{
+	NODE n;
+	P hc;
+	int pos;
+	DPV p;
+	Q q;
+
+	asir_assert(ARG0(arg),O_DPV,"dpv_hc");
+	p = (DPV)ARG0(arg);
+	pos = dpv_hp(p);
+	if ( pos < 0 )
+		hc = 0;
+	else
+		hc = BDY(BDY(p)[pos])->c;
+	STOQ(pos,q);
+	n = mknode(2,q,hc);
+	MKLIST(*rp,n);
+}
+
+int dpv_hp(DPV p)
+{
+	int len,i,maxp,maxw,w,slen;
+	int *shift;
+	DP *e;
+
+	len = p->len;
+	e = p->body;
+	slen = dp_current_modspec->len;
+	shift = dp_current_modspec->degree_shift;
+	switch ( dp_current_modspec->id ) {
+		case ORD_REVGRADLEX:
+			for ( maxp = -1, i = 0; i < len; i++ )
+				if ( !e[i] ) continue;
+				else if ( maxp < 0 ) { 
+					maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i; 
+				} else {
+					w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
+					if ( w >= maxw ) {
+						maxw = w; maxp = i;
+					}
+				}
+			return maxp;
+		case ORD_GRADLEX:
+			for ( maxp = -1, i = 0; i < len; i++ )
+				if ( !e[i] ) continue;
+				else if ( maxp < 0 ) { 
+					maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i; 
+				} else {
+					w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
+					if ( w > maxw ) {
+						maxw = w; maxp = i;
+					}
+				}
+			return maxp;
+			break;
+		case ORD_LEX:
+			for ( i = 0; i < len; i++ )
+				if ( e[i] ) return i;
+			return -1;
+			break;
 	}
 }