[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.27

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
                      9:  * conditions of this Agreement. For the avoidance of doubt, you acquire
                     10:  * only a limited right to use the SOFTWARE hereunder, and FLL or any
                     11:  * third party developer retains all rights, including but not limited to
                     12:  * copyrights, in and to the SOFTWARE.
                     13:  *
                     14:  * (1) FLL does not grant you a license in any way for commercial
                     15:  * purposes. You may use the SOFTWARE only for non-commercial and
                     16:  * non-profit purposes only, such as academic, research and internal
                     17:  * business use.
                     18:  * (2) The SOFTWARE is protected by the Copyright Law of Japan and
                     19:  * international copyright treaties. If you make copies of the SOFTWARE,
                     20:  * with or without modification, as permitted hereunder, you shall affix
                     21:  * to all such copies of the SOFTWARE the above copyright notice.
                     22:  * (3) An explicit reference to this SOFTWARE and its copyright owner
                     23:  * shall be made on your publication or presentation in any form of the
                     24:  * results obtained by use of the SOFTWARE.
                     25:  * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.6       noro       26:  * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.5       noro       27:  * for such modification or the source code of the modified part of the
                     28:  * SOFTWARE.
                     29:  *
                     30:  * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
                     31:  * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
                     32:  * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
                     33:  * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
                     34:  * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
                     35:  * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
                     36:  * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
                     37:  * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
                     38:  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
                     39:  * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
                     40:  * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
                     41:  * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
                     42:  * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
                     43:  * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
                     44:  * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
                     45:  * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
                     46:  * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
                     47:  *
1.27    ! noro       48:  * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.26 2003/01/04 09:06:15 noro Exp $
1.5       noro       49: */
1.1       noro       50: #include "ca.h"
                     51: #include "base.h"
                     52: #include "parse.h"
                     53:
1.8       noro       54: extern int dp_nelim;
                     55: extern int dp_order_pair_length;
                     56: extern struct order_pair *dp_order_pair;
                     57: extern struct order_spec dp_current_spec;
                     58:
1.11      noro       59: int do_weyl;
1.1       noro       60:
                     61: void Pdp_ord(), Pdp_ptod(), Pdp_dtop();
                     62: void Pdp_ptozp(), Pdp_ptozp2(), Pdp_red(), Pdp_red2(), Pdp_lcm(), Pdp_redble();
                     63: void Pdp_sp(), Pdp_hm(), Pdp_ht(), Pdp_hc(), Pdp_rest(), Pdp_td(), Pdp_sugar();
                     64: void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv();
                     65: void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat();
1.9       noro       66: void Pdp_nf(),Pdp_true_nf();
1.1       noro       67: void Pdp_nf_mod(),Pdp_true_nf_mod();
                     68: void Pdp_criB(),Pdp_nelim();
1.9       noro       69: void Pdp_minp(),Pdp_sp_mod();
1.1       noro       70: void Pdp_homo(),Pdp_dehomo();
1.16      noro       71: void Pdp_gr_mod_main(),Pdp_gr_f_main();
1.1       noro       72: void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags();
1.16      noro       73: void Pdp_f4_main(),Pdp_f4_mod_main(),Pdp_f4_f_main();
1.1       noro       74: void Pdp_gr_print();
1.8       noro       75: void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_mdtod();
                     76: void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
                     77: void Pdp_cont();
1.22      noro       78: void Pdp_gr_checklist();
1.1       noro       79:
1.13      noro       80: void Pdp_weyl_red();
                     81: void Pdp_weyl_sp();
                     82: void Pdp_weyl_nf(),Pdp_weyl_nf_mod();
1.16      noro       83: void Pdp_weyl_gr_main(),Pdp_weyl_gr_mod_main(),Pdp_weyl_gr_f_main();
                     84: void Pdp_weyl_f4_main(),Pdp_weyl_f4_mod_main(),Pdp_weyl_f4_f_main();
1.13      noro       85: void Pdp_weyl_mul(),Pdp_weyl_mul_mod();
1.15      noro       86: void Pdp_weyl_set_weight();
1.24      noro       87: void Pdp_set_weight();
1.16      noro       88: void Pdp_nf_f(),Pdp_weyl_nf_f();
                     89: void Pdp_lnf_f();
1.11      noro       90:
1.25      noro       91: LIST remove_zero_from_list(LIST);
                     92:
1.1       noro       93: struct ftab dp_tab[] = {
1.8       noro       94:        /* content reduction */
1.1       noro       95:        {"dp_ptozp",Pdp_ptozp,1},
                     96:        {"dp_ptozp2",Pdp_ptozp2,2},
                     97:        {"dp_prim",Pdp_prim,1},
1.8       noro       98:        {"dp_red_coef",Pdp_red_coef,2},
                     99:        {"dp_cont",Pdp_cont,1},
                    100:
1.11      noro      101: /* polynomial ring */
1.8       noro      102:        /* s-poly */
                    103:        {"dp_sp",Pdp_sp,2},
                    104:        {"dp_sp_mod",Pdp_sp_mod,3},
                    105:
                    106:        /* m-reduction */
1.1       noro      107:        {"dp_red",Pdp_red,3},
                    108:        {"dp_red_mod",Pdp_red_mod,4},
1.8       noro      109:
                    110:        /* normal form */
1.1       noro      111:        {"dp_nf",Pdp_nf,4},
1.16      noro      112:        {"dp_nf_f",Pdp_nf_f,4},
1.1       noro      113:        {"dp_true_nf",Pdp_true_nf,4},
                    114:        {"dp_nf_mod",Pdp_nf_mod,5},
                    115:        {"dp_true_nf_mod",Pdp_true_nf_mod,5},
1.8       noro      116:        {"dp_lnf_mod",Pdp_lnf_mod,3},
                    117:        {"dp_nf_tab_mod",Pdp_nf_tab_mod,3},
1.16      noro      118:        {"dp_lnf_f",Pdp_lnf_f,2},
1.8       noro      119:
                    120:        /* Buchberger algorithm */
1.1       noro      121:        {"dp_gr_main",Pdp_gr_main,5},
                    122:        {"dp_gr_mod_main",Pdp_gr_mod_main,5},
1.27    ! noro      123:        {"dp_gr_f_main",Pdp_gr_f_main,4},
1.23      noro      124:        {"dp_gr_checklist",Pdp_gr_checklist,2},
1.8       noro      125:
                    126:        /* F4 algorithm */
1.1       noro      127:        {"dp_f4_main",Pdp_f4_main,3},
                    128:        {"dp_f4_mod_main",Pdp_f4_mod_main,4},
1.8       noro      129:
1.11      noro      130: /* weyl algebra */
1.12      noro      131:        /* multiplication */
                    132:        {"dp_weyl_mul",Pdp_weyl_mul,2},
1.13      noro      133:        {"dp_weyl_mul_mod",Pdp_weyl_mul_mod,3},
1.12      noro      134:
1.11      noro      135:        /* s-poly */
                    136:        {"dp_weyl_sp",Pdp_weyl_sp,2},
                    137:
                    138:        /* m-reduction */
                    139:        {"dp_weyl_red",Pdp_weyl_red,3},
                    140:
                    141:        /* normal form */
                    142:        {"dp_weyl_nf",Pdp_weyl_nf,4},
1.13      noro      143:        {"dp_weyl_nf_mod",Pdp_weyl_nf_mod,5},
1.16      noro      144:        {"dp_weyl_nf_f",Pdp_weyl_nf_f,4},
1.11      noro      145:
                    146:        /* Buchberger algorithm */
                    147:        {"dp_weyl_gr_main",Pdp_weyl_gr_main,5},
                    148:        {"dp_weyl_gr_mod_main",Pdp_weyl_gr_mod_main,5},
1.16      noro      149:        {"dp_weyl_gr_f_main",Pdp_weyl_gr_f_main,4},
1.11      noro      150:
                    151:        /* F4 algorithm */
                    152:        {"dp_weyl_f4_main",Pdp_weyl_f4_main,3},
1.19      noro      153:        {"dp_weyl_f4_mod_main",Pdp_weyl_f4_mod_main,4},
1.11      noro      154:
1.15      noro      155:        /* misc */
1.24      noro      156:        {"dp_set_weight",Pdp_set_weight,-1},
1.15      noro      157:        {"dp_weyl_set_weight",Pdp_weyl_set_weight,-1},
1.8       noro      158:        {0,0,0},
                    159: };
                    160:
                    161: struct ftab dp_supp_tab[] = {
                    162:        /* setting flags */
                    163:        {"dp_ord",Pdp_ord,-1},
                    164:        {"dp_set_kara",Pdp_set_kara,-1},
                    165:        {"dp_nelim",Pdp_nelim,-1},
1.1       noro      166:        {"dp_gr_flags",Pdp_gr_flags,-1},
                    167:        {"dp_gr_print",Pdp_gr_print,-1},
1.8       noro      168:
                    169:        /* converters */
                    170:        {"dp_ptod",Pdp_ptod,2},
                    171:        {"dp_dtop",Pdp_dtop,2},
                    172:        {"dp_homo",Pdp_homo,1},
                    173:        {"dp_dehomo",Pdp_dehomo,1},
                    174:        {"dp_etov",Pdp_etov,1},
                    175:        {"dp_vtoe",Pdp_vtoe,1},
                    176:        {"dp_dtov",Pdp_dtov,1},
                    177:        {"dp_mdtod",Pdp_mdtod,1},
                    178:        {"dp_mod",Pdp_mod,3},
                    179:        {"dp_rat",Pdp_rat,1},
                    180:
                    181:        /* criteria */
                    182:        {"dp_cri1",Pdp_cri1,2},
                    183:        {"dp_cri2",Pdp_cri2,2},
                    184:        {"dp_criB",Pdp_criB,3},
                    185:
                    186:        /* simple operation */
                    187:        {"dp_subd",Pdp_subd,2},
                    188:        {"dp_lcm",Pdp_lcm,2},
                    189:        {"dp_hm",Pdp_hm,1},
                    190:        {"dp_ht",Pdp_ht,1},
                    191:        {"dp_hc",Pdp_hc,1},
                    192:        {"dp_rest",Pdp_rest,1},
                    193:
                    194:        /* degree and size */
                    195:        {"dp_td",Pdp_td,1},
                    196:        {"dp_mag",Pdp_mag,1},
                    197:        {"dp_sugar",Pdp_sugar,1},
                    198:
                    199:        /* misc */
                    200:        {"dp_mbase",Pdp_mbase,1},
                    201:        {"dp_redble",Pdp_redble,2},
                    202:        {"dp_sep",Pdp_sep,2},
                    203:        {"dp_idiv",Pdp_idiv,2},
                    204:        {"dp_tdiv",Pdp_tdiv,2},
                    205:        {"dp_minp",Pdp_minp,2},
                    206:
                    207:        {0,0,0}
1.1       noro      208: };
                    209:
1.8       noro      210: void Pdp_mdtod(arg,rp)
                    211: NODE arg;
                    212: DP *rp;
                    213: {
                    214:        MP m,mr,mr0;
                    215:        DP p;
                    216:        P t;
                    217:
                    218:        p = (DP)ARG0(arg);
                    219:        if ( !p )
                    220:                *rp = 0;
                    221:        else {
                    222:                for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
                    223:                        mptop(m->c,&t); NEXTMP(mr0,mr); mr->c = t; mr->dl = m->dl;
                    224:                }
                    225:                NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
                    226:        }
                    227: }
                    228:
                    229: void Pdp_sep(arg,rp)
                    230: NODE arg;
                    231: VECT *rp;
                    232: {
                    233:        DP p,r;
                    234:        MP m,t;
                    235:        MP *w0,*w;
                    236:        int i,n,d,nv,sugar;
                    237:        VECT v;
                    238:        pointer *pv;
                    239:
                    240:        p = (DP)ARG0(arg); m = BDY(p);
                    241:        d = QTOS((Q)ARG1(arg));
                    242:        for ( t = m, n = 0; t; t = NEXT(t), n++ );
                    243:        if ( d > n )
                    244:                d = n;
                    245:        MKVECT(v,d); *rp = v;
                    246:        pv = BDY(v); nv = p->nv; sugar = p->sugar;
                    247:        w0 = (MP *)MALLOC(d*sizeof(MP)); bzero(w0,d*sizeof(MP));
                    248:        w = (MP *)MALLOC(d*sizeof(MP)); bzero(w,d*sizeof(MP));
                    249:        for ( t = BDY(p), i = 0; t; t = NEXT(t), i++, i %= d  ) {
                    250:                NEXTMP(w0[i],w[i]); w[i]->c = t->c; w[i]->dl = t->dl;
                    251:        }
                    252:        for ( i = 0; i < d; i++ ) {
                    253:                NEXT(w[i]) = 0; MKDP(nv,w0[i],r); r->sugar = sugar;
                    254:                pv[i] = (pointer)r;
                    255:        }
                    256: }
                    257:
                    258: void Pdp_idiv(arg,rp)
                    259: NODE arg;
                    260: DP *rp;
                    261: {
                    262:        dp_idiv((DP)ARG0(arg),(Q)ARG1(arg),rp);
                    263: }
                    264:
                    265: void Pdp_cont(arg,rp)
                    266: NODE arg;
                    267: Q *rp;
                    268: {
                    269:        dp_cont((DP)ARG0(arg),rp);
                    270: }
                    271:
                    272: void Pdp_dtov(arg,rp)
                    273: NODE arg;
                    274: VECT *rp;
                    275: {
                    276:        dp_dtov((DP)ARG0(arg),rp);
                    277: }
                    278:
                    279: void Pdp_mbase(arg,rp)
                    280: NODE arg;
                    281: LIST *rp;
                    282: {
                    283:        NODE mb;
                    284:
                    285:        asir_assert(ARG0(arg),O_LIST,"dp_mbase");
                    286:        dp_mbase(BDY((LIST)ARG0(arg)),&mb);
                    287:        MKLIST(*rp,mb);
                    288: }
                    289:
                    290: void Pdp_etov(arg,rp)
                    291: NODE arg;
                    292: VECT *rp;
                    293: {
                    294:        DP dp;
                    295:        int n,i;
                    296:        int *d;
                    297:        VECT v;
                    298:        Q t;
                    299:
                    300:        dp = (DP)ARG0(arg);
                    301:        asir_assert(dp,O_DP,"dp_etov");
                    302:        n = dp->nv; d = BDY(dp)->dl->d;
                    303:        MKVECT(v,n);
                    304:        for ( i = 0; i < n; i++ ) {
                    305:                STOQ(d[i],t); v->body[i] = (pointer)t;
                    306:        }
                    307:        *rp = v;
                    308: }
                    309:
                    310: void Pdp_vtoe(arg,rp)
                    311: NODE arg;
                    312: DP *rp;
                    313: {
                    314:        DP dp;
                    315:        DL dl;
                    316:        MP m;
                    317:        int n,i,td;
                    318:        int *d;
                    319:        VECT v;
                    320:
                    321:        v = (VECT)ARG0(arg);
                    322:        asir_assert(v,O_VECT,"dp_vtoe");
                    323:        n = v->len;
                    324:        NEWDL(dl,n); d = dl->d;
                    325:        for ( i = 0, td = 0; i < n; i++ ) {
1.24      noro      326:                d[i] = QTOS((Q)(v->body[i])); td += MUL_WEIGHT(d[i],i);
1.8       noro      327:        }
                    328:        dl->td = td;
                    329:        NEWMP(m); m->dl = dl; m->c = (P)ONE; NEXT(m) = 0;
                    330:        MKDP(n,m,dp); dp->sugar = td;
                    331:        *rp = dp;
                    332: }
                    333:
                    334: void Pdp_lnf_mod(arg,rp)
                    335: NODE arg;
                    336: LIST *rp;
                    337: {
                    338:        DP r1,r2;
                    339:        NODE b,g,n;
                    340:        int mod;
                    341:
                    342:        asir_assert(ARG0(arg),O_LIST,"dp_lnf_mod");
                    343:        asir_assert(ARG1(arg),O_LIST,"dp_lnf_mod");
                    344:        asir_assert(ARG2(arg),O_N,"dp_lnf_mod");
                    345:        b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
                    346:        mod = QTOS((Q)ARG2(arg));
                    347:        dp_lnf_mod((DP)BDY(b),(DP)BDY(NEXT(b)),g,mod,&r1,&r2);
                    348:        NEWNODE(n); BDY(n) = (pointer)r1;
                    349:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
                    350:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
                    351: }
                    352:
