=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/dp.c,v retrieving revision 1.46 retrieving revision 1.55 diff -u -p -r1.46 -r1.55 --- OpenXM_contrib2/asir2000/builtin/dp.c 2004/02/03 23:31:57 1.46 +++ OpenXM_contrib2/asir2000/builtin/dp.c 2004/12/04 09:39:27 1.55 @@ -45,7 +45,7 @@ * 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.45 2003/12/25 08:46:19 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.54 2004/05/31 00:38:44 noro Exp $ */ #include "ca.h" #include "base.h" @@ -55,6 +55,7 @@ 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 +80,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(); @@ -93,7 +95,15 @@ void Pdp_lnf_f(); void Pnd_gr(),Pnd_gr_trace(),Pnd_f4(); void Pnd_weyl_gr(),Pnd_weyl_gr_trace(); void Pnd_nf(); +void Pdp_initial_term(); +void Pdp_order(); +void Pnd_set_nalg(); +LIST dp_initial_term(); +LIST dp_order(); +void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo, + int *modular,struct order_spec **ord); + LIST remove_zero_from_list(LIST); struct ftab dp_tab[] = { @@ -139,6 +149,7 @@ struct ftab dp_tab[] = { {"nd_weyl_gr",Pnd_weyl_gr,4}, {"nd_weyl_gr_trace",Pnd_weyl_gr_trace,5}, {"nd_nf",Pnd_nf,5}, + {"nd_set_nalg",Pnd_set_nalg,1}, /* F4 algorithm */ {"dp_f4_main",Pdp_f4_main,3}, @@ -161,7 +172,7 @@ struct ftab dp_tab[] = { {"dp_weyl_nf_f",Pdp_weyl_nf_f,4}, /* Buchberger algorithm */ - {"dp_weyl_gr_main",Pdp_weyl_gr_main,5}, + {"dp_weyl_gr_main",Pdp_weyl_gr_main,-5}, {"dp_weyl_gr_mod_main",Pdp_weyl_gr_mod_main,5}, {"dp_weyl_gr_f_main",Pdp_weyl_gr_f_main,4}, @@ -179,13 +190,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}, @@ -195,6 +207,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}, @@ -207,7 +220,12 @@ 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}, /* degree and size */ {"dp_td",Pdp_td,1}, @@ -417,12 +435,19 @@ NODE arg; Obj *rp; { struct order_spec *spec; - + LIST v; + struct oLIST f; + Num homo; + int modular; + + f.id = O_LIST; f.body = 0; if ( !arg ) *rp = dp_current_spec->obj; - else if ( !create_order_spec(0,(Obj)ARG0(arg),&spec) ) - error("dp_ord : invalid order specification"); else { + 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; } } @@ -431,12 +456,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 { @@ -446,9 +490,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; @@ -1017,13 +1110,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) @@ -1074,6 +1161,64 @@ Q *rp; STOQ(p->sugar,*rp); } +void Pdp_initial_term(arg,rp) +NODE arg; +Obj *rp; +{ + struct order_spec *ord; + Num homo; + int modular,is_list; + LIST v,f,l,initiallist; + NODE n; + + f = (LIST)ARG0(arg); + if ( f && OID(f) == O_LIST ) + is_list = 1; + else { + n = mknode(1,f); MKLIST(l,n); f = l; + is_list = 0; + } + 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 ) + *rp = (Obj)BDY(BDY(initiallist)); + else + *rp = (Obj)initiallist; +} + +void Pdp_order(arg,rp) +NODE arg; +Obj *rp; +{ + struct order_spec *ord; + Num homo; + int modular,is_list; + LIST v,f,l,ordlist; + NODE n; + + f = (LIST)ARG0(arg); + if ( f && OID(f) == O_LIST ) + is_list = 1; + else { + n = mknode(1,f); MKLIST(l,n); f = l; + is_list = 0; + } + 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 ) + *rp = (Obj)BDY(BDY(ordlist)); + else + *rp = (Obj)ordlist; +} + void Pdp_set_sugar(arg,rp) NODE arg; Q *rp; @@ -1344,8 +1489,13 @@ void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo int ord_is_set = 0; int modular_is_set = 0; int homo_is_set = 0; - VL vl; + VL vl,vl0; LIST vars; + char xiname[BUFSIZ]; + NODE x0,x; + DP d; + P xi; + int nv,i; /* extract vars */ vars = 0; @@ -1359,10 +1509,35 @@ void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo break; } } - if ( !vars ) { - get_vars((Obj)f,&vl); vltopl(vl,v); - } else { + if ( vars ) { *v = vars; pltovl(vars,&vl); + } else { + for ( t = BDY(f); t; t = NEXT(t) ) + if ( BDY(t) && OID((Obj)BDY(t))==O_DP ) + break; + if ( t ) { + /* f is DP list */ + /* create dummy var list */ + d = (DP)BDY(t); + nv = NV(d); + for ( i = 0, vl0 = 0, x0 = 0; i < nv; i++ ) { + NEXTVL(vl0,vl); + NEXTNODE(x0,x); + sprintf(xiname,"x%d",i); + makevar(xiname,&xi); + x->body = (pointer)xi; + vl->v = VR((P)xi); + } + if ( vl0 ) { + NEXT(vl) = 0; + NEXT(x) = 0; + } + MKLIST(vars,x0); + *v = vars; + vl = vl0; + } else { + get_vars((Obj)f,&vl); vltopl(vl,v); + } } for ( t = opt; t; t = NEXT(t) ) { @@ -1373,16 +1548,19 @@ void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo /* variable list; ignore */ } else if ( !strcmp(key,"order") ) { /* order spec */ + if ( !vl ) + error("parse_gr_option : variables must be specified"); create_order_spec(vl,value,ord); ord_is_set = 1; } else if ( !strcmp(key,"block") ) { create_order_spec(0,value,ord); + ord_is_set = 1; } else if ( !strcmp(key,"matrix") ) { create_order_spec(0,value,ord); + ord_is_set = 1; } else if ( !strcmp(key,"sugarweight") ) { /* weight */ Pdp_set_weight(NEXT(p),&dmy); - ord_is_set = 1; } else if ( !strcmp(key,"homo") ) { *homo = (Num)value; homo_is_set = 1; @@ -1422,11 +1600,11 @@ 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"); - f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); + v = (LIST)ARG1(arg); homo = (Num)ARG2(arg); m = (Q)ARG3(arg); if ( !m ) @@ -1436,8 +1614,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 @@ -1692,6 +1870,12 @@ LIST *rp; nd_gr_trace(f,v,m,homo,ord,rp); } +void Pnd_set_nalg(NODE arg,Q *rp) +{ + nd_set_nalg(QTOS((Q)ARG0(arg))); + *rp = (Q)ARG0(arg); +} + void Pnd_nf(arg,rp) NODE arg; P *rp; @@ -1724,27 +1908,36 @@ LIST *rp; LIST f,v; Num homo; Q m; - int modular; + int modular,ac; struct order_spec *ord; + asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main"); - 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"); - f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); + f = (LIST)ARG0(arg); f = remove_zero_from_list(f); if ( !BDY(f) ) { *rp = f; return; } - homo = (Num)ARG2(arg); - m = (Q)ARG3(arg); - if ( !m ) - modular = 0; - else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) ) - error("dp_gr_main : too large modulus"); + 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"); + v = (LIST)ARG1(arg); + homo = (Num)ARG2(arg); + m = (Q)ARG3(arg); + if ( !m ) + modular = 0; + else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) ) + error("dp_weyl_gr_main : too large modulus"); + else + modular = QTOS(m); + create_order_spec(0,ARG4(arg),&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 - modular = QTOS(m); - create_order_spec(0,ARG4(arg),&ord); + error("dp_weyl_gr_main : invalid argument"); do_weyl = 1; dp_gr_main(f,v,homo,modular,0,ord,rp); do_weyl = 0; @@ -1948,5 +2141,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+(idl->td+(i= 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+(idl->td+(i 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; } }