=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2018/builtin/dp.c,v retrieving revision 1.10 retrieving revision 1.25 diff -u -p -r1.10 -r1.25 --- OpenXM_contrib2/asir2018/builtin/dp.c 2019/08/28 23:27:33 1.10 +++ OpenXM_contrib2/asir2018/builtin/dp.c 2020/06/30 01:52:17 1.25 @@ -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.9 2019/08/21 00:37:47 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2018/builtin/dp.c,v 1.24 2020/06/19 10:18:13 noro Exp $ */ #include "ca.h" #include "base.h" @@ -59,7 +59,7 @@ extern struct order_spec *dp_current_spec; extern struct modorder_spec *dp_current_modspec; extern int nd_rref2; -int do_weyl; +extern int do_weyl; void Pdp_monomial_hilbert_poincare(); void Pdp_sort(); @@ -79,6 +79,7 @@ void Pdp_nf_mod(),Pdp_true_nf_mod(); void Pdp_criB(),Pdp_nelim(); void Pdp_minp(),Pdp_sp_mod(); void Pdp_homo(),Pdp_dehomo(); +void Pdpm_homo(),Pdpm_dehomo(); void Pdp_gr_mod_main(),Pdp_gr_f_main(); void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags(); void Pdp_interreduce(); @@ -89,8 +90,12 @@ 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_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_ltod(),Pdpm_dtol(),Pdpm_set_schreyer(),Pdpm_nf(),Pdpm_weyl_nf(),Pdpm_sp(),Pdpm_weyl_sp(),Pdpm_nf_and_quotient(),Pdpm_nf_and_quotient2(); +void Pdpm_schreyer_frame(),Pdpm_set_schreyer_level(); +void Pdpm_list_to_array(),Pdpm_sp_nf(),Pdpm_insert_to_zlist(); +void Pdpm_hm(),Pdpm_ht(),Pdpm_hc(),Pdpm_hp(),Pdpm_rest(),Pdpm_shift(),Pdpm_split(),Pdpm_extract(),Pdpm_sort(),Pdpm_dptodpm(),Pdpm_redble(); +void Pdpm_schreyer_base(),Pdpm_simplify_syz(),Pdpm_td(); +void Pdpm_remove_cont(); void Pdp_weyl_red(); void Pdp_weyl_sp(); @@ -108,6 +113,7 @@ void Pdp_nf_f(),Pdp_weyl_nf_f(); void Pdpm_nf_f(),Pdpm_weyl_nf_f(); void Pdp_lnf_f(); void Pnd_gr(),Pnd_gr_trace(),Pnd_f4(),Pnd_f4_trace(); +void Pnd_sba(),Pnd_sba_f4(); void Pnd_gr_postproc(), Pnd_weyl_gr_postproc(); void Pnd_gr_recompute_trace(), Pnd_btog(); void Pnd_weyl_gr(),Pnd_weyl_gr_trace(); @@ -139,6 +145,7 @@ struct ftab dp_tab[] = { {"dp_prim",Pdp_prim,1}, {"dp_red_coef",Pdp_red_coef,2}, {"dp_cont",Pdp_cont,1}, + {"dpm_remove_cont",Pdpm_remove_cont,1}, /* polynomial ring */ /* special operations */ @@ -158,9 +165,10 @@ struct ftab dp_tab[] = { {"dp_nf_mod",Pdp_nf_mod,5}, {"dp_nf_f",Pdp_nf_f,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_nf_and_quotient2",Pdpm_nf_and_quotient2,-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}, @@ -187,6 +195,8 @@ struct ftab dp_tab[] = { {"dp_gr_checklist",Pdp_gr_checklist,2}, {"nd_f4",Pnd_f4,-4}, {"nd_gr",Pnd_gr,-4}, + {"nd_sba",Pnd_sba,-4}, + {"nd_sba_f4",Pnd_sba_f4,-4}, {"nd_gr_trace",Pnd_gr_trace,-5}, {"nd_f4_trace",Pnd_f4_trace,-5}, {"nd_gr_postproc",Pnd_gr_postproc,5}, @@ -216,7 +226,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}, @@ -254,6 +264,8 @@ struct ftab dp_supp_tab[] = { {"dp_sort",Pdp_sort,1}, {"dp_ord",Pdp_ord,-1}, {"dpm_set_schreyer",Pdpm_set_schreyer,-1}, + {"dpm_set_schreyer_level",Pdpm_set_schreyer_level,1}, + {"dpm_schreyer_frame",Pdpm_schreyer_frame,1}, {"dpv_ord",Pdpv_ord,-2}, {"dp_set_kara",Pdp_set_kara,-1}, {"dp_nelim",Pdp_nelim,-1}, @@ -276,7 +288,9 @@ struct ftab dp_supp_tab[] = { {"dpm_ltod",Pdpm_ltod,2}, {"dpm_dptodpm",Pdpm_dptodpm,2}, - {"dpm_dtol",Pdpm_dtol,3}, + {"dpm_dtol",Pdpm_dtol,2}, + {"dpm_homo",Pdpm_homo,1}, + {"dpm_dehomo",Pdpm_dehomo,1}, /* criteria */ {"dp_cri1",Pdp_cri1,2}, @@ -299,6 +313,7 @@ struct ftab dp_supp_tab[] = { {"dpm_rest",Pdpm_rest,1}, {"dpm_shift",Pdpm_shift,2}, {"dpm_split",Pdpm_split,2}, + {"dpm_extract",Pdpm_extract,2}, {"dpm_sort",Pdpm_sort,1}, {"dp_rest",Pdp_rest,1}, {"dp_initial_term",Pdp_initial_term,1}, @@ -310,6 +325,7 @@ struct ftab dp_supp_tab[] = { {"dp_mag",Pdp_mag,1}, {"dp_sugar",Pdp_sugar,1}, {"dp_set_sugar",Pdp_set_sugar,2}, + {"dpm_td",Pdpm_td,1}, /* misc */ {"dp_mbase",Pdp_mbase,1}, @@ -324,6 +340,11 @@ 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}, + {"dpm_list_to_array",Pdpm_list_to_array,1}, + {"dpm_sp_nf",Pdpm_sp_nf,4}, + {"dpm_insert_to_zlist",Pdpm_insert_to_zlist,3}, + {"dpm_simplify_syz",Pdpm_simplify_syz,2}, {"dp_rref2",Pdp_rref2,2}, {"sumi_updatepairs",Psumi_updatepairs,3}, @@ -806,6 +827,19 @@ void Pdp_cont(NODE arg,Z *rp) dp_cont((DP)ARG0(arg),rp); } +void dpm_ptozp(DPM p,Z *cont,DPM *r); + +void Pdpm_remove_cont(NODE arg,LIST *rp) +{ + NODE nd; + Z cont; + DPM p; + + dpm_ptozp((DPM)ARG0(arg),&cont,&p); + nd = mknode(2,cont,p); + MKLIST(*rp,nd); +} + void Pdp_dtov(NODE arg,VECT *rp) { dp_dtov((DP)ARG0(arg),rp); @@ -926,7 +960,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; + if ( spec->id >= 256 ) dpm_ordtype = spec->module_ordtype; } } @@ -1091,7 +1125,7 @@ void Pdpm_dptodpm(NODE arg,DPM *rp) { DP p; MP mp; - int pos; + int pos,shift; DMM m0,m; p = (DP)ARG0(arg); @@ -1103,7 +1137,15 @@ void Pdpm_dptodpm(NODE arg,DPM *rp) 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; + if ( dp_current_spec->module_top_weight ) { + if ( pos > dp_current_spec->module_rank ) + error("dpm_dptodpm : inconsistent order spec"); + shift = dp_current_spec->module_top_weight[pos-1]; + m->dl->td += shift; + } else + shift = 0; + + MKDPM(p->nv,m0,*rp); (*rp)->sugar = p->sugar+shift; } } @@ -1121,6 +1163,10 @@ void Pdpm_dtol(NODE arg,LIST *rp) Obj s; a = (DPM)ARG0(arg); + if ( !a ) { + MKLIST(*rp,0); + return; + } for ( vl = 0, nd = BDY((LIST)ARG1(arg)), nv = 0; nd; nd = NEXT(nd), nv++ ) { if ( !vl ) { NEWVL(vl); tvl = vl; @@ -1131,7 +1177,8 @@ void Pdpm_dtol(NODE arg,LIST *rp) } if ( vl ) NEXT(tvl) = 0; - n = ZTOS((Q)ARG2(arg)); + for ( t = BDY(a), n = 0; t; t = NEXT(t) ) + if ( t->pos > n ) n = t->pos; w = (MP *)CALLOC(n,sizeof(MP)); for ( t = BDY(a), len = 0; t; t = NEXT(t) ) len++; wa = (DMM *)MALLOC(len*sizeof(DMM)); @@ -1139,8 +1186,8 @@ void Pdpm_dtol(NODE arg,LIST *rp) for ( i = len-1; i >= 0; i-- ) { NEWMP(m); m->dl = wa[i]->dl; C(m) = C(wa[i]); pos = wa[i]->pos; - NEXT(m) = w[pos]; - w[pos] = m; + NEXT(m) = w[pos-1]; + w[pos-1] = m; } nd = 0; for ( i = n-1; i >= 0; i-- ) { @@ -1300,24 +1347,31 @@ 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); +DPM dpm_nf_and_quotient2(NODE b,DPM g,VECT ps,DPM *rp,P *dnp); void Pdpm_nf_and_quotient(NODE arg,LIST *rp) { @@ -1334,11 +1388,11 @@ void Pdpm_nf_and_quotient(NODE arg,LIST *rp) if ( ac < 2 ) error("dpm_nf_and_quotient : invalid arguments"); else if ( ac == 2 ) { - asir_assert(ARG1(arg),O_VECT,"dpm_nf"); + 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"); - asir_assert(ARG2(arg),O_VECT,"dpm_nf"); + 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; @@ -1352,23 +1406,59 @@ void Pdpm_nf_and_quotient(NODE arg,LIST *rp) MKLIST(*rp,n); } +void Pdpm_nf_and_quotient2(NODE arg,LIST *rp) +{ + NODE b; + VECT ps; + DPM g,nm,q; + P dn; + NODE n; + int ac; + + do_weyl = 0; dp_fcoeffs = 0; + ac = argc(arg); + if ( ac < 2 ) + error("dpm_nf_and_quotient2 : invalid arguments"); + else if ( ac == 2 ) { + asir_assert(ARG1(arg),O_VECT,"dpm_nf_and_quotient2"); + b = 0; g = (DPM)ARG0(arg); ps = (VECT)ARG1(arg); + } else if ( ac == 3 ) { + asir_assert(ARG0(arg),O_LIST,"dpm_nf_and_quotient2"); + asir_assert(ARG2(arg),O_VECT,"dpm_nf_and_quotient2"); + b = BDY((LIST)ARG0(arg)); g = (DPM)ARG1(arg); ps = (VECT)ARG2(arg); + } + if ( g ) { + q = dpm_nf_and_quotient2(b,g,ps,&nm,&dn); + } else { + q = 0; nm = 0; dn = (P)ONE; + } + n = mknode(3,nm,dn,q); + 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; } @@ -1419,38 +1509,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; @@ -1843,6 +1946,83 @@ void Pdpm_redble(NODE arg,Z *rp) *rp = 0; } +void dpm_schreyer_base(LIST g,LIST *s); +void dpm_schreyer_base_zlist(LIST g,LIST *s); + +void Pdpm_schreyer_base(NODE arg,LIST *rp) +{ + asir_assert(ARG0(arg),O_LIST,"dpm_schreyer_base"); + dpm_schreyer_base_zlist((LIST)ARG0(arg),rp); +} + +void dpm_list_to_array(LIST g,VECT *psv,VECT *psiv); + +void Pdpm_list_to_array(NODE arg,LIST *rp) +{ + VECT psv,psiv; + NODE nd; + + asir_assert(ARG0(arg),O_LIST,"dpm_list_to_array"); + dpm_list_to_array((LIST)ARG0(arg),&psv,&psiv); + nd = mknode(2,psv,psiv); + MKLIST(*rp,nd); +} + +/* [quo,nf] = dpm_sp_nf(psv,psiv,i,j,top) */ +DPM dpm_sp_nf_zlist(VECT psv,VECT psiv,int i,int j,int top,DPM *nf); + +void Pdpm_sp_nf(NODE arg,LIST *rp) +{ + VECT psv,psiv; + DPM quo,nf; + Obj val; + int i,j,top; + NODE nd; + + asir_assert(ARG0(arg),O_VECT,"dpm_sp_nf"); psv = (VECT)ARG0(arg); + asir_assert(ARG1(arg),O_VECT,"dpm_sp_nf"); psiv = (VECT)ARG1(arg); + asir_assert(ARG2(arg),O_N,"dpm_sp_nf"); i = ZTOS((Q)ARG2(arg)); + asir_assert(ARG3(arg),O_N,"dpm_sp_nf"); j = ZTOS((Q)ARG3(arg)); + if ( get_opt("top",&val) && val ) + top = 1; + else + top = 0; + quo = dpm_sp_nf_zlist(psv,psiv,i,j,top,&nf); + nd = mknode(2,quo,nf); + MKLIST(*rp,nd); +} + +void dpm_insert_to_zlist(VECT psiv,int pos,int i); + +/* insert_to_zlist(indarray,dpm_hp(f),i) */ +void Pdpm_insert_to_zlist(NODE arg,VECT *rp) +{ + VECT psiv; + int i,pos; + + asir_assert(ARG0(arg),O_VECT,"dpm_insert_to_zlist"); psiv = (VECT)ARG0(arg); + asir_assert(ARG1(arg),O_N,"dpm_insert_to_zlist"); pos = ZTOS((Q)ARG1(arg)); + asir_assert(ARG2(arg),O_N,"dpm_insert_to_zlist"); i = ZTOS((Q)ARG2(arg)); + dpm_insert_to_zlist(psiv,pos,i); + *rp = psiv; +} + + +void dpm_simplify_syz(LIST m,LIST s,LIST *m1,LIST *s1,LIST *w1); + +void Pdpm_simplify_syz(NODE arg,LIST *rp) +{ + LIST s1,m1,w1; + NODE t; + + asir_assert(ARG0(arg),O_LIST,"dpm_simplify_syz"); + asir_assert(ARG1(arg),O_LIST,"dpm_simplify_syz"); + dpm_simplify_syz((LIST)ARG0(arg),(LIST)ARG1(arg),&s1,&m1,&w1); + t = mknode(3,s1,m1,w1); + MKLIST(*rp,t); +} + + void Pdp_red_mod(NODE arg,LIST *rp) { DP h,r; @@ -2126,6 +2306,17 @@ void Pdp_td(NODE arg,Z *rp) STOZ(BDY(p)->dl->td,*rp); } +void Pdpm_td(NODE arg,Z *rp) +{ + DPM p; + + p = (DPM)ARG0(arg); asir_assert(p,O_DPM,"dpm_td"); + if ( !p ) + *rp = 0; + else + STOZ(BDY(p)->dl->td,*rp); +} + void Pdp_sugar(NODE arg,Z *rp) { DP p; @@ -2366,6 +2557,22 @@ void Pdp_dehomo(NODE arg,DP *rp) dp_dehomo((DP)ARG0(arg),rp); } +void dpm_homo(DPM a,DPM *b); +void dpm_dehomo(DPM a,DPM *b); + +void Pdpm_homo(NODE arg,DPM *rp) +{ + asir_assert(ARG0(arg),O_DPM,"dpm_homo"); + dpm_homo((DPM)ARG0(arg),rp); +} + +void Pdpm_dehomo(NODE arg,DPM *rp) +{ + asir_assert(ARG0(arg),O_DPM,"dpm_dehomo"); + dpm_dehomo((DPM)ARG0(arg),rp); +} + + void Pdp_gr_flags(NODE arg,LIST *rp) { Obj name,value; @@ -2804,6 +3011,94 @@ void Pnd_gr(NODE arg,LIST *rp) nd_gr(f,v,m,homo,retdp,0,ord,rp); } +void nd_sba(LIST f,LIST v,int m,int homo,int retdp,int f4,struct order_spec *ord,LIST *rp); + +void Pnd_sba(NODE arg,LIST *rp) +{ + LIST f,v; + int m,homo,retdp,ac; + Obj val; + Z mq,z; + Num nhomo; + NODE node; + struct order_spec *ord; + + do_weyl = 0; + retdp = 0; + if ( (ac=argc(arg)) == 4 ) { + asir_assert(ARG0(arg),O_LIST,"nd_sba"); + asir_assert(ARG1(arg),O_LIST,"nd_sba"); + asir_assert(ARG2(arg),O_N,"nd_sba"); + f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); + f = remove_zero_from_list(f); + if ( !BDY(f) ) { + *rp = f; return; + } + mq = (Z)ARG2(arg); + STOZ(0x40000000,z); + if ( cmpz(mq,z) >= 0 ) { + node = mknode(1,mq); + Psetmod_ff(node,&val); + m = -2; + } else + m = ZTOS(mq); + create_order_spec(0,ARG3(arg),&ord); + homo = 0; + if ( get_opt("homo",&val) && val ) homo = 1; + if ( get_opt("dp",&val) && val ) retdp = 1; + } else if ( ac == 1 ) { + f = (LIST)ARG0(arg); + parse_gr_option(f,current_option,&v,&nhomo,&m,&ord); + homo = ZTOS((Q)nhomo); + if ( get_opt("dp",&val) && val ) retdp = 1; + } else + error("nd_gr : invalid argument"); + nd_sba(f,v,m,homo,retdp,0,ord,rp); +} + +void Pnd_sba_f4(NODE arg,LIST *rp) +{ + LIST f,v; + int m,homo,retdp,ac; + Obj val; + Z mq,z; + Num nhomo; + NODE node; + struct order_spec *ord; + + do_weyl = 0; + retdp = 0; + if ( (ac=argc(arg)) == 4 ) { + asir_assert(ARG0(arg),O_LIST,"nd_sba"); + asir_assert(ARG1(arg),O_LIST,"nd_sba"); + asir_assert(ARG2(arg),O_N,"nd_sba"); + f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); + f = remove_zero_from_list(f); + if ( !BDY(f) ) { + *rp = f; return; + } + mq = (Z)ARG2(arg); + STOZ(0x40000000,z); + if ( cmpz(mq,z) >= 0 ) { + node = mknode(1,mq); + Psetmod_ff(node,&val); + m = -2; + } else + m = ZTOS(mq); + create_order_spec(0,ARG3(arg),&ord); + homo = 0; + if ( get_opt("homo",&val) && val ) homo = 1; + if ( get_opt("dp",&val) && val ) retdp = 1; + } else if ( ac == 1 ) { + f = (LIST)ARG0(arg); + parse_gr_option(f,current_option,&v,&nhomo,&m,&ord); + homo = ZTOS((Q)nhomo); + if ( get_opt("dp",&val) && val ) retdp = 1; + } else + error("nd_gr : invalid argument"); + nd_sba(f,v,m,homo,retdp,1,ord,rp); +} + void Pnd_gr_postproc(NODE arg,LIST *rp) { LIST f,v; @@ -3864,20 +4159,88 @@ void Pdpv_ord(NODE arg,Obj *rp) } extern int dpm_ordtype; +extern DMMstack dmm_stack; -void set_schreyer_order(NODE n); +void set_schreyer_order(LIST n); -LIST schreyer_obj; - void Pdpm_set_schreyer(NODE arg,LIST *rp) { if ( argc(arg) ) { - schreyer_obj = (LIST)ARG0(arg); - set_schreyer_order(schreyer_obj?BDY(schreyer_obj):0); + set_schreyer_order(ARG0(arg)?(LIST)ARG0(arg):0); } - *rp = schreyer_obj; + if ( dmm_stack ) + *rp = dmm_stack->obj; + else + *rp = 0; } +DMMstack_array Schreyer_Frame; +DMMstack_array dpm_schreyer_frame(NODE n,int lex); +void set_schreyer_level(DMMstack_array array,int level); + +void Pdpm_set_schreyer_level(NODE arg,Q *rp) +{ + set_schreyer_level(Schreyer_Frame,ZTOS((Q)ARG0(arg))); + *rp = (Q)ARG0(arg); +} + +void Pdpm_schreyer_frame(NODE arg,LIST *rp) +{ + DMMstack_array a; + DMMstack *body; + DMM *in,*sum; + DPM f,s; + NODE b,b1,nd; + LIST l; + VECT v; + Z lev,deg,ind; + int len,i,nv,rank,j,lex; + NODE tt,p; + char *key; + Obj value; + + lex = 0; + 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,"lex") ) + lex = value!=0?1:0; + else { + error("dpm_schreyer_frame: unknown option."); + } + } + } + Schreyer_Frame = a = dpm_schreyer_frame(BDY((LIST)ARG0(arg)),lex); + len = a->len; + body = a->body; + /* XXX */ + nv = ((DPM)BDY(BDY((LIST)body[0]->obj)))->nv; + b = 0; + for ( i = 0; i < len; i++ ) { + rank = body[i]->rank; + in = body[i]->in; + sum = body[i]->sum; + MKVECT(v,rank+1); + STOZ(i+1,lev); + for ( j = 1; j <= rank; j++ ) { + MKDPM(nv,in[j],f); f->sugar = in[j]->dl->td; + MKDPM(nv,sum[j],s);s->sugar = sum[j]->dl->td; + STOZ(s->sugar,deg); + STOZ(j,ind); + nd = mknode(5,f,s,ind,lev,deg); + MKLIST(l,nd); + BDY(v)[j] = (pointer)l; + } + MKNODE(b1,(pointer)v,b); + b = b1; + } + MKLIST(l,b); + *rp = l; +} + + void Pdpm_hm(NODE arg,DPM *rp) { DPM p; @@ -3936,10 +4299,11 @@ void Pdpm_sort(NODE arg,DPM *rp) p = (DPM)ARG0(arg); if ( !p ) *rp = 0; - dpm_sort(p,rp); + else dpm_sort(p,rp); } void dpm_split(DPM p,int s,DPM *up,DPM *lo); +void dpm_extract(DPM p,int s,DP *r); void Pdpm_split(NODE arg,LIST *rp) { @@ -3954,16 +4318,36 @@ void Pdpm_split(NODE arg,LIST *rp) MKLIST(*rp,nd); } +void Pdpm_extract(NODE arg,DP *rp) +{ + DPM p; + int s; -void Pdpm_hc(NODE arg,Obj *rp) + p = (DPM)ARG0(arg); + s = ZTOS((Z)ARG1(arg)); + dpm_extract(p,s,rp); +} + + +void Pdpm_hc(NODE arg,DP *rp) { + DPM p; + DP d; + MP m; + asir_assert(ARG0(arg),O_DPM,"dpm_hc"); if ( !ARG0(arg) ) *rp = 0; - else - *rp = BDY((DPM)ARG0(arg))->c; + else { + p = (DPM)ARG0(arg); + NEWMP(m); + m->dl = BDY(p)->dl; + m->c = BDY(p)->c; + NEXT(m) = 0; + MKDP(NV(p),m,d); d->sugar = p->sugar; + *rp = d; + } } - void Pdpv_ht(NODE arg,LIST *rp) {