1.16      noro      353: void Pdp_lnf_f(arg,rp)
                    354: NODE arg;
                    355: LIST *rp;
                    356: {
                    357:        DP r1,r2;
                    358:        NODE b,g,n;
                    359:
                    360:        asir_assert(ARG0(arg),O_LIST,"dp_lnf_f");
                    361:        asir_assert(ARG1(arg),O_LIST,"dp_lnf_f");
                    362:        b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
                    363:        dp_lnf_f((DP)BDY(b),(DP)BDY(NEXT(b)),g,&r1,&r2);
                    364:        NEWNODE(n); BDY(n) = (pointer)r1;
                    365:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
                    366:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
                    367: }
                    368:
1.8       noro      369: void Pdp_nf_tab_mod(arg,rp)
                    370: NODE arg;
                    371: DP *rp;
                    372: {
                    373:        asir_assert(ARG0(arg),O_DP,"dp_nf_tab_mod");
                    374:        asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_mod");
                    375:        asir_assert(ARG2(arg),O_N,"dp_nf_tab_mod");
                    376:        dp_nf_tab_mod((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),
                    377:                QTOS((Q)ARG2(arg)),rp);
                    378: }
1.1       noro      379:
                    380: void Pdp_ord(arg,rp)
                    381: NODE arg;
                    382: Obj *rp;
                    383: {
                    384:        struct order_spec spec;
                    385:
                    386:        if ( !arg )
                    387:                *rp = dp_current_spec.obj;
                    388:        else if ( !create_order_spec((Obj)ARG0(arg),&spec) )
                    389:                error("dp_ord : invalid order specification");
                    390:        else {
                    391:                initd(&spec); *rp = spec.obj;
                    392:        }
                    393: }
                    394:
                    395: void Pdp_ptod(arg,rp)
                    396: NODE arg;
                    397: DP *rp;
                    398: {
                    399:        NODE n;
                    400:        VL vl,tvl;
                    401:
                    402:        asir_assert(ARG0(arg),O_P,"dp_ptod");
                    403:        asir_assert(ARG1(arg),O_LIST,"dp_ptod");
                    404:        for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
                    405:                if ( !vl ) {
                    406:                        NEWVL(vl); tvl = vl;
                    407:                } else {
                    408:                        NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
                    409:                }
                    410:                VR(tvl) = VR((P)BDY(n));
                    411:        }
                    412:        if ( vl )
                    413:                NEXT(tvl) = 0;
                    414:        ptod(CO,vl,(P)ARG0(arg),rp);
                    415: }
                    416:
                    417: void Pdp_dtop(arg,rp)
                    418: NODE arg;
                    419: P *rp;
                    420: {
                    421:        NODE n;
                    422:        VL vl,tvl;
                    423:
                    424:        asir_assert(ARG0(arg),O_DP,"dp_dtop");
                    425:        asir_assert(ARG1(arg),O_LIST,"dp_dtop");
                    426:        for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
                    427:                if ( !vl ) {
                    428:                        NEWVL(vl); tvl = vl;
                    429:                } else {
                    430:                        NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
                    431:                }
                    432:                VR(tvl) = VR((P)BDY(n));
                    433:        }
                    434:        if ( vl )
                    435:                NEXT(tvl) = 0;
                    436:        dtop(CO,vl,(DP)ARG0(arg),rp);
                    437: }
                    438:
                    439: extern LIST Dist;
                    440:
                    441: void Pdp_ptozp(arg,rp)
                    442: NODE arg;
                    443: DP *rp;
                    444: {
                    445:        asir_assert(ARG0(arg),O_DP,"dp_ptozp");
1.10      noro      446:        dp_ptozp((DP)ARG0(arg),rp);
1.1       noro      447: }
                    448:
                    449: void Pdp_ptozp2(arg,rp)
                    450: NODE arg;
                    451: LIST *rp;
                    452: {
                    453:        DP p0,p1,h,r;
                    454:        NODE n0;
                    455:
                    456:        p0 = (DP)ARG0(arg); p1 = (DP)ARG1(arg);
                    457:        asir_assert(p0,O_DP,"dp_ptozp2");
                    458:        asir_assert(p1,O_DP,"dp_ptozp2");
1.10      noro      459:        dp_ptozp2(p0,p1,&h,&r);
1.1       noro      460:        NEWNODE(n0); BDY(n0) = (pointer)h;
                    461:        NEWNODE(NEXT(n0)); BDY(NEXT(n0)) = (pointer)r;
                    462:        NEXT(NEXT(n0)) = 0;
                    463:        MKLIST(*rp,n0);
                    464: }
                    465:
                    466: void Pdp_prim(arg,rp)
                    467: NODE arg;
                    468: DP *rp;
                    469: {
                    470:        DP t;
                    471:
                    472:        asir_assert(ARG0(arg),O_DP,"dp_prim");
                    473:        dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
                    474: }
                    475:
                    476: void Pdp_mod(arg,rp)
                    477: NODE arg;
                    478: DP *rp;
                    479: {
                    480:        DP p;
                    481:        int mod;
                    482:        NODE subst;
                    483:
                    484:        asir_assert(ARG0(arg),O_DP,"dp_mod");
                    485:        asir_assert(ARG1(arg),O_N,"dp_mod");
                    486:        asir_assert(ARG2(arg),O_LIST,"dp_mod");
                    487:        p = (DP)ARG0(arg); mod = QTOS((Q)ARG1(arg));
                    488:        subst = BDY((LIST)ARG2(arg));
                    489:        dp_mod(p,mod,subst,rp);
                    490: }
                    491:
                    492: void Pdp_rat(arg,rp)
                    493: NODE arg;
                    494: DP *rp;
                    495: {
                    496:        asir_assert(ARG0(arg),O_DP,"dp_rat");
                    497:        dp_rat((DP)ARG0(arg),rp);
                    498: }
                    499:
