[BACK]Return to dp.c CVS log [TXT][DIR] Up to [local] / OpenXM_contrib2 / asir2000 / builtin

Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.77

1.5       noro        1: /*
                      2:  * Copyright (c) 1994-2000 FUJITSU LABORATORIES LIMITED
                      3:  * All rights reserved.
                      4:  *
                      5:  * FUJITSU LABORATORIES LIMITED ("FLL") hereby grants you a limited,
                      6:  * non-exclusive and royalty-free license to use, copy, modify and
                      7:  * redistribute, solely for non-commercial and non-profit purposes, the
                      8:  * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and
1.68      noro        9:  * conditions of this Agreement. For the avoidance of doubt, you acquire * only a limited right to use the SOFTWARE hereunder, and FLL or any
1.5       noro       10:  * third party developer retains all rights, including but not limited to
                     11:  * copyrights, in and to the SOFTWARE.
                     12:  *
                     13:  * (1) FLL does not grant you a license in any way for commercial
                     14:  * purposes. You may use the SOFTWARE only for non-commercial and
                     15:  * non-profit purposes only, such as academic, research and internal
                     16:  * business use.
                     17:  * (2) The SOFTWARE is protected by the Copyright Law of Japan and
                     18:  * international copyright treaties. If you make copies of the SOFTWARE,
                     19:  * with or without modification, as permitted hereunder, you shall affix
                     20:  * to all such copies of the SOFTWARE the above copyright notice.
                     21:  * (3) An explicit reference to this SOFTWARE and its copyright owner
                     22:  * shall be made on your publication or presentation in any form of the
                     23:  * results obtained by use of the SOFTWARE.
                     24:  * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.6       noro       25:  * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.5       noro       26:  * for such modification or the source code of the modified part of the
                     27:  * SOFTWARE.
                     28:  *
                     29:  * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
                     30:  * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
                     31:  * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
                     32:  * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
                     33:  * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
                     34:  * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
                     35:  * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
                     36:  * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
                     37:  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
                     38:  * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
                     39:  * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
                     40:  * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
                     41:  * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
                     42:  * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
                     43:  * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
                     44:  * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
                     45:  * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
                     46:  *
1.77    ! noro       47:  * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.76 2009/01/04 05:44:51 noro Exp $
1.5       noro       48: */
1.1       noro       49: #include "ca.h"
                     50: #include "base.h"
                     51: #include "parse.h"
                     52:
1.61      noro       53: extern int dp_fcoeffs;
1.8       noro       54: extern int dp_nelim;
                     55: extern int dp_order_pair_length;
                     56: extern struct order_pair *dp_order_pair;
1.46      noro       57: extern struct order_spec *dp_current_spec;
1.52      noro       58: extern struct modorder_spec *dp_current_modspec;
1.8       noro       59:
1.11      noro       60: int do_weyl;
1.1       noro       61:
1.44      noro       62: void Pdp_sort();
1.32      noro       63: void Pdp_mul_trunc(),Pdp_quo();
1.64      noro       64: void Pdp_ord(), Pdp_ptod(), Pdp_dtop(), Phomogenize();
1.1       noro       65: void Pdp_ptozp(), Pdp_ptozp2(), Pdp_red(), Pdp_red2(), Pdp_lcm(), Pdp_redble();
                     66: void Pdp_sp(), Pdp_hm(), Pdp_ht(), Pdp_hc(), Pdp_rest(), Pdp_td(), Pdp_sugar();
1.30      ohara      67: void Pdp_set_sugar();
1.1       noro       68: void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv();
                     69: void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat();
1.70      noro       70: void Pdp_nf(),Pdp_true_nf(),Pdp_true_nf_marked(),Pdp_true_nf_marked_mod();
1.73      noro       71: void Pdp_true_nf_and_quotient_marked();
1.1       noro       72: void Pdp_nf_mod(),Pdp_true_nf_mod();
                     73: void Pdp_criB(),Pdp_nelim();
1.9       noro       74: void Pdp_minp(),Pdp_sp_mod();
1.1       noro       75: void Pdp_homo(),Pdp_dehomo();
1.16      noro       76: void Pdp_gr_mod_main(),Pdp_gr_f_main();
1.1       noro       77: void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags();
1.63      noro       78: void Pdp_interreduce();
1.16      noro       79: void Pdp_f4_main(),Pdp_f4_mod_main(),Pdp_f4_f_main();
1.1       noro       80: void Pdp_gr_print();
1.28      noro       81: void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_mdtod(), Pdp_nf_tab_f();
1.8       noro       82: void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
                     83: void Pdp_cont();
1.22      noro       84: void Pdp_gr_checklist();
1.52      noro       85: void Pdp_ltod(),Pdpv_ord(),Pdpv_ht(),Pdpv_hm(),Pdpv_hc();
1.1       noro       86:
1.13      noro       87: void Pdp_weyl_red();
                     88: void Pdp_weyl_sp();
                     89: void Pdp_weyl_nf(),Pdp_weyl_nf_mod();
1.16      noro       90: void Pdp_weyl_gr_main(),Pdp_weyl_gr_mod_main(),Pdp_weyl_gr_f_main();
                     91: void Pdp_weyl_f4_main(),Pdp_weyl_f4_mod_main(),Pdp_weyl_f4_f_main();
1.13      noro       92: void Pdp_weyl_mul(),Pdp_weyl_mul_mod();
1.15      noro       93: void Pdp_weyl_set_weight();
1.77    ! noro       94: void Pdp_set_weight(),Pdp_set_top_weight(),Pdp_set_module_weight();
1.16      noro       95: void Pdp_nf_f(),Pdp_weyl_nf_f();
                     96: void Pdp_lnf_f();
1.62      noro       97: void Pnd_gr(),Pnd_gr_trace(),Pnd_f4(),Pnd_f4_trace();
1.75      noro       98: void Pnd_gr_postproc(), Pnd_weyl_gr_postproc();
1.38      noro       99: void Pnd_weyl_gr(),Pnd_weyl_gr_trace();
1.39      noro      100: void Pnd_nf();
1.49      noro      101: void Pdp_initial_term();
                    102: void Pdp_order();
1.66      noro      103: void Pdp_inv_or_split();
1.74      noro      104: void Pdp_compute_last_t();
1.68      noro      105: void Pdp_compute_last_w();
1.70      noro      106: void Pdp_compute_essential_df();
1.72      noro      107: void Pdp_get_denomlist();
1.49      noro      108:
                    109: LIST dp_initial_term();
                    110: LIST dp_order();
                    111: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
                    112:        int *modular,struct order_spec **ord);
1.11      noro      113:
1.25      noro      114: LIST remove_zero_from_list(LIST);
                    115:
1.1       noro      116: struct ftab dp_tab[] = {
1.8       noro      117:        /* content reduction */
1.1       noro      118:        {"dp_ptozp",Pdp_ptozp,1},
                    119:        {"dp_ptozp2",Pdp_ptozp2,2},
                    120:        {"dp_prim",Pdp_prim,1},
1.8       noro      121:        {"dp_red_coef",Pdp_red_coef,2},
                    122:        {"dp_cont",Pdp_cont,1},
                    123:
1.11      noro      124: /* polynomial ring */
1.32      noro      125:        /* special operations */
                    126:        {"dp_mul_trunc",Pdp_mul_trunc,3},
                    127:        {"dp_quo",Pdp_quo,2},
                    128:
1.8       noro      129:        /* s-poly */
                    130:        {"dp_sp",Pdp_sp,2},
                    131:        {"dp_sp_mod",Pdp_sp_mod,3},
                    132:
                    133:        /* m-reduction */
1.1       noro      134:        {"dp_red",Pdp_red,3},
                    135:        {"dp_red_mod",Pdp_red_mod,4},
1.8       noro      136:
                    137:        /* normal form */
1.1       noro      138:        {"dp_nf",Pdp_nf,4},
1.16      noro      139:        {"dp_nf_f",Pdp_nf_f,4},
1.1       noro      140:        {"dp_true_nf",Pdp_true_nf,4},
1.67      noro      141:        {"dp_true_nf_marked",Pdp_true_nf_marked,4},
1.73      noro      142:        {"dp_true_nf_and_quotient_marked",Pdp_true_nf_and_quotient_marked,4},
1.70      noro      143:        {"dp_true_nf_marked_mod",Pdp_true_nf_marked_mod,5},
1.1       noro      144:        {"dp_nf_mod",Pdp_nf_mod,5},
                    145:        {"dp_true_nf_mod",Pdp_true_nf_mod,5},
1.8       noro      146:        {"dp_lnf_mod",Pdp_lnf_mod,3},
1.28      noro      147:        {"dp_nf_tab_f",Pdp_nf_tab_f,2},
1.8       noro      148:        {"dp_nf_tab_mod",Pdp_nf_tab_mod,3},
1.16      noro      149:        {"dp_lnf_f",Pdp_lnf_f,2},
1.8       noro      150:
                    151:        /* Buchberger algorithm */
1.46      noro      152:        {"dp_gr_main",Pdp_gr_main,-5},
1.63      noro      153:        {"dp_interreduce",Pdp_interreduce,3},
1.1       noro      154:        {"dp_gr_mod_main",Pdp_gr_mod_main,5},
1.27      noro      155:        {"dp_gr_f_main",Pdp_gr_f_main,4},
1.23      noro      156:        {"dp_gr_checklist",Pdp_gr_checklist,2},
1.40      noro      157:        {"nd_f4",Pnd_f4,4},
1.33      noro      158:        {"nd_gr",Pnd_gr,4},
1.36      noro      159:        {"nd_gr_trace",Pnd_gr_trace,5},
1.62      noro      160:        {"nd_f4_trace",Pnd_f4_trace,5},
1.58      noro      161:        {"nd_gr_postproc",Pnd_gr_postproc,5},
1.75      noro      162:        {"nd_weyl_gr_postproc",Pnd_weyl_gr_postproc,5},
1.38      noro      163:        {"nd_weyl_gr",Pnd_weyl_gr,4},
                    164:        {"nd_weyl_gr_trace",Pnd_weyl_gr_trace,5},
1.39      noro      165:        {"nd_nf",Pnd_nf,5},
1.8       noro      166:
                    167:        /* F4 algorithm */
1.1       noro      168:        {"dp_f4_main",Pdp_f4_main,3},
                    169:        {"dp_f4_mod_main",Pdp_f4_mod_main,4},
1.8       noro      170:
1.11      noro      171: /* weyl algebra */
1.12      noro      172:        /* multiplication */
                    173:        {"dp_weyl_mul",Pdp_weyl_mul,2},
1.13      noro      174:        {"dp_weyl_mul_mod",Pdp_weyl_mul_mod,3},
1.12      noro      175:
1.11      noro      176:        /* s-poly */
                    177:        {"dp_weyl_sp",Pdp_weyl_sp,2},
                    178:
                    179:        /* m-reduction */
                    180:        {"dp_weyl_red",Pdp_weyl_red,3},
                    181:
                    182:        /* normal form */
                    183:        {"dp_weyl_nf",Pdp_weyl_nf,4},
1.13      noro      184:        {"dp_weyl_nf_mod",Pdp_weyl_nf_mod,5},
1.16      noro      185:        {"dp_weyl_nf_f",Pdp_weyl_nf_f,4},
1.11      noro      186:
                    187:        /* Buchberger algorithm */
1.50      noro      188:        {"dp_weyl_gr_main",Pdp_weyl_gr_main,-5},
1.11      noro      189:        {"dp_weyl_gr_mod_main",Pdp_weyl_gr_mod_main,5},
1.16      noro      190:        {"dp_weyl_gr_f_main",Pdp_weyl_gr_f_main,4},
1.11      noro      191:
                    192:        /* F4 algorithm */
                    193:        {"dp_weyl_f4_main",Pdp_weyl_f4_main,3},
1.19      noro      194:        {"dp_weyl_f4_mod_main",Pdp_weyl_f4_mod_main,4},
1.11      noro      195:
1.15      noro      196:        /* misc */
1.66      noro      197:        {"dp_inv_or_split",Pdp_inv_or_split,3},
1.24      noro      198:        {"dp_set_weight",Pdp_set_weight,-1},
1.77    ! noro      199:        {"dp_set_module_weight",Pdp_set_module_weight,-1},
1.71      noro      200:        {"dp_set_top_weight",Pdp_set_top_weight,-1},
1.15      noro      201:        {"dp_weyl_set_weight",Pdp_weyl_set_weight,-1},
1.72      noro      202:
                    203:        {"dp_get_denomlist",Pdp_get_denomlist,0},
1.8       noro      204:        {0,0,0},
                    205: };
                    206:
                    207: struct ftab dp_supp_tab[] = {
                    208:        /* setting flags */
1.44      noro      209:        {"dp_sort",Pdp_sort,1},
1.8       noro      210:        {"dp_ord",Pdp_ord,-1},
1.52      noro      211:        {"dpv_ord",Pdpv_ord,-2},
1.8       noro      212:        {"dp_set_kara",Pdp_set_kara,-1},
                    213:        {"dp_nelim",Pdp_nelim,-1},
1.1       noro      214:        {"dp_gr_flags",Pdp_gr_flags,-1},
                    215:        {"dp_gr_print",Pdp_gr_print,-1},
1.8       noro      216:
                    217:        /* converters */
1.64      noro      218:        {"homogenize",Phomogenize,3},
1.53      noro      219:        {"dp_ptod",Pdp_ptod,-2},
1.8       noro      220:        {"dp_dtop",Pdp_dtop,2},
                    221:        {"dp_homo",Pdp_homo,1},
                    222:        {"dp_dehomo",Pdp_dehomo,1},
                    223:        {"dp_etov",Pdp_etov,1},
                    224:        {"dp_vtoe",Pdp_vtoe,1},
                    225:        {"dp_dtov",Pdp_dtov,1},
                    226:        {"dp_mdtod",Pdp_mdtod,1},
                    227:        {"dp_mod",Pdp_mod,3},
                    228:        {"dp_rat",Pdp_rat,1},
1.53      noro      229:        {"dp_ltod",Pdp_ltod,-2},
1.8       noro      230:
                    231:        /* criteria */
                    232:        {"dp_cri1",Pdp_cri1,2},
                    233:        {"dp_cri2",Pdp_cri2,2},
                    234:        {"dp_criB",Pdp_criB,3},
                    235:
                    236:        /* simple operation */
                    237:        {"dp_subd",Pdp_subd,2},
                    238:        {"dp_lcm",Pdp_lcm,2},
                    239:        {"dp_hm",Pdp_hm,1},
                    240:        {"dp_ht",Pdp_ht,1},
                    241:        {"dp_hc",Pdp_hc,1},
1.52      noro      242:        {"dpv_hm",Pdpv_hm,1},
                    243:        {"dpv_ht",Pdpv_ht,1},
                    244:        {"dpv_hc",Pdpv_hc,1},
1.8       noro      245:        {"dp_rest",Pdp_rest,1},
1.49      noro      246:        {"dp_initial_term",Pdp_initial_term,1},
                    247:        {"dp_order",Pdp_order,1},
1.8       noro      248:
                    249:        /* degree and size */
                    250:        {"dp_td",Pdp_td,1},
                    251:        {"dp_mag",Pdp_mag,1},
                    252:        {"dp_sugar",Pdp_sugar,1},
1.30      ohara     253:        {"dp_set_sugar",Pdp_set_sugar,2},
1.8       noro      254:
                    255:        /* misc */
                    256:        {"dp_mbase",Pdp_mbase,1},
                    257:        {"dp_redble",Pdp_redble,2},
                    258:        {"dp_sep",Pdp_sep,2},
                    259:        {"dp_idiv",Pdp_idiv,2},
                    260:        {"dp_tdiv",Pdp_tdiv,2},
                    261:        {"dp_minp",Pdp_minp,2},
1.68      noro      262:        {"dp_compute_last_w",Pdp_compute_last_w,5},
1.74      noro      263:        {"dp_compute_last_t",Pdp_compute_last_t,5},
1.70      noro      264:        {"dp_compute_essential_df",Pdp_compute_essential_df,2},
1.8       noro      265:
                    266:        {0,0,0}
1.1       noro      267: };
1.44      noro      268:
1.68      noro      269: NODE compute_last_w(NODE g,NODE gh,int n,int **v,int row1,int **m1,int row2,int **m2);
1.74      noro      270: Q compute_last_t(NODE g,NODE gh,Q t,VECT w1,VECT w2,NODE *homo,VECT *wp);
                    271:
                    272: void Pdp_compute_last_t(NODE arg,LIST *rp)
                    273: {
                    274:        NODE g,gh,homo,n;
                    275:        LIST hlist;
                    276:        VECT v1,v2,w;
                    277:        Q t;
                    278:
                    279:        g = (NODE)BDY((LIST)ARG0(arg));
                    280:        gh = (NODE)BDY((LIST)ARG1(arg));
                    281:        t = (Q)ARG2(arg);
                    282:        v1 = (VECT)ARG3(arg);
                    283:        v2 = (VECT)ARG4(arg);
                    284:        t = compute_last_t(g,gh,t,v1,v2,&homo,&w);
                    285:        MKLIST(hlist,homo);
                    286:        n = mknode(3,t,w,hlist);
                    287:        MKLIST(*rp,n);
                    288: }
