=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2018/builtin/dp.c,v retrieving revision 1.2 retrieving revision 1.11 diff -u -p -r1.2 -r1.11 --- OpenXM_contrib2/asir2018/builtin/dp.c 2018/09/28 08:20:27 1.2 +++ OpenXM_contrib2/asir2018/builtin/dp.c 2019/09/04 01:12:02 1.11 @@ -45,7 +45,7 @@ * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE, * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE. * - * $OpenXM: OpenXM_contrib2/asir2018/builtin/dp.c,v 1.1 2018/09/19 05:45:05 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2018/builtin/dp.c,v 1.10 2019/08/28 23:27:33 noro Exp $ */ #include "ca.h" #include "base.h" @@ -61,6 +61,7 @@ extern int nd_rref2; int do_weyl; +void Pdp_monomial_hilbert_poincare(); void Pdp_sort(); void Pdp_mul_trunc(),Pdp_quo(); void Pdp_ord(), Pdp_ptod(), Pdp_dtop(), Phomogenize(); @@ -88,8 +89,9 @@ void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), P void Pdp_cont(); void Pdp_gr_checklist(); void Pdp_ltod(),Pdpv_ord(),Pdpv_ht(),Pdpv_hm(),Pdpv_hc(); -void Pdpm_ltod(),Pdpm_dtol(),Pdpm_ord(),Pdpm_nf(),Pdpm_weyl_nf(),Pdpm_sp(),Pdpm_weyl_sp(); -void Pdpm_hm(),Pdpm_ht(),Pdpm_hc(); +void Pdpm_ltod(),Pdpm_dtol(),Pdpm_set_schreyer(),Pdpm_nf(),Pdpm_weyl_nf(),Pdpm_sp(),Pdpm_weyl_sp(),Pdpm_nf_and_quotient(); +void Pdpm_hm(),Pdpm_ht(),Pdpm_hc(),Pdpm_hp(),Pdpm_rest(),Pdpm_shift(),Pdpm_split(),Pdpm_sort(),Pdpm_dptodpm(),Pdpm_redble(); +void Pdpm_schreyer_base(); void Pdp_weyl_red(); void Pdp_weyl_sp(); @@ -156,9 +158,10 @@ struct ftab dp_tab[] = { {"dp_nf",Pdp_nf,4}, {"dp_nf_mod",Pdp_nf_mod,5}, {"dp_nf_f",Pdp_nf_f,4}, - {"dpm_nf_f",Pdpm_nf_f,4}, - {"dpm_weyl_nf_f",Pdpm_weyl_nf_f,4}, - {"dpm_nf",Pdpm_nf,4}, + {"dpm_nf_and_quotient",Pdpm_nf_and_quotient,-3}, + {"dpm_nf_f",Pdpm_nf_f,-4}, + {"dpm_weyl_nf_f",Pdpm_weyl_nf_f,-4}, + {"dpm_nf",Pdpm_nf,-4}, {"dpm_sp",Pdpm_sp,2}, {"dpm_weyl_sp",Pdpm_weyl_sp,2}, @@ -214,7 +217,7 @@ struct ftab dp_tab[] = { /* normal form */ {"dp_weyl_nf",Pdp_weyl_nf,4}, - {"dpm_weyl_nf",Pdpm_weyl_nf,4}, + {"dpm_weyl_nf",Pdpm_weyl_nf,-4}, {"dp_weyl_nf_mod",Pdp_weyl_nf_mod,5}, {"dp_weyl_nf_f",Pdp_weyl_nf_f,4}, @@ -233,6 +236,9 @@ struct ftab dp_tab[] = { {"dp_weyl_f4_main",Pdp_weyl_f4_main,3}, {"dp_weyl_f4_mod_main",Pdp_weyl_f4_mod_main,4}, + /* Hilbert function */ + {"dp_monomial_hilbert_poincare",Pdp_monomial_hilbert_poincare,2}, + /* misc */ {"dp_inv_or_split",Pdp_inv_or_split,3}, {"dp_set_weight",Pdp_set_weight,-1}, @@ -248,7 +254,7 @@ struct ftab dp_supp_tab[] = { /* setting flags */ {"dp_sort",Pdp_sort,1}, {"dp_ord",Pdp_ord,-1}, - {"dpm_ord",Pdpm_ord,-1}, + {"dpm_set_schreyer",Pdpm_set_schreyer,-1}, {"dpv_ord",Pdpv_ord,-2}, {"dp_set_kara",Pdp_set_kara,-1}, {"dp_nelim",Pdp_nelim,-1}, @@ -270,6 +276,7 @@ struct ftab dp_supp_tab[] = { {"dp_ltod",Pdp_ltod,-2}, {"dpm_ltod",Pdpm_ltod,2}, + {"dpm_dptodpm",Pdpm_dptodpm,2}, {"dpm_dtol",Pdpm_dtol,3}, /* criteria */ @@ -289,6 +296,11 @@ struct ftab dp_supp_tab[] = { {"dpm_hm",Pdpm_hm,1}, {"dpm_ht",Pdpm_ht,1}, {"dpm_hc",Pdpm_hc,1}, + {"dpm_hp",Pdpm_hp,1}, + {"dpm_rest",Pdpm_rest,1}, + {"dpm_shift",Pdpm_shift,2}, + {"dpm_split",Pdpm_split,2}, + {"dpm_sort",Pdpm_sort,1}, {"dp_rest",Pdp_rest,1}, {"dp_initial_term",Pdp_initial_term,1}, {"dp_order",Pdp_order,1}, @@ -303,6 +315,7 @@ struct ftab dp_supp_tab[] = { /* misc */ {"dp_mbase",Pdp_mbase,1}, {"dp_redble",Pdp_redble,2}, + {"dpm_redble",Pdpm_redble,2}, {"dp_sep",Pdp_sep,2}, {"dp_idiv",Pdp_idiv,2}, {"dp_tdiv",Pdp_tdiv,2}, @@ -312,6 +325,7 @@ struct ftab dp_supp_tab[] = { {"dp_compute_essential_df",Pdp_compute_essential_df,2}, {"dp_mono_raddec",Pdp_mono_raddec,2}, {"dp_mono_reduce",Pdp_mono_reduce,2}, + {"dpm_schreyer_base",Pdpm_schreyer_base,1}, {"dp_rref2",Pdp_rref2,2}, {"sumi_updatepairs",Psumi_updatepairs,3}, @@ -323,6 +337,321 @@ struct ftab dp_supp_tab[] = { NODE compute_last_w(NODE g,NODE gh,int n,int **v,int row1,int **m1,int row2,int **m2); Q compute_last_t(NODE g,NODE gh,Q t,VECT w1,VECT w2,NODE *homo,VECT *wp); +int comp_by_tdeg(DP *a,DP *b) +{ + int da,db; + + da = BDY(*a)->dl->td; + db = BDY(*b)->dl->td; + if ( da>db ) return 1; + else if ( dad[i]); + printf(">>\n"); +} + +int simple_check(VECT b,int nv) +{ + int n,i,j; + DL *p; + + n = b->len; p = (DL *)b->body; + for ( i = 0; i < n; i++ ) { + for ( j = 0; j < nv; j++ ) { + if ( p[i]->d[j] ) break; + } + if ( p[i]->d[j] != p[i]->td ) return 0; + } + return 1; +} + +void make_reduced(VECT b,int nv) +{ + int n,i,j; + DL *p; + DL pi; + + n = b->len; + p = (DL *)BDY(b); + for ( i = 0; i < n; i++ ) { + pi = p[i]; + if ( !pi ) continue; + for ( j = 0; j < n; j++ ) + if ( i != j && p[j] && _dl_redble(pi,p[j],nv) ) p[j] = 0; + } + for ( i = j = 0; i < n; i++ ) + if ( p[i] ) p[j++] = p[i]; + b->len = j; +} + +void make_reduced2(VECT b,int k,int nv) +{ + int n,i,j,l; + DL *p; + DL pi; + + n = b->len; + p = (DL *)BDY(b); + for ( i = l = k; i < n; i++ ) { + pi = p[i]; + for ( j = 0; j < k; j++ ) + if ( _dl_redble(p[j],pi,nv) ) break; + if ( j == k ) + p[l++] = pi; + } + b->len = l; +} + +int i_all,i_simple; + +P mhp_simple(VECT b,VECT x,P t) +{ + int n,i,j,nv; + DL *p; + P hp,mt,s,w; + Z z; + + n = b->len; nv = x->len; p = (DL *)BDY(b); + hp = (P)ONE; + for ( i = 0; i < n; i++ ) { + for ( j = 0; j < nv; j++ ) + if ( p[i]->d[j] ) break; + STOZ(p[i]->d[j],z); + chsgnp(t,&mt); mt->dc->d =z; + addp(CO,mt,(P)ONE,&s); mulp(CO,hp,s,&w); hp = w; + } + return hp; +} + +struct oEGT eg_comp; + +void mhp_rec(VECT b,VECT x,P t,P *r) +{ + int n,i,j,k,l,i2,nv,len; + int *d; + Z mone,z; + DCP dc,dc1; + P s; + P *r2; + DL *p,*q; + DL pi,xj,d1; + VECT c; +struct oEGT eg0,eg1; + + i_all++; + n = b->len; nv = x->len; p = (DL *)BDY(b); + if ( !n ) { + r[0] = (P)ONE; + return; + } + if ( n == 1 && p[0]->td == 0 ) + return; + for ( i = 0; i < n; i++ ) + if ( p[i]->td > 1 ) break; + if ( i == n ) { + r[n] = (P)ONE; + return; + } +#if 0 + if ( simple_check(b,nv) ) { + i_simple++; + r[0] = mhp_simple(b,x,t); + return; + } +#endif + for ( j = 0, d = p[i]->d; j < nv; j++ ) + if ( d[j] ) break; + xj = BDY(x)[j]; + MKVECT(c,n); q = (DL *)BDY(c); + for ( i = k = l = 0; i < n; i++ ) + if ( p[i]->d[j] ) { + pi = p[i]; + NEWDL(d1,nv); d1->td =pi->td - 1; + memcpy(d1->d,pi->d,nv*sizeof(int)); + d1->d[j]--; + p[k++] = d1; + } else + q[l++] = p[i]; + for ( i = k, i2 = 0; i2 < l; i++, i2++ ) + p[i] = q[i2]; + /* b=(b[0]/xj,...,b[k-1]/xj,b[k],...b[n-1]) where + b[0],...,b[k-1] are divisible by k */ + make_reduced2(b,k,nv); + mhp_rec(b,x,t,r); + /* c = (b[0],...,b[l-1],xj) */ + q[l] = xj; c->len = l+1; + r2 = (P *)CALLOC(nv+1,sizeof(P)); + mhp_rec(c,x,t,r2); +// get_eg(&eg0); + for ( i = 0; i <= nv; i++ ) { + mulp(CO,r[i],t,&s); addp(CO,s,r2[i],&r[i]); + } +// get_eg(&eg1); add_eg(&eg_comp,&eg0,&eg1); +} + +/* (n+a)Cb as a polynomial of n; return (n+a)*...*(n+a-b+1) */ + +P binpoly(P n,int a,int b) +{ + Z z; + P s,r,t; + int i; + + STOZ(a,z); addp(CO,n,(P)z,&s); r = (P)ONE; + for ( i = 0; i < b; i++ ) { + mulp(CO,r,s,&t); r = t; + subp(CO,s,(P)ONE,&t); s = t; + } + return r; +} + +void ibin(unsigned long int n,unsigned long int k,Z *r); + +void mhp_to_hf(VL vl,P hp,int n,P *plist,VECT *head,P *hf) +{ + P tv,gcd,q,h,hphead,tt,ai,hpoly,nv,bp,w; + Z d,z; + DCP dc,topdc; + VECT hfhead; + int i,s,qd; + + if ( !hp ) { + MKVECT(hfhead,0); *head = hfhead; + *hf = 0; + } else { + makevar("t",&tv); + ezgcdp(CO,hp,plist[n],&gcd); + if ( NUM(gcd) ) { + s = n; + q = hp; + } else { + s = n-ZTOS(DEG(DC(gcd))); + divsp(CO,hp,plist[n-s],&q); + } + if ( NUM(q) ) qd = 0; + else qd = ZTOS(DEG(DC(q))); + if ( s == 0 ) { + MKVECT(hfhead,qd+1); + for ( i = 0; i <= qd; i++ ) { + coefp(q,i,(P *)&BDY(hfhead)[i]); + } + *head = hfhead; + *hf = 0; + } else { + if ( qd ) { + topdc = 0; + for ( i = 0; i < qd; i++ ) { + NEWDC(dc); NEXT(dc) = topdc; + ibin(i+s-1,s-1,(Z *)&COEF(dc)); + STOZ(i,d); DEG(dc) = d; + topdc = dc; + } + MKP(VR(tv),topdc,h); + mulp(CO,h,q,&hphead); + } + MKVECT(hfhead,qd); + for ( i = 0; i < qd; i++ ) + coefp(hphead,i,(P *)&BDY(hfhead)[i]); + *head = hfhead; + hpoly = 0; + makevar("n",&nv); + for ( i = 0; i <= qd; i++ ) { + coefp(q,i,&ai); + bp = binpoly(nv,s-i-1,s-1); + mulp(CO,ai,bp,&tt); + addp(CO,hpoly,tt,&w); + hpoly = w; + } + if ( s > 2 ) { + factorialz(s-1,&z); + divsp(CO,hpoly,(P)z,&tt); hpoly = tt; + } + *hf = hpoly; + for ( i = qd-1; i >= 0; i-- ) { + UTOZ(i,z); + substp(CO,hpoly,VR(nv),(P)z,&tt); + if ( cmpz((Z)tt,(Z)BDY(hfhead)[i]) ) break; + } + hfhead->len = i+1; + } + } +} + +/* create (1,1-t,...,(1-t)^n) */ + +P *mhp_prep(int n,P *tv) { + P *plist; + P mt,t1; + int i; + + plist = (P *)MALLOC((n+1)*sizeof(P)); + /* t1 = 1-t */ + makevar("t",tv); chsgnp(*tv,&mt); addp(CO,mt,(P)ONE,&t1); + for ( plist[0] = (P)ONE, i = 1; i <= n; i++ ) + mulp(CO,plist[i-1],t1,&plist[i]); + return plist; +} + +P mhp_ctop(P *r,P *plist,int n) +{ + int i; + P hp,u,w; + + for ( hp = 0, i = 0; i <= n; i++ ) { + mulp(CO,plist[i],r[i],&u); addp(CO,u,hp,&w); hp = w; + } + return hp; +} + +void Pdp_monomial_hilbert_poincare(NODE arg,LIST *rp) +{ + LIST g,v; + VL vl; + int m,n,i; + VECT b,x,hfhead; + NODE t,nd; + Z z,den; + P hp,tv,mt,t1,u,w,hpoly; + DP a; + DL *p; + P *plist,*r; + Obj val; + + i_simple = i_all = 0; + g = (LIST)ARG0(arg); v = (LIST)ARG1(arg); + pltovl(v,&vl); + m = length(BDY(g)); MKVECT(b,m); p = (DL *)BDY(b); + for ( t = BDY(g), i = 0; t; t = NEXT(t), i++ ) { + if ( !BDY(t) ) + p[i] = 0; + else { + ptod(CO,vl,(P)BDY(t),&a); p[i] = BDY(a)->dl; + } + } + n = length(BDY(v)); MKVECT(x,n); p = (DL *)BDY(x); + for ( t = BDY(v), i = 0; t; t = NEXT(t), i++ ) { + ptod(CO,vl,(P)BDY(t),&a); p[i] = BDY(a)->dl; + } + + r = (P *)CALLOC(n+1,sizeof(P)); + plist = mhp_prep(n,&tv); + make_reduced(b,n); + mhp_rec(b,x,tv,r); + hp = mhp_ctop(r,plist,n); + mhp_to_hf(CO,hp,n,plist,&hfhead,&hpoly); + UTOZ(n,z); + nd = mknode(4,hp,z,hfhead,hpoly); + MKLIST(*rp,nd); +} + void Pdp_compute_last_t(NODE arg,LIST *rp) { NODE g,gh,homo,n; @@ -580,6 +909,8 @@ void Pdp_nf_tab_f(NODE arg,DP *rp) dp_nf_tab_f((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),rp); } +extern int dpm_ordtype; + void Pdp_ord(NODE arg,Obj *rp) { struct order_spec *spec; @@ -597,6 +928,7 @@ void Pdp_ord(NODE arg,Obj *rp) else if ( !create_order_spec(0,(Obj)ARG0(arg),&spec) ) error("dp_ord : invalid order specification"); initd(spec); *rp = spec->obj; + if ( spec->id >= 256 ) dpm_ordtype = spec->ispot; } } @@ -747,7 +1079,7 @@ void Pdpm_ltod(NODE arg,DPM *rp) nd = BDY(f); len = length(nd); - for ( i = 0, t = nd, s = 0; i < len; i++, t = NEXT(t) ) { + for ( i = 1, t = nd, s = 0; i <= len; i++, t = NEXT(t) ) { ptod(CO,vl,(P)BDY(t),&d); dtodpm(d,i,&u); adddpm(CO,s,u,&w); s = w; @@ -755,6 +1087,28 @@ void Pdpm_ltod(NODE arg,DPM *rp) *rp = s; } +// c*[monomial,i]+... -> c*<>+... + +void Pdpm_dptodpm(NODE arg,DPM *rp) +{ + DP p; + MP mp; + int pos; + DMM m0,m; + + p = (DP)ARG0(arg); + pos = ZTOS((Z)ARG1(arg)); + if ( pos <= 0 ) + error("dpm_mtod : position must be positive"); + if ( !p ) *rp = 0; + else { + for ( m0 = 0, mp = BDY(p); mp; mp = NEXT(mp) ) { + NEXTDMM(m0,m); m->dl = mp->dl; m->c = mp->c; m->pos = pos; + } + MKDPM(p->nv,m0,*rp); (*rp)->sugar = p->sugar; + } +} + void Pdpm_dtol(NODE arg,LIST *rp) { DPM a; @@ -948,40 +1302,87 @@ void Pdp_weyl_nf(NODE arg,DP *rp) void Pdpm_nf(NODE arg,DPM *rp) { NODE b; - DPM *ps; + VECT ps; DPM g; - int full; + int ac,full; if ( !(g = (DPM)ARG1(arg)) ) { *rp = 0; return; } do_weyl = 0; dp_fcoeffs = 0; - asir_assert(ARG0(arg),O_LIST,"dpm_nf"); - asir_assert(ARG1(arg),O_DPM,"dpm_nf"); - asir_assert(ARG2(arg),O_VECT,"dpm_nf"); - asir_assert(ARG3(arg),O_N,"dpm_nf"); - b = BDY((LIST)ARG0(arg)); ps = (DPM *)BDY((VECT)ARG2(arg)); - full = (Q)ARG3(arg) ? 1 : 0; + ac = argc(arg); + if ( ac < 3 ) + error("dpm_nf: invalid arguments"); + else if ( ac == 3 ) { + asir_assert(ARG1(arg),O_VECT,"dpm_nf"); + b = 0; g = (DPM)ARG0(arg); ps = (VECT)ARG1(arg); + } else if ( ac == 4 ) { + asir_assert(ARG0(arg),O_LIST,"dpm_nf"); + asir_assert(ARG2(arg),O_VECT,"dpm_nf"); + b = BDY((LIST)ARG0(arg)); g = (DPM)ARG1(arg); ps = (VECT)ARG2(arg); + full = (Q)ARG3(arg) ? 1 : 0; + } dpm_nf_z(b,g,ps,full,DP_Multiple,rp); } +DP *dpm_nf_and_quotient(NODE b,DPM g,VECT ps,DPM *rp,P *dnp); + +void Pdpm_nf_and_quotient(NODE arg,LIST *rp) +{ + NODE b; + VECT ps; + DPM g,nm; + P dn; + VECT quo; + NODE n; + int ac; + + do_weyl = 0; dp_fcoeffs = 0; + ac = argc(arg); + if ( ac < 2 ) + error("dpm_nf_and_quotient : invalid arguments"); + else if ( ac == 2 ) { + asir_assert(ARG1(arg),O_VECT,"dpm_nf_and_quotient"); + b = 0; g = (DPM)ARG0(arg); ps = (VECT)ARG1(arg); + } else if ( ac == 3 ) { + asir_assert(ARG0(arg),O_LIST,"dpm_nf_and_quotient"); + asir_assert(ARG2(arg),O_VECT,"dpm_nf_and_quotient"); + b = BDY((LIST)ARG0(arg)); g = (DPM)ARG1(arg); ps = (VECT)ARG2(arg); + } + NEWVECT(quo); quo->len = ps->len; + if ( g ) { + quo->body = (pointer *)dpm_nf_and_quotient(b,g,ps,&nm,&dn); + } else { + quo->body = (pointer *)MALLOC(quo->len*sizeof(pointer)); + nm = 0; dn = (P)ONE; + } + n = mknode(3,nm,dn,quo); + MKLIST(*rp,n); +} + void Pdpm_weyl_nf(NODE arg,DPM *rp) { NODE b; - DPM *ps; + VECT ps; DPM g; - int full; + int ac,full; if ( !(g = (DPM)ARG1(arg)) ) { *rp = 0; return; } - asir_assert(ARG0(arg),O_LIST,"dpm_weyl_nf"); - asir_assert(ARG1(arg),O_DPM,"dpm_weyl_nf"); - asir_assert(ARG2(arg),O_VECT,"dpm_weyl_nf"); - asir_assert(ARG3(arg),O_N,"dpm_weyl_nf"); - b = BDY((LIST)ARG0(arg)); ps = (DPM *)BDY((VECT)ARG2(arg)); - full = (Q)ARG3(arg) ? 1 : 0; - do_weyl = 1; + do_weyl = 1; dp_fcoeffs = 0; + ac = argc(arg); + if ( ac < 3 ) + error("dpm_weyl_nf: invalid arguments"); + else if ( ac == 3 ) { + asir_assert(ARG1(arg),O_VECT,"dpm_nf"); + b = 0; g = (DPM)ARG0(arg); ps = (VECT)ARG1(arg); + } else if ( ac == 4 ) { + asir_assert(ARG0(arg),O_LIST,"dpm_weyl_nf"); + asir_assert(ARG2(arg),O_VECT,"dpm_weyl_nf"); + b = BDY((LIST)ARG0(arg)); g = (DPM)ARG1(arg); ps = (VECT)ARG2(arg); + full = (Q)ARG3(arg) ? 1 : 0; + } dpm_nf_z(b,g,ps,full,DP_Multiple,rp); do_weyl = 0; } @@ -1032,38 +1433,51 @@ void Pdp_weyl_nf_f(NODE arg,DP *rp) void Pdpm_nf_f(NODE arg,DPM *rp) { NODE b; - DPM *ps; + VECT ps; DPM g; - int full; + int ac,full; if ( !(g = (DPM)ARG1(arg)) ) { *rp = 0; return; } - asir_assert(ARG0(arg),O_LIST,"dpm_nf_f"); - asir_assert(ARG1(arg),O_DPM,"dpm_nf_f"); - asir_assert(ARG2(arg),O_VECT,"dpm_nf_f"); - asir_assert(ARG3(arg),O_N,"dpm_nf_f"); - b = BDY((LIST)ARG0(arg)); ps = (DPM *)BDY((VECT)ARG2(arg)); - full = (Q)ARG3(arg) ? 1 : 0; + ac = argc(arg); + if ( ac < 3 ) + error("dpm_nf_f: invalid arguments"); + else if ( ac == 3 ) { + asir_assert(ARG1(arg),O_VECT,"dpm_nf_f"); + b = 0; g = (DPM)ARG0(arg); ps = (VECT)ARG1(arg); + } else if ( ac == 4 ) { + asir_assert(ARG0(arg),O_LIST,"dpm_nf_f"); + asir_assert(ARG2(arg),O_VECT,"dpm_nf_f"); + b = BDY((LIST)ARG0(arg)); g = (DPM)ARG1(arg); ps = (VECT)ARG2(arg); + full = (Q)ARG3(arg) ? 1 : 0; + } + do_weyl = 0; dpm_nf_f(b,g,ps,full,rp); } void Pdpm_weyl_nf_f(NODE arg,DPM *rp) { NODE b; - DPM *ps; + VECT ps; DPM g; - int full; + int ac,full; if ( !(g = (DPM)ARG1(arg)) ) { *rp = 0; return; } - asir_assert(ARG0(arg),O_LIST,"dpm_weyl_nf_f"); - asir_assert(ARG1(arg),O_DP,"dpm_weyl_nf_f"); - asir_assert(ARG2(arg),O_VECT,"dpm_weyl_nf_f"); - asir_assert(ARG3(arg),O_N,"dpm_weyl_nf_f"); - b = BDY((LIST)ARG0(arg)); ps = (DPM *)BDY((VECT)ARG2(arg)); - full = (Q)ARG3(arg) ? 1 : 0; + ac = argc(arg); + if ( ac < 3 ) + error("dpm_weyl_nf_f: invalid arguments"); + else if ( ac == 3 ) { + asir_assert(ARG1(arg),O_VECT,"dpm_weyl_nf_f"); + b = 0; g = (DPM)ARG0(arg); ps = (VECT)ARG1(arg); + } else if ( ac == 4 ) { + asir_assert(ARG0(arg),O_LIST,"dpm_weyl_nf_f"); + asir_assert(ARG2(arg),O_VECT,"dpm_weyl_nf_f"); + b = BDY((LIST)ARG0(arg)); g = (DPM)ARG1(arg); ps = (VECT)ARG2(arg); + full = (Q)ARG3(arg) ? 1 : 0; + } do_weyl = 1; dpm_nf_f(b,g,ps,full,rp); do_weyl = 0; @@ -1446,6 +1860,24 @@ void Pdp_redble(NODE arg,Z *rp) *rp = 0; } +void Pdpm_redble(NODE arg,Z *rp) +{ + asir_assert(ARG0(arg),O_DPM,"dpm_redble"); + asir_assert(ARG1(arg),O_DPM,"dpm_redble"); + if ( dpm_redble((DPM)ARG0(arg),(DPM)ARG1(arg)) ) + *rp = ONE; + else + *rp = 0; +} + +void dpm_schreyer_base(LIST g,LIST *s); + +void Pdpm_schreyer_base(NODE arg,LIST *rp) +{ + asir_assert(ARG0(arg),O_LIST,"dpm_schreyer_base"); + dpm_schreyer_base((LIST)ARG0(arg),rp); +} + void Pdp_red_mod(NODE arg,LIST *rp) { DP h,r; @@ -1608,25 +2040,47 @@ void Pdp_weyl_sp(NODE arg,DP *rp) do_weyl = 0; } -void Pdpm_sp(NODE arg,DPM *rp) +void Pdpm_sp(NODE arg,Obj *rp) { - DPM p1,p2; + DPM p1,p2,sp; + DP mul1,mul2; + Obj val; + NODE nd; + LIST l; do_weyl = 0; p1 = (DPM)ARG0(arg); p2 = (DPM)ARG1(arg); asir_assert(p1,O_DPM,"dpm_sp"); asir_assert(p2,O_DPM,"dpm_sp"); - dpm_sp(p1,p2,rp); + dpm_sp(p1,p2,&sp,&mul1,&mul2); + if ( get_opt("coef",&val) && val ) { + nd = mknode(3,sp,mul1,mul2); + MKLIST(l,nd); + *rp = (Obj)l; + } else { + *rp = (Obj)sp; + } } -void Pdpm_weyl_sp(NODE arg,DPM *rp) +void Pdpm_weyl_sp(NODE arg,Obj *rp) { - DPM p1,p2; + DPM p1,p2,sp; + DP mul1,mul2; + Obj val; + NODE nd; + LIST l; p1 = (DPM)ARG0(arg); p2 = (DPM)ARG1(arg); asir_assert(p1,O_DPM,"dpm_weyl_sp"); asir_assert(p2,O_DPM,"dpm_weyl_sp"); do_weyl = 1; - dpm_sp(p1,p2,rp); + dpm_sp(p1,p2,&sp,&mul1,&mul2); do_weyl = 0; + if ( get_opt("coef",&val) && val ) { + nd = mknode(3,sp,mul1,mul2); + MKLIST(l,nd); + *rp = (Obj)l; + } else { + *rp = (Obj)sp; + } } void Pdp_sp_mod(NODE arg,DP *rp) @@ -2496,6 +2950,8 @@ void Pnd_gr_trace(NODE arg,LIST *rp) { LIST f,v; int m,homo,ac; + Obj val; + int retdp; Num nhomo; struct order_spec *ord; @@ -2519,13 +2975,17 @@ void Pnd_gr_trace(NODE arg,LIST *rp) homo = ZTOS((Q)nhomo); } else error("nd_gr_trace : invalid argument"); - nd_gr_trace(f,v,m,homo,0,ord,rp); + retdp = 0; + if ( get_opt("dp",&val) && val ) retdp = 1; + nd_gr_trace(f,v,m,homo,retdp,0,ord,rp); } void Pnd_f4_trace(NODE arg,LIST *rp) { LIST f,v; int m,homo,ac; + int retdp; + Obj val; Num nhomo; struct order_spec *ord; @@ -2549,7 +3009,9 @@ void Pnd_f4_trace(NODE arg,LIST *rp) homo = ZTOS((Q)nhomo); } else error("nd_gr_trace : invalid argument"); - nd_gr_trace(f,v,m,homo,1,ord,rp); + retdp = 0; + if ( get_opt("dp",&val) && val ) retdp = 1; + nd_gr_trace(f,v,m,homo,retdp,1,ord,rp); } void Pnd_weyl_gr(NODE arg,LIST *rp) @@ -2590,7 +3052,8 @@ void Pnd_weyl_gr(NODE arg,LIST *rp) void Pnd_weyl_gr_trace(NODE arg,LIST *rp) { LIST f,v; - int m,homo,ac; + int m,homo,ac,retdp; + Obj val; Num nhomo; struct order_spec *ord; @@ -2614,7 +3077,9 @@ void Pnd_weyl_gr_trace(NODE arg,LIST *rp) homo = ZTOS((Q)nhomo); } else error("nd_weyl_gr_trace : invalid argument"); - nd_gr_trace(f,v,m,homo,0,ord,rp); + retdp = 0; + if ( get_opt("dp",&val) && val ) retdp = 1; + nd_gr_trace(f,v,m,homo,retdp,0,ord,rp); do_weyl = 0; } @@ -3433,23 +3898,19 @@ void Pdpv_ord(NODE arg,Obj *rp) *rp = dp_current_modspec->obj; } -extern int dpm_ispot; +extern int dpm_ordtype; -void Pdpm_ord(NODE arg,LIST *rp) +void set_schreyer_order(LIST n); + +LIST schreyer_obj; + +void Pdpm_set_schreyer(NODE arg,LIST *rp) { - Z q; - NODE nd; - struct order_spec *spec; - - if ( arg ) { - nd = BDY((LIST)ARG0(arg)); - if ( !create_order_spec(0,(Obj)ARG1(nd),&spec) ) - error("dpm_ord : invalid order specification"); - initdpm(spec,ZTOS((Q)ARG0(nd))); + if ( argc(arg) ) { + schreyer_obj = (LIST)ARG0(arg); + set_schreyer_order(schreyer_obj); } - STOZ(dpm_ispot,q); - nd = mknode(2,q,dp_current_spec->obj); - MKLIST(*rp,nd); + *rp = schreyer_obj; } void Pdpm_hm(NODE arg,DPM *rp) @@ -3464,10 +3925,71 @@ void Pdpm_ht(NODE arg,DPM *rp) { DPM p; - p = (DPM)ARG0(arg); asir_assert(p,O_DPM,"dp_ht"); + p = (DPM)ARG0(arg); asir_assert(p,O_DPM,"dpm_ht"); dpm_ht(p,rp); } +void dpm_rest(DPM p,DPM *r); + +void Pdpm_rest(NODE arg,DPM *rp) +{ + DPM p; + + p = (DPM)ARG0(arg); asir_assert(p,O_DPM,"dpm_ht"); + dpm_rest(p,rp); +} + + +void Pdpm_hp(NODE arg,Z *rp) +{ + DPM p; + int pos; + + p = (DPM)ARG0(arg); asir_assert(p,O_DPM,"dpm_ht"); + pos = BDY(p)->pos; + STOZ(pos,*rp); +} + +void dpm_shift(DPM p,int s,DPM *rp); + +void Pdpm_shift(NODE arg,DPM *rp) +{ + DPM p; + int s; + + p = (DPM)ARG0(arg); asir_assert(p,O_DPM,"dpm_shift"); + s = ZTOS((Z)ARG1(arg)); + dpm_shift(p,s,rp); +} + +void dpm_sort(DPM p,DPM *rp); + +void Pdpm_sort(NODE arg,DPM *rp) +{ + DPM p; + int s; + + p = (DPM)ARG0(arg); + if ( !p ) *rp = 0; + dpm_sort(p,rp); +} + +void dpm_split(DPM p,int s,DPM *up,DPM *lo); + +void Pdpm_split(NODE arg,LIST *rp) +{ + DPM p,up,lo; + int s; + NODE nd; + + p = (DPM)ARG0(arg); + s = ZTOS((Z)ARG1(arg)); + dpm_split(p,s,&up,&lo); + nd = mknode(2,up,lo); + MKLIST(*rp,nd); +} + + void Pdpm_hc(NODE arg,Obj *rp) { asir_assert(ARG0(arg),O_DPM,"dpm_hc"); @@ -3577,6 +4099,10 @@ int dpv_hp(DPV p) case ORD_LEX: for ( i = 0; i < len; i++ ) if ( e[i] ) return i; + return -1; + break; + default: + error("dpv_hp : unsupported term ordering"); return -1; break; }