1.9       noro      500: extern int DP_Multiple;
                    501:
1.1       noro      502: void Pdp_nf(arg,rp)
                    503: NODE arg;
                    504: DP *rp;
                    505: {
                    506:        NODE b;
                    507:        DP *ps;
                    508:        DP g;
                    509:        int full;
                    510:
1.11      noro      511:        do_weyl = 0;
1.1       noro      512:        asir_assert(ARG0(arg),O_LIST,"dp_nf");
                    513:        asir_assert(ARG1(arg),O_DP,"dp_nf");
                    514:        asir_assert(ARG2(arg),O_VECT,"dp_nf");
                    515:        asir_assert(ARG3(arg),O_N,"dp_nf");
                    516:        if ( !(g = (DP)ARG1(arg)) ) {
                    517:                *rp = 0; return;
                    518:        }
                    519:        b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    520:        full = (Q)ARG3(arg) ? 1 : 0;
1.16      noro      521:        dp_nf_z(b,g,ps,full,DP_Multiple,rp);
1.1       noro      522: }
                    523:
1.11      noro      524: void Pdp_weyl_nf(arg,rp)
                    525: NODE arg;
                    526: DP *rp;
                    527: {
                    528:        NODE b;
                    529:        DP *ps;
                    530:        DP g;
                    531:        int full;
                    532:
                    533:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf");
                    534:        asir_assert(ARG1(arg),O_DP,"dp_weyl_nf");
                    535:        asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf");
                    536:        asir_assert(ARG3(arg),O_N,"dp_weyl_nf");
                    537:        if ( !(g = (DP)ARG1(arg)) ) {
                    538:                *rp = 0; return;
                    539:        }
                    540:        b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    541:        full = (Q)ARG3(arg) ? 1 : 0;
1.12      noro      542:        do_weyl = 1;
1.16      noro      543:        dp_nf_z(b,g,ps,full,DP_Multiple,rp);
                    544:        do_weyl = 0;
                    545: }
                    546:
                    547: /* nf computation using field operations */
                    548:
                    549: void Pdp_nf_f(arg,rp)
                    550: NODE arg;
                    551: DP *rp;
                    552: {
                    553:        NODE b;
                    554:        DP *ps;
                    555:        DP g;
                    556:        int full;
                    557:
                    558:        do_weyl = 0;
                    559:        asir_assert(ARG0(arg),O_LIST,"dp_nf_f");
                    560:        asir_assert(ARG1(arg),O_DP,"dp_nf_f");
                    561:        asir_assert(ARG2(arg),O_VECT,"dp_nf_f");
                    562:        asir_assert(ARG3(arg),O_N,"dp_nf_f");
                    563:        if ( !(g = (DP)ARG1(arg)) ) {
                    564:                *rp = 0; return;
                    565:        }
                    566:        b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    567:        full = (Q)ARG3(arg) ? 1 : 0;
                    568:        dp_nf_f(b,g,ps,full,rp);
                    569: }
                    570:
                    571: void Pdp_weyl_nf_f(arg,rp)
                    572: NODE arg;
                    573: DP *rp;
                    574: {
                    575:        NODE b;
                    576:        DP *ps;
                    577:        DP g;
                    578:        int full;
                    579:
                    580:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_f");
                    581:        asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_f");
                    582:        asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_f");
                    583:        asir_assert(ARG3(arg),O_N,"dp_weyl_nf_f");
                    584:        if ( !(g = (DP)ARG1(arg)) ) {
                    585:                *rp = 0; return;
                    586:        }
                    587:        b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    588:        full = (Q)ARG3(arg) ? 1 : 0;
                    589:        do_weyl = 1;
                    590:        dp_nf_f(b,g,ps,full,rp);
1.12      noro      591:        do_weyl = 0;
1.11      noro      592: }
                    593:
1.13      noro      594: void Pdp_nf_mod(arg,rp)
                    595: NODE arg;
                    596: DP *rp;
                    597: {
                    598:        NODE b;
                    599:        DP g;
                    600:        DP *ps;
                    601:        int mod,full,ac;
                    602:        NODE n,n0;
                    603:
1.14      noro      604:        do_weyl = 0;
1.13      noro      605:        ac = argc(arg);
1.14      noro      606:        asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
                    607:        asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
                    608:        asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
                    609:        asir_assert(ARG3(arg),O_N,"dp_nf_mod");
                    610:        asir_assert(ARG4(arg),O_N,"dp_nf_mod");
1.13      noro      611:        if ( !(g = (DP)ARG1(arg)) ) {
                    612:                *rp = 0; return;
                    613:        }
                    614:        b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    615:        full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
                    616:        for ( n0 = n = 0; b; b = NEXT(b) ) {
                    617:                NEXTNODE(n0,n);
                    618:                BDY(n) = (pointer)QTOS((Q)BDY(b));
                    619:        }
                    620:        if ( n0 )
                    621:                NEXT(n) = 0;
                    622:        dp_nf_mod(n0,g,ps,mod,full,rp);
                    623: }
                    624:
1.1       noro      625: void Pdp_true_nf(arg,rp)
                    626: NODE arg;
                    627: LIST *rp;
                    628: {
                    629:        NODE b,n;
                    630:        DP *ps;
                    631:        DP g;
                    632:        DP nm;
                    633:        P dn;
                    634:        int full;
                    635:
1.11      noro      636:        do_weyl = 0;
1.1       noro      637:        asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
                    638:        asir_assert(ARG1(arg),O_DP,"dp_true_nf");
                    639:        asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
                    640:        asir_assert(ARG3(arg),O_N,"dp_nf");
                    641:        if ( !(g = (DP)ARG1(arg)) ) {
                    642:                nm = 0; dn = (P)ONE;
                    643:        } else {
                    644:                b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    645:                full = (Q)ARG3(arg) ? 1 : 0;
                    646:                dp_true_nf(b,g,ps,full,&nm,&dn);
                    647:        }
                    648:        NEWNODE(n); BDY(n) = (pointer)nm;
                    649:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
                    650:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
                    651: }
                    652:
1.13      noro      653: void Pdp_weyl_nf_mod(arg,rp)
1.8       noro      654: NODE arg;
                    655: DP *rp;
                    656: {
                    657:        NODE b;
                    658:        DP g;
                    659:        DP *ps;
                    660:        int mod,full,ac;
1.9       noro      661:        NODE n,n0;
1.8       noro      662:
                    663:        ac = argc(arg);
1.14      noro      664:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_mod");
                    665:        asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_mod");
                    666:        asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_mod");
                    667:        asir_assert(ARG3(arg),O_N,"dp_weyl_nf_mod");
                    668:        asir_assert(ARG4(arg),O_N,"dp_weyl_nf_mod");
1.8       noro      669:        if ( !(g = (DP)ARG1(arg)) ) {
                    670:                *rp = 0; return;
                    671:        }
                    672:        b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    673:        full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
1.9       noro      674:        for ( n0 = n = 0; b; b = NEXT(b) ) {
                    675:                NEXTNODE(n0,n);
                    676:                BDY(n) = (pointer)QTOS((Q)BDY(b));
                    677:        }
                    678:        if ( n0 )
                    679:                NEXT(n) = 0;
1.13      noro      680:        do_weyl = 1;
                    681:        dp_nf_mod(n0,g,ps,mod,full,rp);
                    682:        do_weyl = 0;
1.8       noro      683: }
                    684:
                    685: void Pdp_true_nf_mod(arg,rp)
                    686: NODE arg;
                    687: LIST *rp;
                    688: {
                    689:        NODE b;
                    690:        DP g,nm;
                    691:        P dn;
                    692:        DP *ps;
                    693:        int mod,full;
                    694:        NODE n;
                    695:
1.11      noro      696:        do_weyl = 0;
1.8       noro      697:        asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
                    698:        asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
                    699:        asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
                    700:        asir_assert(ARG3(arg),O_N,"dp_nf_mod");
                    701:        asir_assert(ARG4(arg),O_N,"dp_nf_mod");
                    702:        if ( !(g = (DP)ARG1(arg)) ) {
                    703:                nm = 0; dn = (P)ONEM;
                    704:        } else {
                    705:                b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
                    706:                full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
                    707:                dp_true_nf_mod(b,g,ps,mod,full,&nm,&dn);
                    708:        }
                    709:        NEWNODE(n); BDY(n) = (pointer)nm;
                    710:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
                    711:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.1       noro      712: }
                    713:
                    714: void Pdp_tdiv(arg,rp)
                    715: NODE arg;
                    716: DP *rp;
                    717: {
                    718:        MP m,mr,mr0;
                    719:        DP p;
                    720:        Q c;
                    721:        N d,q,r;
                    722:        int sgn;
                    723:
                    724:        asir_assert(ARG0(arg),O_DP,"dp_tdiv");
                    725:        asir_assert(ARG1(arg),O_N,"dp_tdiv");
                    726:        p = (DP)ARG0(arg); d = NM((Q)ARG1(arg)); sgn = SGN((Q)ARG1(arg));
                    727:        if ( !p )
                    728:                *rp = 0;
                    729:        else {
                    730:                for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
                    731:                        divn(NM((Q)m->c),d,&q,&r);
                    732:                        if ( r ) {
                    733:                                *rp = 0; return;
                    734:                        } else {
                    735:                                NEXTMP(mr0,mr); NTOQ(q,SGN((Q)m->c)*sgn,c);
                    736:                                mr->c = (P)c; mr->dl = m->dl;
                    737:                        }
                    738:                }
                    739:                NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
                    740:        }
                    741: }
                    742:
                    743: void Pdp_red_coef(arg,rp)
                    744: NODE arg;
                    745: DP *rp;
                    746: {
                    747:        MP m,mr,mr0;
                    748:        P q,r;
                    749:        DP p;
                    750:        P mod;
                    751:
                    752:        p = (DP)ARG0(arg); mod = (P)ARG1(arg);
                    753:        asir_assert(p,O_DP,"dp_red_coef");
                    754:        asir_assert(mod,O_P,"dp_red_coef");
                    755:        if ( !p )
                    756:                *rp = 0;
                    757:        else {
                    758:                for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
                    759:                        divsrp(CO,m->c,mod,&q,&r);
                    760:                        if ( r ) {
                    761:                                NEXTMP(mr0,mr); mr->c = r; mr->dl = m->dl;
                    762:                        }
                    763:                }
                    764:                if ( mr0 ) {
                    765:                        NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
                    766:                } else
                    767:                        *rp = 0;
                    768:        }
                    769: }
                    770:
                    771: void Pdp_redble(arg,rp)
                    772: NODE arg;
                    773: Q *rp;
                    774: {
                    775:        asir_assert(ARG0(arg),O_DP,"dp_redble");
                    776:        asir_assert(ARG1(arg),O_DP,"dp_redble");
                    777:        if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
                    778:                *rp = ONE;
                    779:        else
                    780:                *rp = 0;
                    781: }
                    782:
                    783: void Pdp_red_mod(arg,rp)
                    784: NODE arg;
                    785: LIST *rp;
                    786: {
                    787:        DP h,r;
                    788:        P dmy;
                    789:        NODE n;
                    790:
1.11      noro      791:        do_weyl = 0;
1.1       noro      792:        asir_assert(ARG0(arg),O_DP,"dp_red_mod");
                    793:        asir_assert(ARG1(arg),O_DP,"dp_red_mod");
                    794:        asir_assert(ARG2(arg),O_DP,"dp_red_mod");
                    795:        asir_assert(ARG3(arg),O_N,"dp_red_mod");
                    796:        dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),QTOS((Q)ARG3(arg)),
                    797:                &h,&r,&dmy);
                    798:        NEWNODE(n); BDY(n) = (pointer)h;
                    799:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
                    800:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
                    801: }