1.68      noro      289:
                    290: void Pdp_compute_last_w(NODE arg,LIST *rp)
                    291: {
                    292:        NODE g,gh,r;
                    293:        VECT w,rv;
                    294:        LIST l;
                    295:        MAT w1,w2;
                    296:        int row1,row2,i,j,n;
                    297:        int *v;
                    298:        int **m1,**m2;
                    299:        Q q;
                    300:
                    301:        g = (NODE)BDY((LIST)ARG0(arg));
                    302:        gh = (NODE)BDY((LIST)ARG1(arg));
                    303:        w = (VECT)ARG2(arg);
                    304:        w1 = (MAT)ARG3(arg);
                    305:        w2 = (MAT)ARG4(arg);
                    306:        n = w1->col;
                    307:        row1 = w1->row;
                    308:        row2 = w2->row;
                    309:        if ( w ) {
                    310:                v = W_ALLOC(n);
                    311:                for ( i = 0; i < n; i++ ) v[i] = QTOS((Q)w->body[i]);
                    312:        } else v = 0;
                    313:        m1 = almat(row1,n);
                    314:        for ( i = 0; i < row1; i++ )
                    315:                for ( j = 0; j < n; j++ ) m1[i][j] = QTOS((Q)w1->body[i][j]);
                    316:        m2 = almat(row2,n);
                    317:        for ( i = 0; i < row2; i++ )
                    318:                for ( j = 0; j < n; j++ ) m2[i][j] = QTOS((Q)w2->body[i][j]);
                    319:        r = compute_last_w(g,gh,n,&v,row1,m1,row2,m2);
                    320:        if ( !r ) *rp = 0;
                    321:        else {
                    322:                MKVECT(rv,n);
                    323:                for ( i = 0; i < n; i++ ) {
                    324:                        STOQ(v[i],q); rv->body[i] = (pointer)q;
                    325:                }
                    326:                MKLIST(l,r);
                    327:                r = mknode(2,rv,l);
                    328:                MKLIST(*rp,r);
                    329:        }
                    330: }
                    331:
1.70      noro      332: NODE compute_essential_df(DP *g,DP *gh,int n);
                    333:
                    334: void Pdp_compute_essential_df(NODE arg,LIST *rp)
                    335: {
                    336:        VECT g,gh;
                    337:        NODE r;
                    338:
                    339:        g = (VECT)ARG0(arg);
                    340:        gh = (VECT)ARG1(arg);
                    341:        r = (NODE)compute_essential_df((DP *)BDY(g),(DP *)BDY(gh),g->len);
                    342:        MKLIST(*rp,r);
                    343: }
                    344:
1.66      noro      345: void Pdp_inv_or_split(arg,rp)
                    346: NODE arg;
                    347: Obj *rp;
                    348: {
                    349:        NODE gb,newgb;
                    350:        DP f,inv;
                    351:        struct order_spec *spec;
                    352:        LIST list;
                    353:
                    354:        do_weyl = 0; dp_fcoeffs = 0;
                    355:        asir_assert(ARG0(arg),O_LIST,"dp_inv_or_split");
                    356:        asir_assert(ARG1(arg),O_DP,"dp_inv_or_split");
                    357:        if ( !create_order_spec(0,(Obj)ARG2(arg),&spec) )
                    358:                error("dp_inv_or_split : invalid order specification");
                    359:        gb = BDY((LIST)ARG0(arg));
                    360:        f = (DP)ARG1(arg);
                    361:        newgb = (NODE)dp_inv_or_split(gb,f,spec,&inv);
                    362:        if ( !newgb ) {
                    363:                /* invertible */
                    364:                *rp = (Obj)inv;
                    365:        } else {
                    366:                MKLIST(list,newgb);
                    367:                *rp = (Obj)list;
                    368:        }
                    369: }
                    370:
1.44      noro      371: void Pdp_sort(arg,rp)
                    372: NODE arg;
                    373: DP *rp;
                    374: {
                    375:        dp_sort((DP)ARG0(arg),rp);
                    376: }
1.1       noro      377:
1.8       noro      378: void Pdp_mdtod(arg,rp)
                    379: NODE arg;
                    380: DP *rp;
                    381: {
                    382:        MP m,mr,mr0;
                    383:        DP p;
                    384:        P t;
                    385:
                    386:        p = (DP)ARG0(arg);
                    387:        if ( !p )
                    388:                *rp = 0;
                    389:        else {
                    390:                for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
                    391:                        mptop(m->c,&t); NEXTMP(mr0,mr); mr->c = t; mr->dl = m->dl;
                    392:                }
                    393:                NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
                    394:        }
                    395: }
                    396:
                    397: void Pdp_sep(arg,rp)
                    398: NODE arg;
                    399: VECT *rp;
                    400: {
                    401:        DP p,r;
                    402:        MP m,t;
                    403:        MP *w0,*w;
                    404:        int i,n,d,nv,sugar;
                    405:        VECT v;
                    406:        pointer *pv;
                    407:
                    408:        p = (DP)ARG0(arg); m = BDY(p);
                    409:        d = QTOS((Q)ARG1(arg));
                    410:        for ( t = m, n = 0; t; t = NEXT(t), n++ );
                    411:        if ( d > n )
                    412:                d = n;
                    413:        MKVECT(v,d); *rp = v;
                    414:        pv = BDY(v); nv = p->nv; sugar = p->sugar;
                    415:        w0 = (MP *)MALLOC(d*sizeof(MP)); bzero(w0,d*sizeof(MP));
                    416:        w = (MP *)MALLOC(d*sizeof(MP)); bzero(w,d*sizeof(MP));
                    417:        for ( t = BDY(p), i = 0; t; t = NEXT(t), i++, i %= d  ) {
                    418:                NEXTMP(w0[i],w[i]); w[i]->c = t->c; w[i]->dl = t->dl;
                    419:        }
                    420:        for ( i = 0; i < d; i++ ) {
                    421:                NEXT(w[i]) = 0; MKDP(nv,w0[i],r); r->sugar = sugar;
                    422:                pv[i] = (pointer)r;
                    423:        }
                    424: }
                    425:
                    426: void Pdp_idiv(arg,rp)
                    427: NODE arg;
                    428: DP *rp;
                    429: {
                    430:        dp_idiv((DP)ARG0(arg),(Q)ARG1(arg),rp);
                    431: }
                    432:
                    433: void Pdp_cont(arg,rp)
                    434: NODE arg;
                    435: Q *rp;
                    436: {
                    437:        dp_cont((DP)ARG0(arg),rp);
                    438: }
                    439:
                    440: void Pdp_dtov(arg,rp)
                    441: NODE arg;
                    442: VECT *rp;
                    443: {
                    444:        dp_dtov((DP)ARG0(arg),rp);
                    445: }
                    446:
                    447: void Pdp_mbase(arg,rp)
                    448: NODE arg;
                    449: LIST *rp;
                    450: {
                    451:        NODE mb;
                    452:
                    453:        asir_assert(ARG0(arg),O_LIST,"dp_mbase");
                    454:        dp_mbase(BDY((LIST)ARG0(arg)),&mb);
                    455:        MKLIST(*rp,mb);
                    456: }
                    457:
                    458: void Pdp_etov(arg,rp)
                    459: NODE arg;
                    460: VECT *rp;
                    461: {
                    462:        DP dp;
                    463:        int n,i;
                    464:        int *d;
                    465:        VECT v;
                    466:        Q t;
                    467:
                    468:        dp = (DP)ARG0(arg);
                    469:        asir_assert(dp,O_DP,"dp_etov");
                    470:        n = dp->nv; d = BDY(dp)->dl->d;
                    471:        MKVECT(v,n);
                    472:        for ( i = 0; i < n; i++ ) {
                    473:                STOQ(d[i],t); v->body[i] = (pointer)t;
                    474:        }
                    475:        *rp = v;
                    476: }
                    477:
                    478: void Pdp_vtoe(arg,rp)
                    479: NODE arg;
                    480: DP *rp;
                    481: {
                    482:        DP dp;
                    483:        DL dl;
                    484:        MP m;
                    485:        int n,i,td;
                    486:        int *d;
                    487:        VECT v;
                    488:
                    489:        v = (VECT)ARG0(arg);
                    490:        asir_assert(v,O_VECT,"dp_vtoe");
                    491:        n = v->len;
                    492:        NEWDL(dl,n); d = dl->d;
                    493:        for ( i = 0, td = 0; i < n; i++ ) {
1.24      noro      494:                d[i] = QTOS((Q)(v->body[i])); td += MUL_WEIGHT(d[i],i);
1.8       noro      495:        }
                    496:        dl->td = td;
                    497:        NEWMP(m); m->dl = dl; m->c = (P)ONE; NEXT(m) = 0;
                    498:        MKDP(n,m,dp); dp->sugar = td;
                    499:        *rp = dp;
                    500: }
                    501:
                    502: void Pdp_lnf_mod(arg,rp)
                    503: NODE arg;
                    504: LIST *rp;
                    505: {
                    506:        DP r1,r2;
                    507:        NODE b,g,n;
                    508:        int mod;
                    509:
                    510:        asir_assert(ARG0(arg),O_LIST,"dp_lnf_mod");
                    511:        asir_assert(ARG1(arg),O_LIST,"dp_lnf_mod");
                    512:        asir_assert(ARG2(arg),O_N,"dp_lnf_mod");
                    513:        b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
                    514:        mod = QTOS((Q)ARG2(arg));
                    515:        dp_lnf_mod((DP)BDY(b),(DP)BDY(NEXT(b)),g,mod,&r1,&r2);
                    516:        NEWNODE(n); BDY(n) = (pointer)r1;
                    517:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
                    518:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
                    519: }
                    520:
1.16      noro      521: void Pdp_lnf_f(arg,rp)
                    522: NODE arg;
                    523: LIST *rp;
                    524: {
                    525:        DP r1,r2;
                    526:        NODE b,g,n;
                    527:
                    528:        asir_assert(ARG0(arg),O_LIST,"dp_lnf_f");
                    529:        asir_assert(ARG1(arg),O_LIST,"dp_lnf_f");
                    530:        b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
                    531:        dp_lnf_f((DP)BDY(b),(DP)BDY(NEXT(b)),g,&r1,&r2);
                    532:        NEWNODE(n); BDY(n) = (pointer)r1;
                    533:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
                    534:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
                    535: }
                    536:
1.8       noro      537: void Pdp_nf_tab_mod(arg,rp)
                    538: NODE arg;
                    539: DP *rp;
                    540: {
                    541:        asir_assert(ARG0(arg),O_DP,"dp_nf_tab_mod");
                    542:        asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_mod");
                    543:        asir_assert(ARG2(arg),O_N,"dp_nf_tab_mod");
                    544:        dp_nf_tab_mod((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),
                    545:                QTOS((Q)ARG2(arg)),rp);
1.28      noro      546: }
                    547:
                    548: void Pdp_nf_tab_f(arg,rp)
                    549: NODE arg;
                    550: DP *rp;
                    551: {
                    552:        asir_assert(ARG0(arg),O_DP,"dp_nf_tab_f");
                    553:        asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_f");
                    554:        dp_nf_tab_f((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),rp);
1.8       noro      555: }
1.1       noro      556:
                    557: void Pdp_ord(arg,rp)
                    558: NODE arg;
                    559: Obj *rp;
                    560: {
1.46      noro      561:        struct order_spec *spec;
1.51      noro      562:        LIST v;
                    563:        struct oLIST f;
                    564:        Num homo;
                    565:        int modular;
                    566:
                    567:        f.id = O_LIST; f.body = 0;
1.59      noro      568:        if ( !arg && !current_option )
1.46      noro      569:                *rp = dp_current_spec->obj;
1.1       noro      570:        else {
1.53      noro      571:                if ( current_option )
                    572:                        parse_gr_option(&f,current_option,&v,&homo,&modular,&spec);
1.51      noro      573:                else if ( !create_order_spec(0,(Obj)ARG0(arg),&spec) )
                    574:                        error("dp_ord : invalid order specification");
1.46      noro      575:                initd(spec); *rp = spec->obj;
1.1       noro      576:        }
                    577: }
                    578:
                    579: void Pdp_ptod(arg,rp)
                    580: NODE arg;
                    581: DP *rp;
                    582: {
1.53      noro      583:        P p;
1.1       noro      584:        NODE n;
                    585:        VL vl,tvl;
1.53      noro      586:        struct oLIST f;
                    587:        int ac;
                    588:        LIST v;
                    589:        Num homo;
                    590:        int modular;
                    591:        struct order_spec *ord;
1.1       noro      592:
                    593:        asir_assert(ARG0(arg),O_P,"dp_ptod");
1.53      noro      594:        p = (P)ARG0(arg);
                    595:        ac = argc(arg);
                    596:        if ( ac == 1 ) {
                    597:                if ( current_option ) {
                    598:                        f.id = O_LIST; f.body = mknode(1,p);
                    599:                        parse_gr_option(&f,current_option,&v,&homo,&modular,&ord);
1.54      noro      600:                        initd(ord);
1.53      noro      601:                } else
                    602:                        error("dp_ptod : invalid argument");
                    603:        } else {
                    604:                asir_assert(ARG1(arg),O_LIST,"dp_ptod");
                    605:                v = (LIST)ARG1(arg);
                    606:        }
                    607:        for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
1.1       noro      608:                if ( !vl ) {
                    609:                        NEWVL(vl); tvl = vl;
                    610:                } else {
                    611:                        NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
                    612:                }
                    613:                VR(tvl) = VR((P)BDY(n));
                    614:        }
                    615:        if ( vl )
                    616:                NEXT(tvl) = 0;