1.13      noro      802:
1.1       noro      803: void Pdp_subd(arg,rp)
                    804: NODE arg;
                    805: DP *rp;
                    806: {
                    807:        DP p1,p2;
                    808:
                    809:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                    810:        asir_assert(p1,O_DP,"dp_subd");
                    811:        asir_assert(p2,O_DP,"dp_subd");
                    812:        dp_subd(p1,p2,rp);
                    813: }
                    814:
1.12      noro      815: void Pdp_weyl_mul(arg,rp)
                    816: NODE arg;
                    817: DP *rp;
                    818: {
                    819:        DP p1,p2;
                    820:
                    821:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                    822:        asir_assert(p1,O_DP,"dp_weyl_mul"); asir_assert(p2,O_DP,"dp_mul");
                    823:        do_weyl = 1;
                    824:        muld(CO,p1,p2,rp);
1.13      noro      825:        do_weyl = 0;
                    826: }
                    827:
                    828: void Pdp_weyl_mul_mod(arg,rp)
                    829: NODE arg;
                    830: DP *rp;
                    831: {
                    832:        DP p1,p2;
                    833:        Q m;
                    834:
                    835:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); m = (Q)ARG2(arg);
                    836:        asir_assert(p1,O_DP,"dp_weyl_mul_mod");
                    837:        asir_assert(p2,O_DP,"dp_mul_mod");
                    838:        asir_assert(m,O_N,"dp_mul_mod");
                    839:        do_weyl = 1;
                    840:        mulmd(CO,QTOS(m),p1,p2,rp);
1.12      noro      841:        do_weyl = 0;
                    842: }
                    843:
1.1       noro      844: void Pdp_red(arg,rp)
                    845: NODE arg;
                    846: LIST *rp;
                    847: {
                    848:        NODE n;
1.4       noro      849:        DP head,rest,dmy1;
1.1       noro      850:        P dmy;
                    851:
1.11      noro      852:        do_weyl = 0;
1.1       noro      853:        asir_assert(ARG0(arg),O_DP,"dp_red");
                    854:        asir_assert(ARG1(arg),O_DP,"dp_red");
                    855:        asir_assert(ARG2(arg),O_DP,"dp_red");
1.4       noro      856:        dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.1       noro      857:        NEWNODE(n); BDY(n) = (pointer)head;
                    858:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
                    859:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
                    860: }
                    861:
1.11      noro      862: void Pdp_weyl_red(arg,rp)
                    863: NODE arg;
                    864: LIST *rp;
                    865: {
                    866:        NODE n;
                    867:        DP head,rest,dmy1;
                    868:        P dmy;
                    869:
                    870:        asir_assert(ARG0(arg),O_DP,"dp_weyl_red");
                    871:        asir_assert(ARG1(arg),O_DP,"dp_weyl_red");
                    872:        asir_assert(ARG2(arg),O_DP,"dp_weyl_red");
1.12      noro      873:        do_weyl = 1;
1.11      noro      874:        dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.12      noro      875:        do_weyl = 0;
1.11      noro      876:        NEWNODE(n); BDY(n) = (pointer)head;
                    877:        NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
                    878:        NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
                    879: }
                    880:
1.1       noro      881: void Pdp_sp(arg,rp)
                    882: NODE arg;
                    883: DP *rp;
                    884: {
                    885:        DP p1,p2;
                    886:
1.11      noro      887:        do_weyl = 0;
1.1       noro      888:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                    889:        asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
                    890:        dp_sp(p1,p2,rp);
                    891: }
                    892:
1.11      noro      893: void Pdp_weyl_sp(arg,rp)
                    894: NODE arg;
                    895: DP *rp;
                    896: {
                    897:        DP p1,p2;
                    898:
                    899:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                    900:        asir_assert(p1,O_DP,"dp_weyl_sp"); asir_assert(p2,O_DP,"dp_sp");
1.12      noro      901:        do_weyl = 1;
1.11      noro      902:        dp_sp(p1,p2,rp);
1.12      noro      903:        do_weyl = 0;
1.11      noro      904: }
                    905:
1.1       noro      906: void Pdp_sp_mod(arg,rp)
                    907: NODE arg;
                    908: DP *rp;
                    909: {
                    910:        DP p1,p2;
                    911:        int mod;
                    912:
1.11      noro      913:        do_weyl = 0;
1.1       noro      914:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                    915:        asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
                    916:        asir_assert(ARG2(arg),O_N,"dp_sp_mod");
                    917:        mod = QTOS((Q)ARG2(arg));
                    918:        dp_sp_mod(p1,p2,mod,rp);
                    919: }
                    920:
                    921: void Pdp_lcm(arg,rp)
                    922: NODE arg;
                    923: DP *rp;
                    924: {
                    925:        int i,n,td;
                    926:        DL d1,d2,d;
                    927:        MP m;
                    928:        DP p1,p2;
                    929:
                    930:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                    931:        asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
                    932:        n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
                    933:        NEWDL(d,n);
                    934:        for ( i = 0, td = 0; i < n; i++ ) {
1.24      noro      935:                d->d[i] = MAX(d1->d[i],d2->d[i]); td += MUL_WEIGHT(d->d[i],i);
1.1       noro      936:        }
                    937:        d->td = td;
                    938:        NEWMP(m); m->dl = d; m->c = (P)ONE; NEXT(m) = 0;
                    939:        MKDP(n,m,*rp); (*rp)->sugar = td;       /* XXX */
                    940: }
                    941:
                    942: void Pdp_hm(arg,rp)
                    943: NODE arg;
                    944: DP *rp;
                    945: {
                    946:        DP p;
                    947:
                    948:        p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
                    949:        dp_hm(p,rp);
                    950: }
                    951:
                    952: void Pdp_ht(arg,rp)
                    953: NODE arg;
                    954: DP *rp;
                    955: {
                    956:        DP p;
                    957:        MP m,mr;
                    958:
                    959:        p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
                    960:        if ( !p )
                    961:                *rp = 0;
                    962:        else {
                    963:                m = BDY(p);
                    964:                NEWMP(mr); mr->dl = m->dl; mr->c = (P)ONE; NEXT(mr) = 0;
                    965:                MKDP(p->nv,mr,*rp); (*rp)->sugar = mr->dl->td;  /* XXX */
                    966:        }
                    967: }
                    968:
                    969: void Pdp_hc(arg,rp)
                    970: NODE arg;
                    971: P *rp;
                    972: {
                    973:        asir_assert(ARG0(arg),O_DP,"dp_hc");
                    974:        if ( !ARG0(arg) )
                    975:                *rp = 0;
                    976:        else
                    977:                *rp = BDY((DP)ARG0(arg))->c;
                    978: }
                    979:
                    980: void Pdp_rest(arg,rp)
                    981: NODE arg;
                    982: DP *rp;
                    983: {
                    984:        asir_assert(ARG0(arg),O_DP,"dp_rest");
                    985:        if ( !ARG0(arg) )
                    986:                *rp = 0;
                    987:        else
                    988:                dp_rest((DP)ARG0(arg),rp);
                    989: }
                    990:
                    991: void Pdp_td(arg,rp)
                    992: NODE arg;
                    993: Q *rp;
                    994: {
                    995:        DP p;
                    996:
                    997:        p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
                    998:        if ( !p )
                    999:                *rp = 0;
                   1000:        else
                   1001:                STOQ(BDY(p)->dl->td,*rp);
                   1002: }
                   1003:
                   1004: void Pdp_sugar(arg,rp)
                   1005: NODE arg;
                   1006: Q *rp;
                   1007: {
                   1008:        DP p;
                   1009:
                   1010:        p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
                   1011:        if ( !p )
                   1012:                *rp = 0;
                   1013:        else
                   1014:                STOQ(p->sugar,*rp);
                   1015: }
                   1016:
                   1017: void Pdp_cri1(arg,rp)
                   1018: NODE arg;
                   1019: Q *rp;
                   1020: {
                   1021:        DP p1,p2;
                   1022:        int *d1,*d2;
                   1023:        int i,n;
                   1024:
                   1025:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                   1026:        asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
                   1027:        n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
                   1028:        for ( i = 0; i < n; i++ )
                   1029:                if ( d1[i] > d2[i] )
                   1030:                        break;
                   1031:        *rp = i == n ? ONE : 0;
                   1032: }
                   1033:
                   1034: void Pdp_cri2(arg,rp)
                   1035: NODE arg;
                   1036: Q *rp;
                   1037: {
                   1038:        DP p1,p2;
                   1039:        int *d1,*d2;
                   1040:        int i,n;
                   1041:
                   1042:        p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
                   1043:        asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
                   1044:        n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
                   1045:        for ( i = 0; i < n; i++ )
                   1046:                if ( MIN(d1[i],d2[i]) >= 1 )
                   1047:                        break;
                   1048:        *rp = i == n ? ONE : 0;
                   1049: }
                   1050:
                   1051: void Pdp_minp(arg,rp)
                   1052: NODE arg;
                   1053: LIST *rp;
                   1054: {
                   1055:        NODE tn,tn1,d,dd,dd0,p,tp;
                   1056:        LIST l,minp;
                   1057:        DP lcm,tlcm;
                   1058:        int s,ts;
                   1059:
                   1060:        asir_assert(ARG0(arg),O_LIST,"dp_minp");
                   1061:        d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
                   1062:        p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
                   1063:        if ( !ARG1(arg) ) {
                   1064:                s = QTOS((Q)BDY(p)); p = NEXT(p);
                   1065:                for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
                   1066:                        tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
                   1067:                        tlcm = (DP)BDY(tp); tp = NEXT(tp);
                   1068:                        ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
                   1069:                        NEXTNODE(dd0,dd);
                   1070:                        if ( ts < s ) {
                   1071:                                BDY(dd) = (pointer)minp;
                   1072:                                minp = (LIST)BDY(d); lcm = tlcm; s = ts;
                   1073:                        } else if ( ts == s ) {
                   1074:                                if ( compd(CO,lcm,tlcm) > 0 ) {
                   1075:                                        BDY(dd) = (pointer)minp;
                   1076:                                        minp = (LIST)BDY(d); lcm = tlcm; s = ts;
                   1077:                                } else
                   1078:                                        BDY(dd) = BDY(d);
                   1079:                        } else
                   1080:                                BDY(dd) = BDY(d);
                   1081:                }
                   1082:        } else {
                   1083:                for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
                   1084:                        tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
                   1085:                        tlcm = (DP)BDY(tp);
                   1086:                        NEXTNODE(dd0,dd);
                   1087:                        if ( compd(CO,lcm,tlcm) > 0 ) {
                   1088:                                BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
                   1089:                        } else
                   1090:                                BDY(dd) = BDY(d);
                   1091:                }
                   1092:        }
                   1093:        if ( dd0 )
                   1094:                NEXT(dd) = 0;
                   1095:        MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
                   1096: }
                   1097:
                   1098: void Pdp_criB(arg,rp)
                   1099: NODE arg;
                   1100: LIST *rp;
                   1101: {
                   1102:        NODE d,ij,dd,ddd;
                   1103:        int i,j,s,n;
                   1104:        DP *ps;
                   1105:        DL ts,ti,tj,lij,tdl;
                   1106:
                   1107:        asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
                   1108:        asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
                   1109:        asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
                   1110:        if ( !d )
                   1111:                *rp = (LIST)ARG0(arg);
                   1112:        else {
                   1113:                ts = BDY(ps[s])->dl;
                   1114:                n = ps[s]->nv;
                   1115:                NEWDL(tdl,n);
                   1116:                for ( dd = 0; d; d = NEXT(d) ) {
                   1117:                        ij = BDY((LIST)BDY(d));
                   1118:                        i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
                   1119:                        j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
                   1120:                        lij = BDY((DP)BDY(ij))->dl;
                   1121:                        ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
                   1122:                        if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
                   1123:                                || !dl_equal(n,lij,tdl)
                   1124:                                || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
                   1125:                                        && dl_equal(n,tdl,lij))
                   1126:                                || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
                   1127:                                        && dl_equal(n,tdl,lij)) ) {
                   1128:                                MKNODE(ddd,BDY(d),dd);
                   1129:                                dd = ddd;
                   1130:                        }
                   1131:                }
                   1132:                MKLIST(*rp,dd);
                   1133:        }
                   1134: }
                   1135:
                   1136: void Pdp_nelim(arg,rp)
                   1137: NODE arg;
                   1138: Q *rp;
                   1139: {
                   1140:        if ( arg ) {
                   1141:                asir_assert(ARG0(arg),O_N,"dp_nelim");
                   1142:                dp_nelim = QTOS((Q)ARG0(arg));
                   1143:        }
                   1144:        STOQ(dp_nelim,*rp);
                   1145: }
                   1146:
                   1147: void Pdp_mag(arg,rp)
                   1148: NODE arg;
                   1149: Q *rp;
                   1150: {
                   1151:        DP p;
                   1152:        int s;
                   1153:        MP m;
                   1154:
                   1155:        p = (DP)ARG0(arg);
                   1156:        asir_assert(p,O_DP,"dp_mag");
                   1157:        if ( !p )
                   1158:                *rp = 0;
                   1159:        else {
                   1160:                for ( s = 0, m = BDY(p); m; m = NEXT(m) )
                   1161:                        s += p_mag(m->c);
                   1162:                STOQ(s,*rp);
                   1163:        }
                   1164: }
                   1165:
                   1166: extern int kara_mag;
                   1167:
                   1168: void Pdp_set_kara(arg,rp)
                   1169: NODE arg;
                   1170: Q *rp;
                   1171: {
                   1172:        if ( arg ) {
                   1173:                asir_assert(ARG0(arg),O_N,"dp_set_kara");
                   1174:                kara_mag = QTOS((Q)ARG0(arg));
                   1175:        }
                   1176:        STOQ(kara_mag,*rp);
                   1177: }
                   1178:
                   1179: void Pdp_homo(arg,rp)
                   1180: NODE arg;
                   1181: DP *rp;
                   1182: {
                   1183:        asir_assert(ARG0(arg),O_DP,"dp_homo");
                   1184:        dp_homo((DP)ARG0(arg),rp);
                   1185: }
                   1186:
1.8       noro     1187: void Pdp_dehomo(arg,rp)
                   1188: NODE arg;