1.53      noro      617:        ptod(CO,vl,p,rp);
1.64      noro      618: }
                    619:
                    620: void Phomogenize(arg,rp)
                    621: NODE arg;
                    622: P *rp;
                    623: {
                    624:        P p;
                    625:        DP d,h;
                    626:        NODE n;
                    627:        V hv;
                    628:        VL vl,tvl,last;
                    629:        struct oLIST f;
                    630:        LIST v;
                    631:
                    632:        asir_assert(ARG0(arg),O_P,"homogenize");
                    633:        p = (P)ARG0(arg);
                    634:        asir_assert(ARG1(arg),O_LIST,"homogenize");
                    635:        v = (LIST)ARG1(arg);
                    636:        asir_assert(ARG2(arg),O_P,"homogenize");
                    637:        hv = VR((P)ARG2(arg));
                    638:        for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
                    639:                if ( !vl ) {
                    640:                        NEWVL(vl); tvl = vl;
                    641:                } else {
                    642:                        NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
                    643:                }
                    644:                VR(tvl) = VR((P)BDY(n));
                    645:        }
                    646:        if ( vl ) {
                    647:                last = tvl;
                    648:                NEXT(tvl) = 0;
                    649:        }
                    650:        ptod(CO,vl,p,&d);
                    651:        dp_homo(d,&h);
                    652:        NEWVL(NEXT(last)); last = NEXT(last);
                    653:        VR(last) = hv; NEXT(last) = 0;
                    654:        dtop(CO,vl,h,rp);
1.1       noro      655: }
                    656:
1.52      noro      657: void Pdp_ltod(arg,rp)
                    658: NODE arg;
                    659: DPV *rp;
                    660: {
                    661:        NODE n;
                    662:        VL vl,tvl;
1.53      noro      663:        LIST f,v;
                    664:        int sugar,i,len,ac,modular;
                    665:        Num homo;
                    666:        struct order_spec *ord;
1.52      noro      667:        DP *e;
                    668:        NODE nd,t;
                    669:
1.53      noro      670:        ac = argc(arg);
1.52      noro      671:        asir_assert(ARG0(arg),O_LIST,"dp_ptod");
1.53      noro      672:        f = (LIST)ARG0(arg);
                    673:        if ( ac == 1 ) {
                    674:                if ( current_option ) {
                    675:                        parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.54      noro      676:                        initd(ord);
1.53      noro      677:                } else
                    678:                        error("dp_ltod : invalid argument");
                    679:        } else {
                    680:                asir_assert(ARG1(arg),O_LIST,"dp_ptod");
                    681:                v = (LIST)ARG1(arg);
                    682:        }
                    683:        for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
1.52      noro      684:                if ( !vl ) {
                    685:                        NEWVL(vl); tvl = vl;
                    686:                } else {
                    687:                        NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
                    688:                }
                    689:                VR(tvl) = VR((P)BDY(n));
                    690:        }
                    691:        if ( vl )
                    692:                NEXT(tvl) = 0;
1.53      noro      693:
                    694:        nd = BDY(f);
1.52      noro      695:        len = length(nd);
                    696:        e = (DP *)MALLOC(len*sizeof(DP));
                    697:        sugar = 0;
                    698:        for ( i = 0, t = nd; i < len; i++, t = NEXT(t) ) {
                    699:                ptod(CO,vl,(P)BDY(t),&e[i]);
                    700:                if ( e[i] )
                    701:                        sugar = MAX(sugar,e[i]->sugar);
                    702:        }
                    703:        MKDPV(len,e,*rp);
                    704: }
                    705:
1.1       noro      706: void Pdp_dtop(arg,rp)
                    707: NODE arg;
                    708: P *rp;
                    709: {
                    710:        NODE n;
                    711:        VL vl,tvl;
                    712:
                    713:        asir_assert(ARG0(arg),O_DP,"dp_dtop");
                    714:        asir_assert(ARG1(arg),O_LIST,"dp_dtop");
                    715:        for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
                    716:                if ( !vl ) {
                    717:                        NEWVL(vl); tvl = vl;
                    718:                } else {
                    719:                        NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
                    720:                }
                    721:                VR(tvl) = VR((P)BDY(n));
                    722:        }
                    723:        if ( vl )
                    724:                NEXT(tvl) = 0;
                    725:        dtop(CO,vl,(DP)ARG0(arg),rp);
                    726: }
                    727:
                    728: extern LIST Dist;
                    729:
                    730: void Pdp_ptozp(arg,rp)
                    731: NODE arg;
1.60      ohara     732: Obj *rp;
1.1       noro      733: {
1.60      ohara     734:        Q t;
                    735:     NODE tt,p;
                    736:     NODE n,n0;
                    737:     char *key;
                    738:        DP pp;
                    739:        LIST list;
                    740:     int get_factor=0;
                    741:
1.1       noro      742:        asir_assert(ARG0(arg),O_DP,"dp_ptozp");
1.60      ohara     743:
                    744:     /* analyze the option */
                    745:     if ( current_option ) {
                    746:       for ( tt = current_option; tt; tt = NEXT(tt) ) {
                    747:         p = BDY((LIST)BDY(tt));
                    748:         key = BDY((STRING)BDY(p));
                    749:         /*  value = (Obj)BDY(NEXT(p)); */
                    750:         if ( !strcmp(key,"factor") )  get_factor=1;
                    751:         else {
                    752:           error("ptozp: unknown option.");
                    753:         }
                    754:       }
                    755:     }
                    756:
                    757:        dp_ptozp3((DP)ARG0(arg),&t,&pp);
                    758:
                    759:     /* printexpr(NULL,t); */
                    760:        /* if the option factor is given, then it returns the answer
                    761:        in the format [zpoly, num] where num*zpoly is equal to the argument.*/
                    762:     if (get_factor) {
                    763:          n0 = mknode(2,pp,t);
                    764:       MKLIST(list,n0);
                    765:          *rp = (Obj)list;
                    766:     } else
                    767:       *rp = (Obj)pp;
1.1       noro      768: }
                    769:
                    770: void Pdp_ptozp2(arg,rp)
                    771: NODE arg;
                    772: LIST *rp;
                    773: {
                    774:        DP p0,p1,h,r;
                    775:        NODE n0;
                    776:
                    777:        p0 = (DP)ARG0(arg); p1 = (DP)ARG1(arg);
                    778:        asir_assert(p0,O_DP,"dp_ptozp2");
                    779:        asir_assert(p1,O_DP,"dp_ptozp2");
1.10      noro      780:        dp_ptozp2(p0,p1,&h,&r);
1.1       noro      781:        NEWNODE(n0); BDY(n0) = (pointer)h;
                    782:        NEWNODE(NEXT(n0)); BDY(NEXT(n0)) = (pointer)r;
                    783:        NEXT(NEXT(n0)) = 0;
                    784:        MKLIST(*rp,n0);
                    785: }
                    786:
                    787: void Pdp_prim(arg,rp)
                    788: NODE arg;
                    789: DP *rp;
                    790: {
                    791:        DP t;
                    792:
                    793:        asir_assert(ARG0(arg),O_DP,"dp_prim");
                    794:        dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
                    795: }
                    796:
                    797: void Pdp_mod(arg,rp)
                    798: NODE arg;
                    799: DP *rp;
                    800: {
                    801:        DP p;
                    802:        int mod;
                    803:        NODE subst;
                    804:
                    805:        asir_assert(ARG0(arg),O_DP,"dp_mod");
                    806:        asir_assert(ARG1(arg),O_N,"dp_mod");
                    807:        asir_assert(ARG2(arg),O_LIST,"dp_mod");
                    808:        p = (DP)ARG0(arg); mod = QTOS((Q)ARG1(arg));
                    809:        subst = BDY((LIST)ARG2(arg));
                    810:        dp_mod(p,mod,subst,rp);
                    811: }
                    812:
                    813: void Pdp_rat(arg,rp)
                    814: NODE arg;
                    815: DP *rp;
                    816: {
                    817:        asir_assert(ARG0(arg),O_DP,"dp_rat");
                    818:        dp_rat((DP)ARG0(arg),rp);
                    819: }
                    820:
1.9       noro      821: extern int DP_Multiple;
                    822:
1.1       noro      823: void Pdp_nf(arg,rp)
                    824: NODE arg;
                    825: DP *rp;
                    826: {
                    827:        NODE b;
                    828:        DP *ps;
                    829:        DP g;
                    830:        int full;
                    831:
1.61      noro      832:        do_weyl = 0; dp_fcoeffs = 0;
1.1       noro      833:        asir_assert(ARG0(arg),O_LIST,"dp_nf");
                    834:        asir_assert(ARG1(arg),O_DP,"dp_nf");
                    835:        asir_assert(ARG2(arg),O_VECT,"dp_nf");
                    836:        asir_assert(ARG3(arg),O_N,"dp_nf");
                    837:        if ( !(g = (DP)ARG1(arg)) ) {
                    838:                *rp = 0; return;
                    839:        }
                    840:        b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    841:        full = (Q)ARG3(arg) ? 1 : 0;
1.16      noro      842:        dp_nf_z(b,g,ps,full,DP_Multiple,rp);
1.1       noro      843: }
                    844:
1.11      noro      845: void Pdp_weyl_nf(arg,rp)
                    846: NODE arg;
                    847: DP *rp;
                    848: {
                    849:        NODE b;
                    850:        DP *ps;
                    851:        DP g;
                    852:        int full;
                    853:
                    854:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf");
                    855:        asir_assert(ARG1(arg),O_DP,"dp_weyl_nf");
                    856:        asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf");
                    857:        asir_assert(ARG3(arg),O_N,"dp_weyl_nf");
                    858:        if ( !(g = (DP)ARG1(arg)) ) {
                    859:                *rp = 0; return;
                    860:        }
                    861:        b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    862:        full = (Q)ARG3(arg) ? 1 : 0;
1.12      noro      863:        do_weyl = 1;
1.16      noro      864:        dp_nf_z(b,g,ps,full,DP_Multiple,rp);
                    865:        do_weyl = 0;
                    866: }
                    867:
                    868: /* nf computation using field operations */
                    869:
                    870: void Pdp_nf_f(arg,rp)
                    871: NODE arg;
                    872: DP *rp;
                    873: {
                    874:        NODE b;
                    875:        DP *ps;
                    876:        DP g;
                    877:        int full;
                    878:
                    879:        do_weyl = 0;
                    880:        asir_assert(ARG0(arg),O_LIST,"dp_nf_f");
                    881:        asir_assert(ARG1(arg),O_DP,"dp_nf_f");
                    882:        asir_assert(ARG2(arg),O_VECT,"dp_nf_f");
                    883:        asir_assert(ARG3(arg),O_N,"dp_nf_f");
                    884:        if ( !(g = (DP)ARG1(arg)) ) {
                    885:                *rp = 0; return;
                    886:        }
                    887:        b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    888:        full = (Q)ARG3(arg) ? 1 : 0;
                    889:        dp_nf_f(b,g,ps,full,rp);
                    890: }
                    891:
                    892: void Pdp_weyl_nf_f(arg,rp)
                    893: NODE arg;
                    894: DP *rp;
                    895: {
                    896:        NODE b;
                    897:        DP *ps;
                    898:        DP g;
                    899:        int full;
                    900:
                    901:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_f");
                    902:        asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_f");
                    903:        asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_f");
                    904:        asir_assert(ARG3(arg),O_N,"dp_weyl_nf_f");
                    905:        if ( !(g = (DP)ARG1(arg)) ) {
                    906:                *rp = 0; return;
                    907:        }
                    908:        b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    909:        full = (Q)ARG3(arg) ? 1 : 0;
                    910:        do_weyl = 1;
                    911:        dp_nf_f(b,g,ps,full,rp);
1.12      noro      912:        do_weyl = 0;
1.11      noro      913: }
                    914:
1.13      noro      915: void Pdp_nf_mod(arg,rp)
                    916: NODE arg;
                    917: DP *rp;
                    918: {
                    919:        NODE b;
                    920:        DP g;
                    921:        DP *ps;
                    922:        int mod,full,ac;
                    923:        NODE n,n0;
                    924:
1.14      noro      925:        do_weyl = 0;
1.13      noro      926:        ac = argc(arg);
1.14      noro      927:        asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
                    928:        asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
                    929:        asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
                    930:        asir_assert(ARG3(arg),O_N,"dp_nf_mod");
                    931:        asir_assert(ARG4(arg),O_N,"dp_nf_mod");
1.13      noro      932:        if ( !(g = (DP)ARG1(arg)) ) {
                    933:                *rp = 0; return;
                    934:        }
                    935:        b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    936:        full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
                    937:        for ( n0 = n = 0; b; b = NEXT(b) ) {
                    938:                NEXTNODE(n0,n);
                    939:                BDY(n) = (pointer)QTOS((Q)BDY(b));
                    940:        }
                    941:        if ( n0 )
                    942:                NEXT(n) = 0;
                    943:        dp_nf_mod(n0,g,ps,mod,full,rp);
                    944: }
                    945:
1.1       noro      946: void Pdp_true_nf(arg,rp)
                    947: NODE arg;
                    948: LIST *rp;
                    949: {
                    950:        NODE b,n;
                    951:        DP *ps;
                    952:        DP g;
                    953:        DP nm;
                    954:        P dn;
                    955:        int full;
                    956:
1.61      noro      957:        do_weyl = 0; dp_fcoeffs = 0;
1.1       noro      958:        asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
                    959:        asir_assert(ARG1(arg),O_DP,"dp_true_nf");
                    960:        asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
                    961:        asir_assert(ARG3(arg),O_N,"dp_nf");
                    962:        if ( !(g = (DP)ARG1(arg)) ) {
                    963:                nm = 0; dn = (P)ONE;
                    964:        } else {
                    965:                b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    966:                full = (Q)ARG3(arg) ? 1 : 0;
                    967:                dp_true_nf(b,g,ps,full,&nm,&dn);
                    968:        }
                    969:        NEWNODE(n); BDY(n) = (pointer)nm;
                    970:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
                    971:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
                    972: }
                    973:
1.67      noro      974: void Pdp_true_nf_marked(arg,rp)
                    975: NODE arg;
                    976: LIST *rp;
                    977: {
                    978:        NODE b,n;
                    979:        DP *ps,*hps;
                    980:        DP g;
                    981:        DP nm;
1.69      noro      982:        Q cont;
1.67      noro      983:        P dn;
                    984:        int full;
                    985:
                    986:        do_weyl = 0; dp_fcoeffs = 0;
                    987:        asir_assert(ARG0(arg),O_LIST,"dp_true_nf_marked");
                    988:        asir_assert(ARG1(arg),O_DP,"dp_true_nf_marked");
                    989:        asir_assert(ARG2(arg),O_VECT,"dp_true_nf_marked");
                    990:        asir_assert(ARG3(arg),O_VECT,"dp_true_nf_marked");
                    991:        if ( !(g = (DP)ARG1(arg)) ) {
                    992:                nm = 0; dn = (P)ONE;
                    993:        } else {
                    994:                b = BDY((LIST)ARG0(arg));
                    995:                ps = (DP *)BDY((VECT)ARG2(arg));
                    996:                hps = (DP *)BDY((VECT)ARG3(arg));
1.69      noro      997:                dp_true_nf_marked(b,g,ps,hps,&nm,&cont,&dn);
1.67      noro      998:        }
1.69      noro      999:        n = mknode(3,nm,cont,dn);
                   1000:        MKLIST(*rp,n);
1.67      noro     1001: }
                   1002:
1.73      noro     1003: DP *dp_true_nf_and_quotient_marked (NODE b,DP g,DP *ps,DP *hps,DP *rp,P *dnp);
                   1004:
                   1005: void Pdp_true_nf_and_quotient_marked(arg,rp)
                   1006: NODE arg;
                   1007: LIST *rp;
                   1008: {
                   1009:        NODE b,n;
                   1010:        DP *ps,*hps;
                   1011:        DP g;
                   1012:        DP nm;
                   1013:        VECT quo;
                   1014:        P dn;
                   1015:        int full;
                   1016:
                   1017:        do_weyl = 0; dp_fcoeffs = 0;
                   1018:        asir_assert(ARG0(arg),O_LIST,"dp_true_nf_and_quotient_marked");
                   1019:        asir_assert(ARG1(arg),O_DP,"dp_true_nf_and_quotient_marked");
                   1020:        asir_assert(ARG2(arg),O_VECT,"dp_true_nf_and_quotient_marked");
                   1021:        asir_assert(ARG3(arg),O_VECT,"dp_true_nf_and_quotient_marked");
                   1022:        if ( !(g = (DP)ARG1(arg)) ) {
                   1023:                nm = 0; dn = (P)ONE;
                   1024:        } else {
                   1025:                b = BDY((LIST)ARG0(arg));
                   1026:                ps = (DP *)BDY((VECT)ARG2(arg));
                   1027:                hps = (DP *)BDY((VECT)ARG3(arg));
                   1028:                NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
                   1029:                quo->body = (pointer *)dp_true_nf_and_quotient_marked(b,g,ps,hps,&nm,&dn);
                   1030:        }
                   1031:        n = mknode(3,nm,dn,quo);
                   1032:        MKLIST(*rp,n);
                   1033: }
                   1034:
1.70      noro     1035: void Pdp_true_nf_marked_mod(arg,rp)
                   1036: NODE arg;
                   1037: LIST *rp;
                   1038: {
                   1039:        NODE b,n;
                   1040:        DP *ps,*hps;
                   1041:        DP g;
                   1042:        DP nm;
                   1043:        P dn;
                   1044:        int mod;
                   1045:
                   1046:        do_weyl = 0; dp_fcoeffs = 0;
                   1047:        asir_assert(ARG0(arg),O_LIST,"dp_true_nf_marked_mod");
                   1048:        asir_assert(ARG1(arg),O_DP,"dp_true_nf_marked_mod");
                   1049:        asir_assert(ARG2(arg),O_VECT,"dp_true_nf_marked_mod");
                   1050:        asir_assert(ARG3(arg),O_VECT,"dp_true_nf_marked_mod");
                   1051:        asir_assert(ARG4(arg),O_N,"dp_true_nf_marked_mod");
                   1052:        if ( !(g = (DP)ARG1(arg)) ) {
                   1053:                nm = 0; dn = (P)ONE;
                   1054:        } else {
                   1055:                b = BDY((LIST)ARG0(arg));
                   1056:                ps = (DP *)BDY((VECT)ARG2(arg));
                   1057:                hps = (DP *)BDY((VECT)ARG3(arg));
                   1058:                mod = QTOS((Q)ARG4(arg));
                   1059:                dp_true_nf_marked_mod(b,g,ps,hps,mod,&nm,&dn);
                   1060:        }
                   1061:        n = mknode(2,nm,dn);
                   1062:        MKLIST(*rp,n);
                   1063: }
                   1064:
1.13      noro     1065: void Pdp_weyl_nf_mod(arg,rp)
1.8       noro     1066: NODE arg;
                   1067: DP *rp;
                   1068: {
                   1069:        NODE b;
                   1070:        DP g;
                   1071:        DP *ps;
                   1072:        int mod,full,ac;
1.9       noro     1073:        NODE n,n0;
1.8       noro     1074:
                   1075:        ac = argc(arg);
1.14      noro     1076:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_mod");
                   1077:        asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_mod");
                   1078:        asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_mod");
                   1079:        asir_assert(ARG3(arg),O_N,"dp_weyl_nf_mod");
                   1080:        asir_assert(ARG4(arg),O_N,"dp_weyl_nf_mod");
1.8       noro     1081:        if ( !(g = (DP)ARG1(arg)) ) {
                   1082:                *rp = 0; return;
                   1083:        }
                   1084:        b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                   1085:        full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
1.9       noro     1086:        for ( n0 = n = 0; b; b = NEXT(b) ) {
                   1087:                NEXTNODE(n0,n);
                   1088:                BDY(n) = (pointer)QTOS((Q)BDY(b));
                   1089:        }
                   1090:        if ( n0 )
                   1091:                NEXT(n) = 0;
1.13      noro     1092:        do_weyl = 1;
                   1093:        dp_nf_mod(n0,g,ps,mod,full,rp);
                   1094:        do_weyl = 0;
1.8       noro     1095: }
                   1096:
                   1097: void Pdp_true_nf_mod(arg,rp)
                   1098: NODE arg;
                   1099: LIST *rp;
                   1100: {
                   1101:        NODE b;
                   1102:        DP g,nm;
                   1103:        P dn;
                   1104:        DP *ps;
                   1105:        int mod,full;
                   1106:        NODE n;
                   1107:
1.11      noro     1108:        do_weyl = 0;
1.8       noro     1109:        asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
                   1110:        asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
                   1111:        asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
                   1112:        asir_assert(ARG3(arg),O_N,"dp_nf_mod");
                   1113:        asir_assert(ARG4(arg),O_N,"dp_nf_mod");
                   1114:        if ( !(g = (DP)ARG1(arg)) ) {
                   1115:                nm = 0; dn = (P)ONEM;
                   1116:        } else {
                   1117:                b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                   1118:                full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
                   1119:                dp_true_nf_mod(b,g,ps,mod,full,&nm,&dn);
                   1120:        }
                   1121:        NEWNODE(n); BDY(n) = (pointer)nm;
                   1122:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
                   1123:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.1       noro     1124: }
                   1125:
                   1126: void Pdp_tdiv(arg,rp)
                   1127: NODE arg;
                   1128: DP *rp;
                   1129: {
                   1130:        MP m,mr,mr0;
                   1131:        DP p;
                   1132:        Q c;
                   1133:        N d,q,r;
                   1134:        int sgn;
                   1135:
                   1136:        asir_assert(ARG0(arg),O_DP,"dp_tdiv");
                   1137:        asir_assert(ARG1(arg),O_N,"dp_tdiv");
                   1138:        p = (DP)ARG0(arg); d = NM((Q)ARG1(arg)); sgn = SGN((Q)ARG1(arg));
                   1139:        if ( !p )
                   1140:                *rp = 0;
                   1141:        else {
                   1142:                for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
                   1143:                        divn(NM((Q)m->c),d,&q,&r);
                   1144:                        if ( r ) {
                   1145:                                *rp = 0; return;
                   1146:                        } else {
                   1147:                                NEXTMP(mr0,mr); NTOQ(q,SGN((Q)m->c)*sgn,c);
                   1148:                                mr->c = (P)c; mr->dl = m->dl;
                   1149:                        }
                   1150:                }
                   1151:                NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
                   1152:        }
                   1153: }
                   1154:
                   1155: void Pdp_red_coef(arg,rp)
                   1156: NODE arg;
                   1157: DP *rp;
                   1158: {
                   1159:        MP m,mr,mr0;
                   1160:        P q,r;
                   1161:        DP p;
                   1162:        P mod;
                   1163:
                   1164:        p = (DP)ARG0(arg); mod = (P)ARG1(arg);
                   1165:        asir_assert(p,O_DP,"dp_red_coef");
                   1166:        asir_assert(mod,O_P,"dp_red_coef");
                   1167:        if ( !p )
                   1168:                *rp = 0;
                   1169:        else {
                   1170:                for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
                   1171:                        divsrp(CO,m->c,mod,&q,&r);
                   1172:                        if ( r ) {
                   1173:                                NEXTMP(mr0,mr); mr->c = r; mr->dl = m->dl;
                   1174:                        }
                   1175:                }
                   1176:                if ( mr0 ) {
                   1177:                        NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
                   1178:                } else
                   1179:                        *rp = 0;
                   1180:        }
                   1181: }
                   1182:
                   1183: void Pdp_redble(arg,rp)
                   1184: NODE arg;
                   1185: Q *rp;
                   1186: {
                   1187:        asir_assert(ARG0(arg),O_DP,"dp_redble");
                   1188:        asir_assert(ARG1(arg),O_DP,"dp_redble");
                   1189:        if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
                   1190:                *rp = ONE;
                   1191:        else
                   1192:                *rp = 0;
                   1193: }
                   1194:
                   1195: void Pdp_red_mod(arg,rp)
                   1196: NODE arg;
                   1197: LIST *rp;
                   1198: {
                   1199:        DP h,r;
                   1200:        P dmy;
                   1201:        NODE n;
                   1202:
1.11      noro     1203:        do_weyl = 0;
1.1       noro     1204:        asir_assert(ARG0(arg),O_DP,"dp_red_mod");
                   1205:        asir_assert(ARG1(arg),O_DP,"dp_red_mod");
                   1206:        asir_assert(ARG2(arg),O_DP,"dp_red_mod");
                   1207:        asir_assert(ARG3(arg),O_N,"dp_red_mod");
                   1208:        dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),QTOS((Q)ARG3(arg)),
                   1209:                &h,&r,&dmy);
                   1210:        NEWNODE(n); BDY(n) = (pointer)h;
                   1211:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
                   1212:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
                   1213: }
1.13      noro     1214:
1.1       noro     1215: void Pdp_subd(arg,rp)
                   1216: NODE arg;
                   1217: DP *rp;
                   1218: {
                   1219:        DP p1,p2;
                   1220:
                   1221:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                   1222:        asir_assert(p1,O_DP,"dp_subd");
                   1223:        asir_assert(p2,O_DP,"dp_subd");
                   1224:        dp_subd(p1,p2,rp);
                   1225: }
                   1226:
1.32      noro     1227: void Pdp_mul_trunc(arg,rp)
                   1228: NODE arg;
                   1229: DP *rp;
                   1230: {
                   1231:        DP p1,p2,p;
                   1232:
                   1233:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); p = (DP)ARG2(arg);
                   1234:        asir_assert(p1,O_DP,"dp_mul_trunc");
                   1235:        asir_assert(p2,O_DP,"dp_mul_trunc");
                   1236:        asir_assert(p,O_DP,"dp_mul_trunc");
                   1237:        comm_muld_trunc(CO,p1,p2,BDY(p)->dl,rp);
                   1238: }
                   1239:
                   1240: void Pdp_quo(arg,rp)
                   1241: NODE arg;
                   1242: DP *rp;
                   1243: {
                   1244:        DP p1,p2;
                   1245:
                   1246:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                   1247:        asir_assert(p1,O_DP,"dp_quo");
                   1248:        asir_assert(p2,O_DP,"dp_quo");
                   1249:        comm_quod(CO,p1,p2,rp);
                   1250: }
                   1251:
1.12      noro     1252: void Pdp_weyl_mul(arg,rp)
                   1253: NODE arg;
                   1254: DP *rp;
                   1255: {
                   1256:        DP p1,p2;
                   1257:
                   1258:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1.32      noro     1259:        asir_assert(p1,O_DP,"dp_weyl_mul"); asir_assert(p2,O_DP,"dp_weyl_mul");
1.12      noro     1260:        do_weyl = 1;
                   1261:        muld(CO,p1,p2,rp);
1.13      noro     1262:        do_weyl = 0;
                   1263: }
                   1264:
                   1265: void Pdp_weyl_mul_mod(arg,rp)
                   1266: NODE arg;
                   1267: DP *rp;
                   1268: {
                   1269:        DP p1,p2;
                   1270:        Q m;
                   1271:
                   1272:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); m = (Q)ARG2(arg);
                   1273:        asir_assert(p1,O_DP,"dp_weyl_mul_mod");
                   1274:        asir_assert(p2,O_DP,"dp_mul_mod");
                   1275:        asir_assert(m,O_N,"dp_mul_mod");
                   1276:        do_weyl = 1;
                   1277:        mulmd(CO,QTOS(m),p1,p2,rp);
1.12      noro     1278:        do_weyl = 0;
                   1279: }
                   1280:
1.1       noro     1281: void Pdp_red(arg,rp)
                   1282: NODE arg;
                   1283: LIST *rp;
                   1284: {
                   1285:        NODE n;
1.4       noro     1286:        DP head,rest,dmy1;
1.1       noro     1287:        P dmy;
                   1288:
1.11      noro     1289:        do_weyl = 0;
1.1       noro     1290:        asir_assert(ARG0(arg),O_DP,"dp_red");
                   1291:        asir_assert(ARG1(arg),O_DP,"dp_red");
                   1292:        asir_assert(ARG2(arg),O_DP,"dp_red");
1.4       noro     1293:        dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.1       noro     1294:        NEWNODE(n); BDY(n) = (pointer)head;
                   1295:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
                   1296:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
                   1297: }
                   1298:
1.11      noro     1299: void Pdp_weyl_red(arg,rp)
                   1300: NODE arg;
                   1301: LIST *rp;
                   1302: {
                   1303:        NODE n;
                   1304:        DP head,rest,dmy1;
                   1305:        P dmy;
                   1306:
                   1307:        asir_assert(ARG0(arg),O_DP,"dp_weyl_red");
                   1308:        asir_assert(ARG1(arg),O_DP,"dp_weyl_red");
                   1309:        asir_assert(ARG2(arg),O_DP,"dp_weyl_red");
1.12      noro     1310:        do_weyl = 1;
1.11      noro     1311:        dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.12      noro     1312:        do_weyl = 0;
1.11      noro     1313:        NEWNODE(n); BDY(n) = (pointer)head;
                   1314:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
                   1315:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
                   1316: }
                   1317:
1.1       noro     1318: void Pdp_sp(arg,rp)
                   1319: NODE arg;
                   1320: DP *rp;
                   1321: {
                   1322:        DP p1,p2;
                   1323:
1.11      noro     1324:        do_weyl = 0;
1.1       noro     1325:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                   1326:        asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
                   1327:        dp_sp(p1,p2,rp);
                   1328: }
                   1329:
1.11      noro     1330: void Pdp_weyl_sp(arg,rp)
                   1331: NODE arg;
                   1332: DP *rp;
                   1333: {
                   1334:        DP p1,p2;
                   1335:
                   1336:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                   1337:        asir_assert(p1,O_DP,"dp_weyl_sp"); asir_assert(p2,O_DP,"dp_sp");
1.12      noro     1338:        do_weyl = 1;
1.11      noro     1339:        dp_sp(p1,p2,rp);
1.12      noro     1340:        do_weyl = 0;
1.11      noro     1341: }
                   1342:
1.1       noro     1343: void Pdp_sp_mod(arg,rp)
                   1344: NODE arg;
                   1345: DP *rp;
                   1346: {
                   1347:        DP p1,p2;
                   1348:        int mod;
                   1349:
1.11      noro     1350:        do_weyl = 0;
1.1       noro     1351:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                   1352:        asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
                   1353:        asir_assert(ARG2(arg),O_N,"dp_sp_mod");
                   1354:        mod = QTOS((Q)ARG2(arg));
                   1355:        dp_sp_mod(p1,p2,mod,rp);
                   1356: }
                   1357:
                   1358: void Pdp_lcm(arg,rp)
                   1359: NODE arg;
                   1360: DP *rp;
                   1361: {
                   1362:        int i,n,td;
                   1363:        DL d1,d2,d;
                   1364:        MP m;
                   1365:        DP p1,p2;
                   1366:
                   1367:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                   1368:        asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
                   1369:        n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
                   1370:        NEWDL(d,n);
                   1371:        for ( i = 0, td = 0; i < n; i++ ) {
1.24      noro     1372:                d->d[i] = MAX(d1->d[i],d2->d[i]); td += MUL_WEIGHT(d->d[i],i);
1.1       noro     1373:        }
                   1374:        d->td = td;
                   1375:        NEWMP(m); m->dl = d; m->c = (P)ONE; NEXT(m) = 0;
                   1376:        MKDP(n,m,*rp); (*rp)->sugar = td;       /* XXX */
                   1377: }
                   1378:
                   1379: void Pdp_hm(arg,rp)
                   1380: NODE arg;
                   1381: DP *rp;
                   1382: {
                   1383:        DP p;
                   1384:
                   1385:        p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
                   1386:        dp_hm(p,rp);
                   1387: }
                   1388:
                   1389: void Pdp_ht(arg,rp)
                   1390: NODE arg;
                   1391: DP *rp;
                   1392: {
                   1393:        DP p;
                   1394:        MP m,mr;
                   1395:
                   1396:        p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
1.52      noro     1397:        dp_ht(p,rp);
1.1       noro     1398: }
                   1399:
                   1400: void Pdp_hc(arg,rp)
                   1401: NODE arg;
                   1402: P *rp;
                   1403: {
                   1404:        asir_assert(ARG0(arg),O_DP,"dp_hc");
                   1405:        if ( !ARG0(arg) )
                   1406:                *rp = 0;
                   1407:        else
                   1408:                *rp = BDY((DP)ARG0(arg))->c;
                   1409: }
                   1410:
                   1411: void Pdp_rest(arg,rp)
                   1412: NODE arg;
                   1413: DP *rp;
                   1414: {
                   1415:        asir_assert(ARG0(arg),O_DP,"dp_rest");
                   1416:        if ( !ARG0(arg) )
                   1417:                *rp = 0;
                   1418:        else
                   1419:                dp_rest((DP)ARG0(arg),rp);
                   1420: }
                   1421:
                   1422: void Pdp_td(arg,rp)
                   1423: NODE arg;
                   1424: Q *rp;
                   1425: {
                   1426:        DP p;
                   1427:
                   1428:        p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
                   1429:        if ( !p )
                   1430:                *rp = 0;
                   1431:        else
                   1432:                STOQ(BDY(p)->dl->td,*rp);
                   1433: }
                   1434:
                   1435: void Pdp_sugar(arg,rp)
                   1436: NODE arg;
                   1437: Q *rp;
                   1438: {
                   1439:        DP p;
                   1440:
                   1441:        p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
                   1442:        if ( !p )
                   1443:                *rp = 0;
                   1444:        else
                   1445:                STOQ(p->sugar,*rp);
1.30      ohara    1446: }
                   1447:
1.49      noro     1448: void Pdp_initial_term(arg,rp)
                   1449: NODE arg;
                   1450: Obj *rp;
                   1451: {
                   1452:        struct order_spec *ord;
                   1453:        Num homo;
                   1454:        int modular,is_list;
                   1455:        LIST v,f,l,initiallist;
                   1456:        NODE n;
                   1457:
                   1458:        f = (LIST)ARG0(arg);
                   1459:        if ( f && OID(f) == O_LIST )
                   1460:                is_list = 1;
                   1461:        else {
                   1462:                n = mknode(1,f); MKLIST(l,n); f = l;
                   1463:                is_list = 0;
                   1464:        }
1.54      noro     1465:        if ( current_option ) {
1.53      noro     1466:                parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.54      noro     1467:                initd(ord);
                   1468:        } else
1.49      noro     1469:                ord = dp_current_spec;
                   1470:        initiallist = dp_initial_term(f,ord);
                   1471:        if ( !is_list )
                   1472:                *rp = (Obj)BDY(BDY(initiallist));
                   1473:        else
                   1474:                *rp = (Obj)initiallist;
                   1475: }
                   1476:
                   1477: void Pdp_order(arg,rp)
                   1478: NODE arg;
                   1479: Obj *rp;
                   1480: {
                   1481:        struct order_spec *ord;
                   1482:        Num homo;
                   1483:        int modular,is_list;
                   1484:        LIST v,f,l,ordlist;
                   1485:        NODE n;
                   1486:
                   1487:        f = (LIST)ARG0(arg);
                   1488:        if ( f && OID(f) == O_LIST )
                   1489:                is_list = 1;
                   1490:        else {
                   1491:                n = mknode(1,f); MKLIST(l,n); f = l;
                   1492:                is_list = 0;
                   1493:        }
1.54      noro     1494:        if ( current_option ) {
1.53      noro     1495:                parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.54      noro     1496:                initd(ord);
                   1497:        } else
1.49      noro     1498:                ord = dp_current_spec;
                   1499:        ordlist = dp_order(f,ord);
                   1500:        if ( !is_list )
                   1501:                *rp = (Obj)BDY(BDY(ordlist));
                   1502:        else
                   1503:                *rp = (Obj)ordlist;
                   1504: }
                   1505:
1.30      ohara    1506: void Pdp_set_sugar(arg,rp)
                   1507: NODE arg;
                   1508: Q *rp;
                   1509: {
                   1510:        DP p;
                   1511:        Q q;
                   1512:        int i;
                   1513:
                   1514:        p = (DP)ARG0(arg);
                   1515:        q = (Q)ARG1(arg);
                   1516:        if ( p && q) {
                   1517:                asir_assert(p,O_DP,"dp_set_sugar");
                   1518:                asir_assert(q,O_N, "dp_set_sugar");
                   1519:                i = QTOS(q);
                   1520:                if (p->sugar < i) {
                   1521:                        p->sugar = i;
                   1522:                }
                   1523:        }
                   1524:        *rp = 0;
1.1       noro     1525: }
                   1526:
                   1527: void Pdp_cri1(arg,rp)
                   1528: NODE arg;
                   1529: Q *rp;
                   1530: {
                   1531:        DP p1,p2;
                   1532:        int *d1,*d2;
                   1533:        int i,n;
                   1534:
                   1535:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                   1536:        asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
                   1537:        n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
                   1538:        for ( i = 0; i < n; i++ )
                   1539:                if ( d1[i] > d2[i] )
                   1540:                        break;
                   1541:        *rp = i == n ? ONE : 0;
                   1542: }
                   1543:
                   1544: void Pdp_cri2(arg,rp)
                   1545: NODE arg;
                   1546: Q *rp;
                   1547: {
                   1548:        DP p1,p2;
                   1549:        int *d1,*d2;
                   1550:        int i,n;
                   1551:
                   1552:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                   1553:        asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
                   1554:        n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
                   1555:        for ( i = 0; i < n; i++ )
                   1556:                if ( MIN(d1[i],d2[i]) >= 1 )
                   1557:                        break;
                   1558:        *rp = i == n ? ONE : 0;
                   1559: }
                   1560:
                   1561: void Pdp_minp(arg,rp)
                   1562: NODE arg;
                   1563: LIST *rp;
                   1564: {
                   1565:        NODE tn,tn1,d,dd,dd0,p,tp;
                   1566:        LIST l,minp;
                   1567:        DP lcm,tlcm;
                   1568:        int s,ts;
                   1569:
                   1570:        asir_assert(ARG0(arg),O_LIST,"dp_minp");
                   1571:        d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
                   1572:        p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
                   1573:        if ( !ARG1(arg) ) {
                   1574:                s = QTOS((Q)BDY(p)); p = NEXT(p);
                   1575:                for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
                   1576:                        tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
                   1577:                        tlcm = (DP)BDY(tp); tp = NEXT(tp);
                   1578:                        ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
                   1579:                        NEXTNODE(dd0,dd);
                   1580:                        if ( ts < s ) {
                   1581:                                BDY(dd) = (pointer)minp;
                   1582:                                minp = (LIST)BDY(d); lcm = tlcm; s = ts;
                   1583:                        } else if ( ts == s ) {
                   1584:                                if ( compd(CO,lcm,tlcm) > 0 ) {
                   1585:                                        BDY(dd) = (pointer)minp;
                   1586:                                        minp = (LIST)BDY(d); lcm = tlcm; s = ts;
                   1587:                                } else
                   1588:                                        BDY(dd) = BDY(d);
                   1589:                        } else
                   1590:                                BDY(dd) = BDY(d);
                   1591:                }
                   1592:        } else {
                   1593:                for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
                   1594:                        tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
                   1595:                        tlcm = (DP)BDY(tp);
                   1596:                        NEXTNODE(dd0,dd);
                   1597:                        if ( compd(CO,lcm,tlcm) > 0 ) {
                   1598:                                BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
                   1599:                        } else
                   1600:                                BDY(dd) = BDY(d);
                   1601:                }
                   1602:        }
                   1603:        if ( dd0 )
                   1604:                NEXT(dd) = 0;
                   1605:        MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
                   1606: }
                   1607:
                   1608: void Pdp_criB(arg,rp)
                   1609: NODE arg;
                   1610: LIST *rp;
                   1611: {
                   1612:        NODE d,ij,dd,ddd;
                   1613:        int i,j,s,n;
                   1614:        DP *ps;
                   1615:        DL ts,ti,tj,lij,tdl;
                   1616:
                   1617:        asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
                   1618:        asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
                   1619:        asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
                   1620:        if ( !d )
                   1621:                *rp = (LIST)ARG0(arg);
                   1622:        else {
                   1623:                ts = BDY(ps[s])->dl;
                   1624:                n = ps[s]->nv;
                   1625:                NEWDL(tdl,n);
                   1626:                for ( dd = 0; d; d = NEXT(d) ) {
                   1627:                        ij = BDY((LIST)BDY(d));
                   1628:                        i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
                   1629:                        j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
                   1630:                        lij = BDY((DP)BDY(ij))->dl;
                   1631:                        ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
                   1632:                        if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
                   1633:                                || !dl_equal(n,lij,tdl)
                   1634:                                || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
                   1635:                                        && dl_equal(n,tdl,lij))
                   1636:                                || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
                   1637:                                        && dl_equal(n,tdl,lij)) ) {
                   1638:                                MKNODE(ddd,BDY(d),dd);
                   1639:                                dd = ddd;
                   1640:                        }
                   1641:                }
                   1642:                MKLIST(*rp,dd);
                   1643:        }
                   1644: }
                   1645:
                   1646: void Pdp_nelim(arg,rp)
                   1647: NODE arg;
                   1648: Q *rp;
                   1649: {
                   1650:        if ( arg ) {
                   1651:                asir_assert(ARG0(arg),O_N,"dp_nelim");
                   1652:                dp_nelim = QTOS((Q)ARG0(arg));
                   1653:        }
                   1654:        STOQ(dp_nelim,*rp);
                   1655: }
                   1656:
                   1657: void Pdp_mag(arg,rp)
                   1658: NODE arg;
                   1659: Q *rp;
                   1660: {
                   1661:        DP p;
                   1662:        int s;
                   1663:        MP m;
                   1664:
                   1665:        p = (DP)ARG0(arg);
                   1666:        asir_assert(p,O_DP,"dp_mag");
                   1667:        if ( !p )
                   1668:                *rp = 0;
                   1669:        else {
                   1670:                for ( s = 0, m = BDY(p); m; m = NEXT(m) )
                   1671:                        s += p_mag(m->c);
                   1672:                STOQ(s,*rp);
                   1673:        }
                   1674: }
                   1675:
                   1676: extern int kara_mag;
                   1677:
                   1678: void Pdp_set_kara(arg,rp)
                   1679: NODE arg;
                   1680: Q *rp;
                   1681: {
                   1682:        if ( arg ) {
                   1683:                asir_assert(ARG0(arg),O_N,"dp_set_kara");
                   1684:                kara_mag = QTOS((Q)ARG0(arg));
                   1685:        }
                   1686:        STOQ(kara_mag,*rp);
                   1687: }
                   1688:
                   1689: void Pdp_homo(arg,rp)
                   1690: NODE arg;
                   1691: DP *rp;
                   1692: {
                   1693:        asir_assert(ARG0(arg),O_DP,"dp_homo");
                   1694:        dp_homo((DP)ARG0(arg),rp);
                   1695: }
                   1696:
1.8       noro     1697: void Pdp_dehomo(arg,rp)
                   1698: NODE arg;
1.1       noro     1699: DP *rp;
                   1700: {
1.8       noro     1701:        asir_assert(ARG0(arg),O_DP,"dp_dehomo");
                   1702:        dp_dehomo((DP)ARG0(arg),rp);
                   1703: }
                   1704:
                   1705: void Pdp_gr_flags(arg,rp)
                   1706: NODE arg;
                   1707: LIST *rp;
                   1708: {
                   1709:        Obj name,value;
                   1710:        NODE n;
1.1       noro     1711:
1.8       noro     1712:        if ( arg ) {
                   1713:                asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
                   1714:                n = BDY((LIST)ARG0(arg));
                   1715:                while ( n ) {
                   1716:                        name = (Obj)BDY(n); n = NEXT(n);
                   1717:                        if ( !n )
                   1718:                                break;
                   1719:                        else {
                   1720:                                value = (Obj)BDY(n); n = NEXT(n);
                   1721:                        }
                   1722:                        dp_set_flag(name,value);
1.1       noro     1723:                }
                   1724:        }
1.8       noro     1725:        dp_make_flaglist(rp);
                   1726: }
                   1727:
1.29      noro     1728: extern int DP_Print, DP_PrintShort;
1.8       noro     1729:
                   1730: void Pdp_gr_print(arg,rp)
                   1731: NODE arg;
                   1732: Q *rp;
                   1733: {
                   1734:        Q q;
1.29      noro     1735:        int s;
1.8       noro     1736:
                   1737:        if ( arg ) {
                   1738:                asir_assert(ARG0(arg),O_N,"dp_gr_print");
1.29      noro     1739:                q = (Q)ARG0(arg);
                   1740:                s = QTOS(q);
                   1741:                switch ( s ) {
                   1742:                        case 0:
                   1743:                                DP_Print = 0; DP_PrintShort = 0;
                   1744:                                break;
                   1745:                        case 1:
                   1746:                                DP_Print = 1;
                   1747:                                break;
1.41      noro     1748:                        case 2:
1.29      noro     1749:                                DP_Print = 0; DP_PrintShort = 1;
1.43      noro     1750:                                break;
1.41      noro     1751:                        default:
                   1752:                                DP_Print = s; DP_PrintShort = 0;
1.29      noro     1753:                                break;
                   1754:                }
                   1755:        } else {
                   1756:                if ( DP_Print ) {
                   1757:                        STOQ(1,q);
                   1758:                } else if ( DP_PrintShort ) {
                   1759:                        STOQ(2,q);
                   1760:                } else
                   1761:                        q = 0;
                   1762:        }
1.8       noro     1763:        *rp = q;
1.1       noro     1764: }
                   1765:
1.46      noro     1766: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
                   1767:        int *modular,struct order_spec **ord)
                   1768: {
                   1769:        NODE t,p;
                   1770:        Q m;
                   1771:        char *key;
                   1772:        Obj value,dmy;
                   1773:        int ord_is_set = 0;
                   1774:        int modular_is_set = 0;
                   1775:        int homo_is_set = 0;
1.47      noro     1776:        VL vl,vl0;
1.46      noro     1777:        LIST vars;
1.47      noro     1778:        char xiname[BUFSIZ];
                   1779:        NODE x0,x;
                   1780:        DP d;
                   1781:        P xi;
                   1782:        int nv,i;
1.46      noro     1783:
                   1784:        /* extract vars */
                   1785:        vars = 0;
                   1786:        for ( t = opt; t; t = NEXT(t) ) {
                   1787:                p = BDY((LIST)BDY(t));
                   1788:                key = BDY((STRING)BDY(p));
                   1789:                value = (Obj)BDY(NEXT(p));
                   1790:                if ( !strcmp(key,"v") ) {
                   1791:                        /* variable list */
                   1792:                        vars = (LIST)value;
                   1793:                        break;
                   1794:                }
                   1795:        }
1.48      noro     1796:        if ( vars ) {
                   1797:                *v = vars; pltovl(vars,&vl);
                   1798:        } else {
                   1799:                for ( t = BDY(f); t; t = NEXT(t) )
                   1800:                        if ( BDY(t) && OID((Obj)BDY(t))==O_DP )
                   1801:                                break;
                   1802:                if ( t ) {
                   1803:                        /* f is DP list */
                   1804:                        /* create dummy var list */
                   1805:                        d = (DP)BDY(t);
                   1806:                        nv = NV(d);
                   1807:                        for ( i = 0, vl0 = 0, x0 = 0; i < nv; i++ ) {
                   1808:                                NEXTVL(vl0,vl);
                   1809:                                NEXTNODE(x0,x);
                   1810:                                sprintf(xiname,"x%d",i);
                   1811:                                makevar(xiname,&xi);
                   1812:                                x->body = (pointer)xi;
                   1813:                                vl->v = VR((P)xi);
                   1814:                        }
                   1815:                        if ( vl0 ) {
                   1816:                                NEXT(vl) = 0;
                   1817:                                NEXT(x) = 0;
                   1818:                        }
                   1819:                        MKLIST(vars,x0);
                   1820:                        *v = vars;
                   1821:                        vl = vl0;
                   1822:                } else {
                   1823:                        get_vars((Obj)f,&vl); vltopl(vl,v);
1.47      noro     1824:                }
1.46      noro     1825:        }
                   1826:
                   1827:        for ( t = opt; t; t = NEXT(t) ) {
                   1828:                p = BDY((LIST)BDY(t));
                   1829:                key = BDY((STRING)BDY(p));
                   1830:                value = (Obj)BDY(NEXT(p));
                   1831:                if ( !strcmp(key,"v") ) {
                   1832:                        /* variable list; ignore */
                   1833:                } else if ( !strcmp(key,"order") ) {
                   1834:                        /* order spec */
1.51      noro     1835:                        if ( !vl )
                   1836:                                error("parse_gr_option : variables must be specified");
1.46      noro     1837:                        create_order_spec(vl,value,ord);
                   1838:                        ord_is_set = 1;
                   1839:                } else if ( !strcmp(key,"block") ) {
                   1840:                        create_order_spec(0,value,ord);
1.51      noro     1841:                        ord_is_set = 1;
1.46      noro     1842:                } else if ( !strcmp(key,"matrix") ) {
                   1843:                        create_order_spec(0,value,ord);
1.51      noro     1844:                        ord_is_set = 1;
1.46      noro     1845:                } else if ( !strcmp(key,"sugarweight") ) {
                   1846:                        /* weight */
                   1847:                        Pdp_set_weight(NEXT(p),&dmy);
                   1848:                } else if ( !strcmp(key,"homo") ) {
                   1849:                        *homo = (Num)value;
                   1850:                        homo_is_set = 1;
                   1851:                } else if ( !strcmp(key,"trace") ) {
                   1852:                        m = (Q)value;
                   1853:                        if ( !m )
                   1854:                                *modular = 0;
                   1855:                        else if ( PL(NM(m))>1 || (PL(NM(m)) == 1
                   1856:                                && BD(NM(m))[0] >= 0x80000000) )
                   1857:                                error("parse_gr_option : too large modulus");
                   1858:                        else
                   1859:                                *modular = QTOS(m);
                   1860:                        modular_is_set = 1;
                   1861:                } else
                   1862:                        error("parse_gr_option : not implemented");
                   1863:        }
                   1864:        if ( !ord_is_set ) create_order_spec(0,0,ord);
                   1865:        if ( !modular_is_set ) *modular = 0;
                   1866:        if ( !homo_is_set ) *homo = 0;
                   1867: }
                   1868:
1.8       noro     1869: void Pdp_gr_main(arg,rp)
1.1       noro     1870: NODE arg;
1.8       noro     1871: LIST *rp;
1.1       noro     1872: {
1.8       noro     1873:        LIST f,v;
1.46      noro     1874:        VL vl;
1.8       noro     1875:        Num homo;
                   1876:        Q m;
1.46      noro     1877:        int modular,ac;
                   1878:        struct order_spec *ord;
1.8       noro     1879:
1.11      noro     1880:        do_weyl = 0;
1.8       noro     1881:        asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1.46      noro     1882:        f = (LIST)ARG0(arg);
1.25      noro     1883:        f = remove_zero_from_list(f);
                   1884:        if ( !BDY(f) ) {
                   1885:                *rp = f; return;
                   1886:        }
1.53      noro     1887:        if ( (ac = argc(arg)) == 5 ) {
1.46      noro     1888:                asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
                   1889:                asir_assert(ARG2(arg),O_N,"dp_gr_main");
                   1890:                asir_assert(ARG3(arg),O_N,"dp_gr_main");
1.49      noro     1891:                v = (LIST)ARG1(arg);
1.46      noro     1892:                homo = (Num)ARG2(arg);
                   1893:                m = (Q)ARG3(arg);
                   1894:                if ( !m )
                   1895:                        modular = 0;
                   1896:                else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
                   1897:                        error("dp_gr_main : too large modulus");
                   1898:                else
                   1899:                        modular = QTOS(m);
                   1900:                create_order_spec(0,ARG4(arg),&ord);
1.53      noro     1901:        } else if ( current_option )
                   1902:                parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.46      noro     1903:        else if ( ac == 1 )
                   1904:                parse_gr_option(f,0,&v,&homo,&modular,&ord);
1.8       noro     1905:        else
1.46      noro     1906:                error("dp_gr_main : invalid argument");
                   1907:        dp_gr_main(f,v,homo,modular,0,ord,rp);
1.63      noro     1908: }
                   1909:
                   1910: void Pdp_interreduce(arg,rp)
                   1911: NODE arg;
                   1912: LIST *rp;
                   1913: {
                   1914:        LIST f,v;
                   1915:        VL vl;
                   1916:        int ac;
                   1917:        struct order_spec *ord;
                   1918:
                   1919:        do_weyl = 0;
                   1920:        asir_assert(ARG0(arg),O_LIST,"dp_interreduce");
                   1921:        f = (LIST)ARG0(arg);
                   1922:        f = remove_zero_from_list(f);
                   1923:        if ( !BDY(f) ) {
                   1924:                *rp = f; return;
                   1925:        }
                   1926:        if ( (ac = argc(arg)) == 3 ) {
                   1927:                asir_assert(ARG1(arg),O_LIST,"dp_interreduce");
                   1928:                v = (LIST)ARG1(arg);
                   1929:                create_order_spec(0,ARG2(arg),&ord);
                   1930:        }
                   1931:        dp_interreduce(f,v,0,ord,rp);
1.16      noro     1932: }
                   1933:
                   1934: void Pdp_gr_f_main(arg,rp)
                   1935: NODE arg;
                   1936: LIST *rp;
                   1937: {
                   1938:        LIST f,v;
                   1939:        Num homo;
1.26      noro     1940:        int m,field,t;
1.46      noro     1941:        struct order_spec *ord;
1.26      noro     1942:        NODE n;
1.16      noro     1943:
                   1944:        do_weyl = 0;
                   1945:        asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
                   1946:        asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
                   1947:        asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
                   1948:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     1949:        f = remove_zero_from_list(f);
                   1950:        if ( !BDY(f) ) {
                   1951:                *rp = f; return;
                   1952:        }
1.16      noro     1953:        homo = (Num)ARG2(arg);
1.27      noro     1954: #if 0
                   1955:        asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
1.26      noro     1956:        m = QTOS((Q)ARG3(arg));
                   1957:        if ( m )
                   1958:                error("dp_gr_f_main : trace lifting is not implemented yet");
1.46      noro     1959:        create_order_spec(0,ARG4(arg),&ord);
1.27      noro     1960: #else
                   1961:        m = 0;
1.46      noro     1962:        create_order_spec(0,ARG3(arg),&ord);
1.27      noro     1963: #endif
1.26      noro     1964:        field = 0;
                   1965:        for ( n = BDY(f); n; n = NEXT(n) ) {
                   1966:                t = get_field_type(BDY(n));
                   1967:                if ( !t )
                   1968:                        continue;
                   1969:                if ( t < 0 )
                   1970:                        error("dp_gr_f_main : incosistent coefficients");
                   1971:                if ( !field )
                   1972:                        field = t;
                   1973:                else if ( t != field )
                   1974:                        error("dp_gr_f_main : incosistent coefficients");
                   1975:        }
1.46      noro     1976:        dp_gr_main(f,v,homo,m?1:0,field,ord,rp);
1.1       noro     1977: }
                   1978:
1.8       noro     1979: void Pdp_f4_main(arg,rp)
                   1980: NODE arg;
                   1981: LIST *rp;
1.1       noro     1982: {
1.8       noro     1983:        LIST f,v;
1.46      noro     1984:        struct order_spec *ord;
1.1       noro     1985:
1.11      noro     1986:        do_weyl = 0;
1.8       noro     1987:        asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
                   1988:        asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
                   1989:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     1990:        f = remove_zero_from_list(f);
                   1991:        if ( !BDY(f) ) {
                   1992:                *rp = f; return;
                   1993:        }
1.46      noro     1994:        create_order_spec(0,ARG2(arg),&ord);
                   1995:        dp_f4_main(f,v,ord,rp);
1.22      noro     1996: }
                   1997:
                   1998: /* dp_gr_checklist(list of dp) */
                   1999:
                   2000: void Pdp_gr_checklist(arg,rp)
                   2001: NODE arg;
                   2002: LIST *rp;
                   2003: {
                   2004:        VECT g;
                   2005:        LIST dp;
                   2006:        NODE r;
1.23      noro     2007:        int n;
1.22      noro     2008:
                   2009:        do_weyl = 0;
                   2010:        asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
1.23      noro     2011:        asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
                   2012:        n = QTOS((Q)ARG1(arg));
                   2013:        gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
1.22      noro     2014:        r = mknode(2,g,dp);
                   2015:        MKLIST(*rp,r);
1.1       noro     2016: }
                   2017:
1.8       noro     2018: void Pdp_f4_mod_main(arg,rp)
                   2019: NODE arg;
                   2020: LIST *rp;