1.1       noro     1189: DP *rp;
                   1190: {
1.8       noro     1191:        asir_assert(ARG0(arg),O_DP,"dp_dehomo");
                   1192:        dp_dehomo((DP)ARG0(arg),rp);
                   1193: }
                   1194:
                   1195: void Pdp_gr_flags(arg,rp)
                   1196: NODE arg;
                   1197: LIST *rp;
                   1198: {
                   1199:        Obj name,value;
                   1200:        NODE n;
1.1       noro     1201:
1.8       noro     1202:        if ( arg ) {
                   1203:                asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
                   1204:                n = BDY((LIST)ARG0(arg));
                   1205:                while ( n ) {
                   1206:                        name = (Obj)BDY(n); n = NEXT(n);
                   1207:                        if ( !n )
                   1208:                                break;
                   1209:                        else {
                   1210:                                value = (Obj)BDY(n); n = NEXT(n);
                   1211:                        }
                   1212:                        dp_set_flag(name,value);
1.1       noro     1213:                }
                   1214:        }
1.8       noro     1215:        dp_make_flaglist(rp);
                   1216: }
                   1217:
                   1218: extern int DP_Print;
                   1219:
                   1220: void Pdp_gr_print(arg,rp)
                   1221: NODE arg;
                   1222: Q *rp;
                   1223: {
                   1224:        Q q;
                   1225:
                   1226:        if ( arg ) {
                   1227:                asir_assert(ARG0(arg),O_N,"dp_gr_print");
                   1228:                q = (Q)ARG0(arg); DP_Print = QTOS(q);
                   1229:        } else
                   1230:                STOQ(DP_Print,q);
                   1231:        *rp = q;
1.1       noro     1232: }
                   1233:
1.8       noro     1234: void Pdp_gr_main(arg,rp)
1.1       noro     1235: NODE arg;
1.8       noro     1236: LIST *rp;
1.1       noro     1237: {
1.8       noro     1238:        LIST f,v;
                   1239:        Num homo;
                   1240:        Q m;
                   1241:        int modular;
                   1242:        struct order_spec ord;
                   1243:
1.11      noro     1244:        do_weyl = 0;
1.8       noro     1245:        asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
                   1246:        asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
                   1247:        asir_assert(ARG2(arg),O_N,"dp_gr_main");
                   1248:        asir_assert(ARG3(arg),O_N,"dp_gr_main");
                   1249:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     1250:        f = remove_zero_from_list(f);
                   1251:        if ( !BDY(f) ) {
                   1252:                *rp = f; return;
                   1253:        }
1.8       noro     1254:        homo = (Num)ARG2(arg);
                   1255:        m = (Q)ARG3(arg);
                   1256:        if ( !m )
                   1257:                modular = 0;
                   1258:        else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
                   1259:                error("dp_gr_main : too large modulus");
                   1260:        else
                   1261:                modular = QTOS(m);
                   1262:        create_order_spec(ARG4(arg),&ord);
1.16      noro     1263:        dp_gr_main(f,v,homo,modular,0,&ord,rp);
                   1264: }
                   1265:
                   1266: void Pdp_gr_f_main(arg,rp)
                   1267: NODE arg;
                   1268: LIST *rp;
                   1269: {
                   1270:        LIST f,v;
                   1271:        Num homo;
1.26      noro     1272:        int m,field,t;
1.16      noro     1273:        struct order_spec ord;
1.26      noro     1274:        NODE n;
1.16      noro     1275:
                   1276:        do_weyl = 0;
                   1277:        asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
                   1278:        asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
                   1279:        asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
                   1280:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     1281:        f = remove_zero_from_list(f);
                   1282:        if ( !BDY(f) ) {
                   1283:                *rp = f; return;
                   1284:        }
1.16      noro     1285:        homo = (Num)ARG2(arg);
1.27    ! noro     1286: #if 0
        !          1287:        asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
1.26      noro     1288:        m = QTOS((Q)ARG3(arg));
                   1289:        if ( m )
                   1290:                error("dp_gr_f_main : trace lifting is not implemented yet");
                   1291:        create_order_spec(ARG4(arg),&ord);
1.27    ! noro     1292: #else
        !          1293:        m = 0;
        !          1294:        create_order_spec(ARG3(arg),&ord);
        !          1295: #endif
1.26      noro     1296:        field = 0;
                   1297:        for ( n = BDY(f); n; n = NEXT(n) ) {
                   1298:                t = get_field_type(BDY(n));
                   1299:                if ( !t )
                   1300:                        continue;
                   1301:                if ( t < 0 )
                   1302:                        error("dp_gr_f_main : incosistent coefficients");
                   1303:                if ( !field )
                   1304:                        field = t;
                   1305:                else if ( t != field )
                   1306:                        error("dp_gr_f_main : incosistent coefficients");
                   1307:        }
                   1308:        dp_gr_main(f,v,homo,m?1:0,field,&ord,rp);
1.1       noro     1309: }
                   1310:
1.8       noro     1311: void Pdp_f4_main(arg,rp)
                   1312: NODE arg;
                   1313: LIST *rp;
1.1       noro     1314: {
1.8       noro     1315:        LIST f,v;
                   1316:        struct order_spec ord;
1.1       noro     1317:
1.11      noro     1318:        do_weyl = 0;
1.8       noro     1319:        asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
                   1320:        asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
                   1321:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     1322:        f = remove_zero_from_list(f);
                   1323:        if ( !BDY(f) ) {
                   1324:                *rp = f; return;
                   1325:        }
1.8       noro     1326:        create_order_spec(ARG2(arg),&ord);
1.17      noro     1327:        dp_f4_main(f,v,&ord,rp);
1.22      noro     1328: }
                   1329:
                   1330: /* dp_gr_checklist(list of dp) */
                   1331:
                   1332: void Pdp_gr_checklist(arg,rp)
                   1333: NODE arg;
                   1334: LIST *rp;
                   1335: {
                   1336:        VECT g;
                   1337:        LIST dp;
                   1338:        NODE r;
1.23      noro     1339:        int n;
1.22      noro     1340:
                   1341:        do_weyl = 0;
                   1342:        asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
1.23      noro     1343:        asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
                   1344:        n = QTOS((Q)ARG1(arg));
                   1345:        gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
1.22      noro     1346:        r = mknode(2,g,dp);
                   1347:        MKLIST(*rp,r);
1.1       noro     1348: }
                   1349:
1.8       noro     1350: void Pdp_f4_mod_main(arg,rp)
                   1351: NODE arg;
                   1352: LIST *rp;
1.1       noro     1353: {
1.8       noro     1354:        LIST f,v;
                   1355:        int m;
                   1356:        struct order_spec ord;
                   1357:
1.11      noro     1358:        do_weyl = 0;
1.17      noro     1359:        asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
                   1360:        asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
                   1361:        asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
1.8       noro     1362:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25      noro     1363:        f = remove_zero_from_list(f);
                   1364:        if ( !BDY(f) ) {
                   1365:                *rp = f; return;
                   1366:        }
1.20      noro     1367:        if ( !m )
                   1368:                error("dp_f4_mod_main : invalid argument");
1.8       noro     1369:        create_order_spec(ARG3(arg),&ord);
                   1370:        dp_f4_mod_main(f,v,m,&ord,rp);
                   1371: }
1.1       noro     1372:
1.8       noro     1373: void Pdp_gr_mod_main(arg,rp)
                   1374: NODE arg;
                   1375: LIST *rp;
                   1376: {
                   1377:        LIST f,v;
                   1378:        Num homo;
                   1379:        int m;
                   1380:        struct order_spec ord;
                   1381:
1.11      noro     1382:        do_weyl = 0;
1.8       noro     1383:        asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
                   1384:        asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
                   1385:        asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
                   1386:        asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1.11      noro     1387:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     1388:        f = remove_zero_from_list(f);
                   1389:        if ( !BDY(f) ) {
                   1390:                *rp = f; return;
                   1391:        }
1.11      noro     1392:        homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20      noro     1393:        if ( !m )
                   1394:                error("dp_gr_mod_main : invalid argument");
1.11      noro     1395:        create_order_spec(ARG4(arg),&ord);
                   1396:        dp_gr_mod_main(f,v,homo,m,&ord,rp);
                   1397: }
                   1398:
                   1399: /* for Weyl algebra */
                   1400:
                   1401: void Pdp_weyl_gr_main(arg,rp)
                   1402: NODE arg;
                   1403: LIST *rp;
                   1404: {
                   1405:        LIST f,v;
                   1406:        Num homo;
                   1407:        Q m;
                   1408:        int modular;
                   1409:        struct order_spec ord;
                   1410:
                   1411:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
                   1412:        asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
                   1413:        asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
                   1414:        asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
                   1415:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     1416:        f = remove_zero_from_list(f);
                   1417:        if ( !BDY(f) ) {
                   1418:                *rp = f; return;
                   1419:        }
1.11      noro     1420:        homo = (Num)ARG2(arg);
                   1421:        m = (Q)ARG3(arg);
                   1422:        if ( !m )
                   1423:                modular = 0;
                   1424:        else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
                   1425:                error("dp_gr_main : too large modulus");
                   1426:        else
                   1427:                modular = QTOS(m);
                   1428:        create_order_spec(ARG4(arg),&ord);
1.12      noro     1429:        do_weyl = 1;
1.16      noro     1430:        dp_gr_main(f,v,homo,modular,0,&ord,rp);
                   1431:        do_weyl = 0;
                   1432: }
                   1433:
                   1434: void Pdp_weyl_gr_f_main(arg,rp)
                   1435: NODE arg;
                   1436: LIST *rp;
                   1437: {
                   1438:        LIST f,v;
                   1439:        Num homo;
                   1440:        struct order_spec ord;
                   1441:
                   1442:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
                   1443:        asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
                   1444:        asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
                   1445:        asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
                   1446:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     1447:        f = remove_zero_from_list(f);
                   1448:        if ( !BDY(f) ) {
                   1449:                *rp = f; return;
                   1450:        }
1.16      noro     1451:        homo = (Num)ARG2(arg);
                   1452:        create_order_spec(ARG3(arg),&ord);
                   1453:        do_weyl = 1;
                   1454:        dp_gr_main(f,v,homo,0,1,&ord,rp);
1.12      noro     1455:        do_weyl = 0;
1.11      noro     1456: }
                   1457:
                   1458: void Pdp_weyl_f4_main(arg,rp)
                   1459: NODE arg;
                   1460: LIST *rp;
                   1461: {
                   1462:        LIST f,v;
                   1463:        struct order_spec ord;
                   1464:
                   1465:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
                   1466:        asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
                   1467:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     1468:        f = remove_zero_from_list(f);
                   1469:        if ( !BDY(f) ) {
                   1470:                *rp = f; return;
                   1471:        }
1.11      noro     1472:        create_order_spec(ARG2(arg),&ord);
1.12      noro     1473:        do_weyl = 1;
1.17      noro     1474:        dp_f4_main(f,v,&ord,rp);
1.12      noro     1475:        do_weyl = 0;
1.11      noro     1476: }
                   1477:
                   1478: void Pdp_weyl_f4_mod_main(arg,rp)
                   1479: NODE arg;
                   1480: LIST *rp;
                   1481: {
                   1482:        LIST f,v;
                   1483:        int m;
                   1484:        struct order_spec ord;
                   1485:
                   1486:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
                   1487:        asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
                   1488:        asir_assert(ARG2(arg),O_N,"dp_f4_main");
                   1489:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25      noro     1490:        f = remove_zero_from_list(f);
                   1491:        if ( !BDY(f) ) {
                   1492:                *rp = f; return;
                   1493:        }
1.20      noro     1494:        if ( !m )
                   1495:                error("dp_weyl_f4_mod_main : invalid argument");
1.11      noro     1496:        create_order_spec(ARG3(arg),&ord);
1.12      noro     1497:        do_weyl = 1;
1.11      noro     1498:        dp_f4_mod_main(f,v,m,&ord,rp);
1.12      noro     1499:        do_weyl = 0;
1.11      noro     1500: }
                   1501:
                   1502: void Pdp_weyl_gr_mod_main(arg,rp)
                   1503: NODE arg;
                   1504: LIST *rp;
                   1505: {
                   1506:        LIST f,v;
                   1507:        Num homo;
                   1508:        int m;
                   1509:        struct order_spec ord;
                   1510:
                   1511:        asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
                   1512:        asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
                   1513:        asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
                   1514:        asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
1.8       noro     1515:        f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25      noro     1516:        f = remove_zero_from_list(f);
                   1517:        if ( !BDY(f) ) {
                   1518:                *rp = f; return;
                   1519:        }
1.8       noro     1520:        homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20      noro     1521:        if ( !m )
                   1522:                error("dp_weyl_gr_mod_main : invalid argument");
1.8       noro     1523:        create_order_spec(ARG4(arg),&ord);
1.12      noro     1524:        do_weyl = 1;
1.8       noro     1525:        dp_gr_mod_main(f,v,homo,m,&ord,rp);
1.12      noro     1526:        do_weyl = 0;
1.1       noro     1527: }
1.8       noro     1528:
1.24      noro     1529: static VECT current_dl_weight_vector_obj;
                   1530: int *current_dl_weight_vector;
                   1531:
                   1532: void Pdp_set_weight(arg,rp)
                   1533: NODE arg;
                   1534: VECT *rp;
                   1535: {
                   1536:        VECT v;
                   1537:        int i,n;
                   1538:
                   1539:        if ( !arg )
                   1540:                *rp = current_dl_weight_vector_obj;
                   1541:        else if ( !ARG0(arg) ) {
                   1542:                current_dl_weight_vector_obj = 0;
                   1543:                current_dl_weight_vector = 0;
                   1544:                *rp = 0;
                   1545:        } else {
                   1546:                asir_assert(ARG0(arg),O_VECT,"dp_set_weight");
                   1547:                v = (VECT)ARG0(arg);
                   1548:                current_dl_weight_vector_obj = v;
                   1549:                n = v->len;
                   1550:                current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
                   1551:                for ( i = 0; i < n; i++ )
                   1552:                        current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
                   1553:                *rp = v;
                   1554:        }
                   1555: }
                   1556:
                   1557: static VECT current_weyl_weight_vector_obj;
                   1558: int *current_weyl_weight_vector;
1.15      noro     1559:
                   1560: void Pdp_weyl_set_weight(arg,rp)
                   1561: NODE arg;
                   1562: VECT *rp;
                   1563: {
                   1564:        VECT v;
                   1565:        int i,n;
                   1566:
                   1567:        if ( !arg )
1.24      noro     1568:                *rp = current_weyl_weight_vector_obj;
1.15      noro     1569:        else {
                   1570:                asir_assert(ARG0(arg),O_VECT,"dp_weyl_set_weight");
                   1571:                v = (VECT)ARG0(arg);
1.24      noro     1572:                current_weyl_weight_vector_obj = v;
1.15      noro     1573:                n = v->len;
1.24      noro     1574:                current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
1.15      noro     1575:                for ( i = 0; i < n; i++ )
1.24      noro     1576:                        current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
1.15      noro     1577:                *rp = v;
                   1578:        }
1.25      noro     1579: }
                   1580:
                   1581: LIST remove_zero_from_list(LIST l)
                   1582: {
                   1583:        NODE n,r0,r;
                   1584:        LIST rl;
                   1585:
                   1586:        asir_assert(l,O_LIST,"remove_zero_from_list");
                   1587:        n = BDY(l);
                   1588:        for ( r0 = 0; n; n = NEXT(n) )
                   1589:                if ( BDY(n) ) {
                   1590:                        NEXTNODE(r0,r);
                   1591:                        BDY(r) = BDY(n);
                   1592:                }
                   1593:        if ( r0 )
                   1594:                NEXT(r) = 0;
                   1595:        MKLIST(rl,r0);
                   1596:        return rl;
1.26      noro     1597: }
                   1598:
                   1599: int get_field_type(P p)
                   1600: {
                   1601:        int type,t;
                   1602:        DCP dc;
                   1603:
                   1604:        if ( !p )
                   1605:                return 0;
                   1606:        else if ( NUM(p) )
                   1607:                return NID((Num)p);
                   1608:        else {
                   1609:                type = 0;
                   1610:                for ( dc = DC(p); dc; dc = NEXT(dc) ) {
                   1611:                        t = get_field_type(COEF(dc));
                   1612:                        if ( !t )
                   1613:                                continue;
                   1614:                        if ( t < 0 )
                   1615:                                return t;
                   1616:                        if ( !type )
                   1617:                                type = t;
                   1618:                        else if ( t != type )
                   1619:                                return -1;
                   1620:                }
                   1621:                return type;
                   1622:        }
1.15      noro     1623: }

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