1.1       noro     2021: {
1.8       noro     2022:        LIST f,v;
                   2023:        int m;
1.46      noro     2024:        struct order_spec *ord;
1.8       noro     2025:
1.11      noro     2026:        do_weyl = 0;
1.17      noro     2027:        asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
                   2028:        asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
                   2029:        asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
1.8       noro     2030:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25      noro     2031:        f = remove_zero_from_list(f);
                   2032:        if ( !BDY(f) ) {
                   2033:                *rp = f; return;
                   2034:        }
1.20      noro     2035:        if ( !m )
                   2036:                error("dp_f4_mod_main : invalid argument");
1.46      noro     2037:        create_order_spec(0,ARG3(arg),&ord);
                   2038:        dp_f4_mod_main(f,v,m,ord,rp);
1.8       noro     2039: }
1.1       noro     2040:
1.8       noro     2041: void Pdp_gr_mod_main(arg,rp)
                   2042: NODE arg;
                   2043: LIST *rp;
                   2044: {
                   2045:        LIST f,v;
                   2046:        Num homo;
                   2047:        int m;
1.46      noro     2048:        struct order_spec *ord;
1.8       noro     2049:
1.11      noro     2050:        do_weyl = 0;
1.8       noro     2051:        asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
                   2052:        asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
                   2053:        asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
                   2054:        asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1.11      noro     2055:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     2056:        f = remove_zero_from_list(f);
                   2057:        if ( !BDY(f) ) {
                   2058:                *rp = f; return;
                   2059:        }
1.11      noro     2060:        homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20      noro     2061:        if ( !m )
                   2062:                error("dp_gr_mod_main : invalid argument");
1.46      noro     2063:        create_order_spec(0,ARG4(arg),&ord);
                   2064:        dp_gr_mod_main(f,v,homo,m,ord,rp);
1.33      noro     2065: }
                   2066:
1.40      noro     2067: void Pnd_f4(arg,rp)
                   2068: NODE arg;
                   2069: LIST *rp;
                   2070: {
                   2071:        LIST f,v;
                   2072:        int m,homo;
1.46      noro     2073:        struct order_spec *ord;
1.40      noro     2074:
                   2075:        do_weyl = 0;
1.76      noro     2076:        asir_assert(ARG0(arg),O_LIST,"nd_f4");
                   2077:        asir_assert(ARG1(arg),O_LIST,"nd_f4");
                   2078:        asir_assert(ARG2(arg),O_N,"nd_f4");
1.40      noro     2079:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
                   2080:        f = remove_zero_from_list(f);
                   2081:        if ( !BDY(f) ) {
                   2082:                *rp = f; return;
                   2083:        }
                   2084:        m = QTOS((Q)ARG2(arg));
1.46      noro     2085:        create_order_spec(0,ARG3(arg),&ord);
                   2086:        nd_gr(f,v,m,1,ord,rp);
1.40      noro     2087: }
                   2088:
1.33      noro     2089: void Pnd_gr(arg,rp)
                   2090: NODE arg;
                   2091: LIST *rp;
                   2092: {
                   2093:        LIST f,v;
1.36      noro     2094:        int m,homo;
1.46      noro     2095:        struct order_spec *ord;
1.33      noro     2096:
                   2097:        do_weyl = 0;
                   2098:        asir_assert(ARG0(arg),O_LIST,"nd_gr");
                   2099:        asir_assert(ARG1(arg),O_LIST,"nd_gr");
1.36      noro     2100:        asir_assert(ARG2(arg),O_N,"nd_gr");
1.33      noro     2101:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
                   2102:        f = remove_zero_from_list(f);
                   2103:        if ( !BDY(f) ) {
                   2104:                *rp = f; return;
                   2105:        }
                   2106:        m = QTOS((Q)ARG2(arg));
1.46      noro     2107:        create_order_spec(0,ARG3(arg),&ord);
                   2108:        nd_gr(f,v,m,0,ord,rp);
1.58      noro     2109: }
                   2110:
                   2111: void Pnd_gr_postproc(arg,rp)
                   2112: NODE arg;
                   2113: LIST *rp;
                   2114: {
                   2115:        LIST f,v;
                   2116:        int m,do_check;
                   2117:        struct order_spec *ord;
                   2118:
                   2119:        do_weyl = 0;
                   2120:        asir_assert(ARG0(arg),O_LIST,"nd_gr");
                   2121:        asir_assert(ARG1(arg),O_LIST,"nd_gr");
                   2122:        asir_assert(ARG2(arg),O_N,"nd_gr");
                   2123:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
                   2124:        f = remove_zero_from_list(f);
                   2125:        if ( !BDY(f) ) {
                   2126:                *rp = f; return;
                   2127:        }
                   2128:        m = QTOS((Q)ARG2(arg));
                   2129:        create_order_spec(0,ARG3(arg),&ord);
                   2130:        do_check = ARG4(arg) ? 1 : 0;
                   2131:        nd_gr_postproc(f,v,m,ord,do_check,rp);
1.36      noro     2132: }
                   2133:
1.75      noro     2134: void Pnd_weyl_gr_postproc(arg,rp)
                   2135: NODE arg;
                   2136: LIST *rp;
                   2137: {
                   2138:        LIST f,v;
                   2139:        int m,do_check;
                   2140:        struct order_spec *ord;
                   2141:
                   2142:        do_weyl = 1;
                   2143:        asir_assert(ARG0(arg),O_LIST,"nd_gr");
                   2144:        asir_assert(ARG1(arg),O_LIST,"nd_gr");
                   2145:        asir_assert(ARG2(arg),O_N,"nd_gr");
                   2146:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
                   2147:        f = remove_zero_from_list(f);
                   2148:        if ( !BDY(f) ) {
                   2149:                *rp = f; return;
                   2150:        }
                   2151:        m = QTOS((Q)ARG2(arg));
                   2152:        create_order_spec(0,ARG3(arg),&ord);
                   2153:        do_check = ARG4(arg) ? 1 : 0;
                   2154:        nd_gr_postproc(f,v,m,ord,do_check,rp);
                   2155: }
                   2156:
1.36      noro     2157: void Pnd_gr_trace(arg,rp)
                   2158: NODE arg;
                   2159: LIST *rp;
                   2160: {
                   2161:        LIST f,v;
                   2162:        int m,homo;
1.46      noro     2163:        struct order_spec *ord;
1.36      noro     2164:
                   2165:        do_weyl = 0;
                   2166:        asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
                   2167:        asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
                   2168:        asir_assert(ARG2(arg),O_N,"nd_gr_trace");
                   2169:        asir_assert(ARG3(arg),O_N,"nd_gr_trace");
                   2170:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
                   2171:        f = remove_zero_from_list(f);
                   2172:        if ( !BDY(f) ) {
                   2173:                *rp = f; return;
                   2174:        }
                   2175:        homo = QTOS((Q)ARG2(arg));
                   2176:        m = QTOS((Q)ARG3(arg));
1.46      noro     2177:        create_order_spec(0,ARG4(arg),&ord);
1.62      noro     2178:        nd_gr_trace(f,v,m,homo,0,ord,rp);
                   2179: }
                   2180:
                   2181: void Pnd_f4_trace(arg,rp)
                   2182: NODE arg;
                   2183: LIST *rp;
                   2184: {
                   2185:        LIST f,v;
                   2186:        int m,homo;
                   2187:        struct order_spec *ord;
                   2188:
                   2189:        do_weyl = 0;
                   2190:        asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
                   2191:        asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
                   2192:        asir_assert(ARG2(arg),O_N,"nd_gr_trace");
                   2193:        asir_assert(ARG3(arg),O_N,"nd_gr_trace");
                   2194:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
                   2195:        f = remove_zero_from_list(f);
                   2196:        if ( !BDY(f) ) {
                   2197:                *rp = f; return;
                   2198:        }
                   2199:        homo = QTOS((Q)ARG2(arg));
                   2200:        m = QTOS((Q)ARG3(arg));
                   2201:        create_order_spec(0,ARG4(arg),&ord);
                   2202:        nd_gr_trace(f,v,m,homo,1,ord,rp);
1.11      noro     2203: }
                   2204:
1.38      noro     2205: void Pnd_weyl_gr(arg,rp)
                   2206: NODE arg;
                   2207: LIST *rp;
                   2208: {
                   2209:        LIST f,v;
                   2210:        int m,homo;
1.46      noro     2211:        struct order_spec *ord;
1.38      noro     2212:
                   2213:        do_weyl = 1;
                   2214:        asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr");
                   2215:        asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr");
                   2216:        asir_assert(ARG2(arg),O_N,"nd_weyl_gr");
                   2217:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
                   2218:        f = remove_zero_from_list(f);
                   2219:        if ( !BDY(f) ) {
                   2220:                *rp = f; return;
                   2221:        }
                   2222:        m = QTOS((Q)ARG2(arg));
1.46      noro     2223:        create_order_spec(0,ARG3(arg),&ord);
                   2224:        nd_gr(f,v,m,0,ord,rp);
1.38      noro     2225: }
                   2226:
                   2227: void Pnd_weyl_gr_trace(arg,rp)
                   2228: NODE arg;
                   2229: LIST *rp;
                   2230: {
                   2231:        LIST f,v;
                   2232:        int m,homo;
1.46      noro     2233:        struct order_spec *ord;
1.38      noro     2234:
                   2235:        do_weyl = 1;
                   2236:        asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr_trace");
                   2237:        asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr_trace");
                   2238:        asir_assert(ARG2(arg),O_N,"nd_weyl_gr_trace");
                   2239:        asir_assert(ARG3(arg),O_N,"nd_weyl_gr_trace");
                   2240:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
                   2241:        f = remove_zero_from_list(f);
                   2242:        if ( !BDY(f) ) {
                   2243:                *rp = f; return;
                   2244:        }
                   2245:        homo = QTOS((Q)ARG2(arg));
                   2246:        m = QTOS((Q)ARG3(arg));
1.46      noro     2247:        create_order_spec(0,ARG4(arg),&ord);
1.65      noro     2248:        nd_gr_trace(f,v,m,homo,0,ord,rp);
1.38      noro     2249: }
1.39      noro     2250:
                   2251: void Pnd_nf(arg,rp)
                   2252: NODE arg;
                   2253: P *rp;
                   2254: {
                   2255:        P f;
                   2256:        LIST g,v;
1.46      noro     2257:        struct order_spec *ord;
1.39      noro     2258:
                   2259:        do_weyl = 0;
                   2260:        asir_assert(ARG0(arg),O_P,"nd_nf");
                   2261:        asir_assert(ARG1(arg),O_LIST,"nd_nf");
                   2262:        asir_assert(ARG2(arg),O_LIST,"nd_nf");
                   2263:        asir_assert(ARG4(arg),O_N,"nd_nf");
                   2264:        f = (P)ARG0(arg);
                   2265:        g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
                   2266:        if ( !BDY(g) ) {
                   2267:                *rp = f; return;
                   2268:        }
                   2269:        v = (LIST)ARG2(arg);
1.46      noro     2270:        create_order_spec(0,ARG3(arg),&ord);
                   2271:        nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),ord,rp);
1.39      noro     2272: }
                   2273:
1.11      noro     2274: /* for Weyl algebra */
                   2275:
                   2276: void Pdp_weyl_gr_main(arg,rp)
                   2277: NODE arg;
                   2278: LIST *rp;
                   2279: {
                   2280:        LIST f,v;
                   2281:        Num homo;
                   2282:        Q m;
1.49      noro     2283:        int modular,ac;
1.46      noro     2284:        struct order_spec *ord;
1.11      noro     2285:
1.49      noro     2286:
1.11      noro     2287:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1.49      noro     2288:        f = (LIST)ARG0(arg);
1.25      noro     2289:        f = remove_zero_from_list(f);
                   2290:        if ( !BDY(f) ) {
                   2291:                *rp = f; return;
                   2292:        }
1.53      noro     2293:        if ( (ac = argc(arg)) == 5 ) {
1.49      noro     2294:                asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
                   2295:                asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
                   2296:                asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
                   2297:                v = (LIST)ARG1(arg);
                   2298:                homo = (Num)ARG2(arg);
                   2299:                m = (Q)ARG3(arg);
                   2300:                if ( !m )
                   2301:                        modular = 0;
                   2302:                else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
                   2303:                        error("dp_weyl_gr_main : too large modulus");
                   2304:                else
                   2305:                        modular = QTOS(m);
                   2306:                create_order_spec(0,ARG4(arg),&ord);
1.53      noro     2307:        } else if ( current_option )
                   2308:                parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.49      noro     2309:        else if ( ac == 1 )
                   2310:                parse_gr_option(f,0,&v,&homo,&modular,&ord);
1.11      noro     2311:        else
1.49      noro     2312:                error("dp_weyl_gr_main : invalid argument");
1.12      noro     2313:        do_weyl = 1;
1.46      noro     2314:        dp_gr_main(f,v,homo,modular,0,ord,rp);
1.16      noro     2315:        do_weyl = 0;
                   2316: }
                   2317:
                   2318: void Pdp_weyl_gr_f_main(arg,rp)
                   2319: NODE arg;
                   2320: LIST *rp;
                   2321: {
                   2322:        LIST f,v;
                   2323:        Num homo;
1.46      noro     2324:        struct order_spec *ord;
1.16      noro     2325:
                   2326:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
                   2327:        asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
                   2328:        asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
                   2329:        asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
                   2330:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     2331:        f = remove_zero_from_list(f);
                   2332:        if ( !BDY(f) ) {
                   2333:                *rp = f; return;
                   2334:        }
1.16      noro     2335:        homo = (Num)ARG2(arg);
1.46      noro     2336:        create_order_spec(0,ARG3(arg),&ord);
1.16      noro     2337:        do_weyl = 1;
1.46      noro     2338:        dp_gr_main(f,v,homo,0,1,ord,rp);
1.12      noro     2339:        do_weyl = 0;
1.11      noro     2340: }
                   2341:
                   2342: void Pdp_weyl_f4_main(arg,rp)
                   2343: NODE arg;
                   2344: LIST *rp;
                   2345: {
                   2346:        LIST f,v;
1.46      noro     2347:        struct order_spec *ord;
1.11      noro     2348:
                   2349:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
                   2350:        asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
                   2351:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     2352:        f = remove_zero_from_list(f);
                   2353:        if ( !BDY(f) ) {
                   2354:                *rp = f; return;
                   2355:        }
1.46      noro     2356:        create_order_spec(0,ARG2(arg),&ord);
1.12      noro     2357:        do_weyl = 1;
1.46      noro     2358:        dp_f4_main(f,v,ord,rp);
1.12      noro     2359:        do_weyl = 0;
1.11      noro     2360: }
                   2361:
                   2362: void Pdp_weyl_f4_mod_main(arg,rp)
                   2363: NODE arg;
                   2364: LIST *rp;
                   2365: {
                   2366:        LIST f,v;
                   2367:        int m;
1.46      noro     2368:        struct order_spec *ord;
1.11      noro     2369:
                   2370:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
                   2371:        asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
                   2372:        asir_assert(ARG2(arg),O_N,"dp_f4_main");
                   2373:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25      noro     2374:        f = remove_zero_from_list(f);
                   2375:        if ( !BDY(f) ) {
                   2376:                *rp = f; return;
                   2377:        }
1.20      noro     2378:        if ( !m )
                   2379:                error("dp_weyl_f4_mod_main : invalid argument");
1.46      noro     2380:        create_order_spec(0,ARG3(arg),&ord);
1.12      noro     2381:        do_weyl = 1;
1.46      noro     2382:        dp_f4_mod_main(f,v,m,ord,rp);
1.12      noro     2383:        do_weyl = 0;
1.11      noro     2384: }
                   2385:
                   2386: void Pdp_weyl_gr_mod_main(arg,rp)
                   2387: NODE arg;
                   2388: LIST *rp;
                   2389: {
                   2390:        LIST f,v;
                   2391:        Num homo;
                   2392:        int m;
1.46      noro     2393:        struct order_spec *ord;
1.11      noro     2394:
                   2395:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
                   2396:        asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
                   2397:        asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
                   2398:        asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
1.8       noro     2399:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     2400:        f = remove_zero_from_list(f);
                   2401:        if ( !BDY(f) ) {
                   2402:                *rp = f; return;
                   2403:        }
1.8       noro     2404:        homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20      noro     2405:        if ( !m )
                   2406:                error("dp_weyl_gr_mod_main : invalid argument");
1.46      noro     2407:        create_order_spec(0,ARG4(arg),&ord);
1.12      noro     2408:        do_weyl = 1;
1.46      noro     2409:        dp_gr_mod_main(f,v,homo,m,ord,rp);
1.12      noro     2410:        do_weyl = 0;
1.1       noro     2411: }
1.8       noro     2412:
1.57      noro     2413: VECT current_dl_weight_vector_obj;
1.24      noro     2414: int *current_dl_weight_vector;
                   2415:
                   2416: void Pdp_set_weight(arg,rp)
                   2417: NODE arg;
                   2418: VECT *rp;
                   2419: {
                   2420:        VECT v;
                   2421:        int i,n;
1.45      noro     2422:        NODE node;
1.24      noro     2423:
                   2424:        if ( !arg )
                   2425:                *rp = current_dl_weight_vector_obj;
                   2426:        else if ( !ARG0(arg) ) {
                   2427:                current_dl_weight_vector_obj = 0;
                   2428:                current_dl_weight_vector = 0;
                   2429:                *rp = 0;
                   2430:        } else {
1.45      noro     2431:                if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
                   2432:                        error("dp_set_weight : invalid argument");
                   2433:                if ( OID(ARG0(arg)) == O_VECT )
                   2434:                        v = (VECT)ARG0(arg);
                   2435:                else {
                   2436:                        node = (NODE)BDY((LIST)ARG0(arg));
                   2437:                        n = length(node);
                   2438:                        MKVECT(v,n);
                   2439:                        for ( i = 0; i < n; i++, node = NEXT(node) )
                   2440:                                BDY(v)[i] = BDY(node);
                   2441:                }
1.24      noro     2442:                current_dl_weight_vector_obj = v;
                   2443:                n = v->len;
                   2444:                current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
                   2445:                for ( i = 0; i < n; i++ )
                   2446:                        current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
                   2447:                *rp = v;
                   2448:        }
                   2449: }
                   2450:
1.77    ! noro     2451: VECT current_module_weight_vector_obj;
        !          2452: int *current_module_weight_vector;
        !          2453:
        !          2454: void Pdp_set_module_weight(arg,rp)
        !          2455: NODE arg;
        !          2456: VECT *rp;
        !          2457: {
        !          2458:        VECT v;
        !          2459:        int i,n;
        !          2460:        NODE node;
        !          2461:
        !          2462:        if ( !arg )
        !          2463:                *rp = current_module_weight_vector_obj;
        !          2464:        else if ( !ARG0(arg) ) {
        !          2465:                current_module_weight_vector_obj = 0;
        !          2466:                current_module_weight_vector = 0;
        !          2467:                *rp = 0;
        !          2468:        } else {
        !          2469:                if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
        !          2470:                        error("dp_module_set_weight : invalid argument");
        !          2471:                if ( OID(ARG0(arg)) == O_VECT )
        !          2472:                        v = (VECT)ARG0(arg);
        !          2473:                else {
        !          2474:                        node = (NODE)BDY((LIST)ARG0(arg));
        !          2475:                        n = length(node);
        !          2476:                        MKVECT(v,n);
        !          2477:                        for ( i = 0; i < n; i++, node = NEXT(node) )
        !          2478:                                BDY(v)[i] = BDY(node);
        !          2479:                }
        !          2480:                current_module_weight_vector_obj = v;
        !          2481:                n = v->len;
        !          2482:                current_module_weight_vector = (int *)CALLOC(n,sizeof(int));
        !          2483:                for ( i = 0; i < n; i++ )
        !          2484:                        current_module_weight_vector[i] = QTOS((Q)v->body[i]);
        !          2485:                *rp = v;
        !          2486:        }
        !          2487: }
        !          2488:
1.71      noro     2489: VECT current_top_weight_vector_obj;
                   2490: N *current_top_weight_vector;
                   2491:
                   2492: void Pdp_set_top_weight(arg,rp)
                   2493: NODE arg;
                   2494: VECT *rp;
                   2495: {
                   2496:        VECT v;
                   2497:        int i,n;
                   2498:        NODE node;
                   2499:
                   2500:        if ( !arg )
                   2501:                *rp = current_top_weight_vector_obj;
                   2502:        else if ( !ARG0(arg) ) {
                   2503:                current_top_weight_vector = 0;
                   2504:                current_top_weight_vector_obj = 0;
                   2505:                *rp = 0;
                   2506:        } else {
                   2507:                if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
                   2508:                        error("dp_set_top_weight : invalid argument");
                   2509:                if ( OID(ARG0(arg)) == O_VECT )
                   2510:                        v = (VECT)ARG0(arg);
                   2511:                else {
                   2512:                        node = (NODE)BDY((LIST)ARG0(arg));
                   2513:                        n = length(node);
                   2514:                        MKVECT(v,n);
                   2515:                        for ( i = 0; i < n; i++, node = NEXT(node) )
                   2516:                                BDY(v)[i] = BDY(node);
                   2517:                }
                   2518:                for ( i = 0; i < v->len; i++ )
1.74      noro     2519:                        if ( !INT(BDY(v)[i]) || (BDY(v)[i] && SGN((Q)BDY(v)[i]) < 0) )
1.71      noro     2520:                                error("dp_set_top_weight : each element must be a non-negative integer");
                   2521:                current_top_weight_vector_obj = v;
                   2522:                current_top_weight_vector = (N *)MALLOC(v->len*sizeof(N));
                   2523:                for ( i = 0; i < v->len; i++ ) {
1.74      noro     2524:                        current_top_weight_vector[i] = !BDY(v)[i]?0:NM((Q)BDY(v)[i]);
1.71      noro     2525:                }
                   2526:                *rp = current_top_weight_vector_obj;
                   2527:        }
                   2528: }
                   2529:
1.72      noro     2530: LIST get_denomlist();
                   2531:
                   2532: void Pdp_get_denomlist(LIST *rp)
                   2533: {
                   2534:        *rp = get_denomlist();
                   2535: }
                   2536:
1.24      noro     2537: static VECT current_weyl_weight_vector_obj;
                   2538: int *current_weyl_weight_vector;
1.15      noro     2539:
                   2540: void Pdp_weyl_set_weight(arg,rp)
                   2541: NODE arg;
                   2542: VECT *rp;
                   2543: {
                   2544:        VECT v;
                   2545:        int i,n;
                   2546:
                   2547:        if ( !arg )
1.24      noro     2548:                *rp = current_weyl_weight_vector_obj;
1.15      noro     2549:        else {
                   2550:                asir_assert(ARG0(arg),O_VECT,"dp_weyl_set_weight");
                   2551:                v = (VECT)ARG0(arg);
1.24      noro     2552:                current_weyl_weight_vector_obj = v;
1.15      noro     2553:                n = v->len;
1.24      noro     2554:                current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
1.15      noro     2555:                for ( i = 0; i < n; i++ )
1.24      noro     2556:                        current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
1.15      noro     2557:                *rp = v;
                   2558:        }
1.25      noro     2559: }
                   2560:
                   2561: LIST remove_zero_from_list(LIST l)
                   2562: {
                   2563:        NODE n,r0,r;
                   2564:        LIST rl;
                   2565:
                   2566:        asir_assert(l,O_LIST,"remove_zero_from_list");
                   2567:        n = BDY(l);
                   2568:        for ( r0 = 0; n; n = NEXT(n) )
                   2569:                if ( BDY(n) ) {
                   2570:                        NEXTNODE(r0,r);
                   2571:                        BDY(r) = BDY(n);
                   2572:                }
                   2573:        if ( r0 )
                   2574:                NEXT(r) = 0;
                   2575:        MKLIST(rl,r0);
                   2576:        return rl;
1.26      noro     2577: }
                   2578:
                   2579: int get_field_type(P p)
                   2580: {
                   2581:        int type,t;
                   2582:        DCP dc;
                   2583:
                   2584:        if ( !p )
                   2585:                return 0;
                   2586:        else if ( NUM(p) )
                   2587:                return NID((Num)p);
                   2588:        else {
                   2589:                type = 0;
                   2590:                for ( dc = DC(p); dc; dc = NEXT(dc) ) {
                   2591:                        t = get_field_type(COEF(dc));
                   2592:                        if ( !t )
                   2593:                                continue;
                   2594:                        if ( t < 0 )
                   2595:                                return t;
                   2596:                        if ( !type )
                   2597:                                type = t;
                   2598:                        else if ( t != type )
                   2599:                                return -1;
                   2600:                }
                   2601:                return type;
1.52      noro     2602:        }
                   2603: }
                   2604:
                   2605: void Pdpv_ord(NODE arg,Obj *rp)
                   2606: {
                   2607:        int ac,id;
                   2608:        LIST shift;
                   2609:
                   2610:        ac = argc(arg);
                   2611:        if ( ac ) {
                   2612:                id = QTOS((Q)ARG0(arg));
                   2613:                if ( ac > 1 && ARG1(arg) && OID((Obj)ARG1(arg))==O_LIST )
                   2614:                        shift = (LIST)ARG1(arg);
                   2615:                else
                   2616:                        shift = 0;
                   2617:                create_modorder_spec(id,shift,&dp_current_modspec);
                   2618:        }
                   2619:        *rp = dp_current_modspec->obj;
                   2620: }
                   2621:
                   2622: void Pdpv_ht(NODE arg,LIST *rp)
                   2623: {
                   2624:        NODE n;
                   2625:        DP ht;
                   2626:        int pos;
                   2627:        DPV p;
                   2628:        Q q;
                   2629:
                   2630:        asir_assert(ARG0(arg),O_DPV,"dpv_ht");
                   2631:        p = (DPV)ARG0(arg);
                   2632:        pos = dpv_hp(p);
                   2633:        if ( pos < 0 )
                   2634:                ht = 0;
                   2635:        else
                   2636:                dp_ht(BDY(p)[pos],&ht);
                   2637:        STOQ(pos,q);
                   2638:        n = mknode(2,q,ht);
                   2639:        MKLIST(*rp,n);
                   2640: }
                   2641:
                   2642: void Pdpv_hm(NODE arg,LIST *rp)
                   2643: {
                   2644:        NODE n;
                   2645:        DP ht;
                   2646:        int pos;
                   2647:        DPV p;
                   2648:        Q q;
                   2649:
                   2650:        asir_assert(ARG0(arg),O_DPV,"dpv_hm");
                   2651:        p = (DPV)ARG0(arg);
                   2652:        pos = dpv_hp(p);
                   2653:        if ( pos < 0 )
                   2654:                ht = 0;
                   2655:        else
                   2656:                dp_hm(BDY(p)[pos],&ht);
                   2657:        STOQ(pos,q);
                   2658:        n = mknode(2,q,ht);
                   2659:        MKLIST(*rp,n);
                   2660: }
                   2661:
                   2662: void Pdpv_hc(NODE arg,LIST *rp)
                   2663: {
                   2664:        NODE n;
                   2665:        P hc;
                   2666:        int pos;
                   2667:        DPV p;
                   2668:        Q q;
                   2669:
                   2670:        asir_assert(ARG0(arg),O_DPV,"dpv_hc");
                   2671:        p = (DPV)ARG0(arg);
                   2672:        pos = dpv_hp(p);
                   2673:        if ( pos < 0 )
                   2674:                hc = 0;
                   2675:        else
                   2676:                hc = BDY(BDY(p)[pos])->c;
                   2677:        STOQ(pos,q);
                   2678:        n = mknode(2,q,hc);
                   2679:        MKLIST(*rp,n);
                   2680: }
                   2681:
                   2682: int dpv_hp(DPV p)
                   2683: {
                   2684:        int len,i,maxp,maxw,w,slen;
                   2685:        int *shift;
                   2686:        DP *e;
                   2687:
                   2688:        len = p->len;
                   2689:        e = p->body;
                   2690:        slen = dp_current_modspec->len;
                   2691:        shift = dp_current_modspec->degree_shift;
                   2692:        switch ( dp_current_modspec->id ) {
                   2693:                case ORD_REVGRADLEX:
                   2694:                        for ( maxp = -1, i = 0; i < len; i++ )
                   2695:                                if ( !e[i] ) continue;
                   2696:                                else if ( maxp < 0 ) {
                   2697:                                        maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
                   2698:                                } else {
                   2699:                                        w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
                   2700:                                        if ( w >= maxw ) {
                   2701:                                                maxw = w; maxp = i;
                   2702:                                        }
                   2703:                                }
                   2704:                        return maxp;
                   2705:                case ORD_GRADLEX:
                   2706:                        for ( maxp = -1, i = 0; i < len; i++ )
                   2707:                                if ( !e[i] ) continue;
                   2708:                                else if ( maxp < 0 ) {
                   2709:                                        maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
                   2710:                                } else {
                   2711:                                        w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
                   2712:                                        if ( w > maxw ) {
                   2713:                                                maxw = w; maxp = i;
                   2714:                                        }
                   2715:                                }
                   2716:                        return maxp;
                   2717:                        break;
                   2718:                case ORD_LEX:
                   2719:                        for ( i = 0; i < len; i++ )
                   2720:                                if ( e[i] ) return i;
                   2721:                        return -1;
                   2722:                        break;
1.26      noro     2723:        }
1.15      noro     2724: }

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>