Annotation of OpenXM_contrib2/asir2018/builtin/dp.c, Revision 1.1
1.1 ! 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
! 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
! 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: *
! 48: * $OpenXM$
! 49: */
! 50: #include "ca.h"
! 51: #include "base.h"
! 52: #include "parse.h"
! 53:
! 54: extern int dp_fcoeffs;
! 55: extern int dp_nelim;
! 56: extern int dp_order_pair_length;
! 57: extern struct order_pair *dp_order_pair;
! 58: extern struct order_spec *dp_current_spec;
! 59: extern struct modorder_spec *dp_current_modspec;
! 60: extern int nd_rref2;
! 61:
! 62: int do_weyl;
! 63:
! 64: void Pdp_sort();
! 65: void Pdp_mul_trunc(),Pdp_quo();
! 66: void Pdp_ord(), Pdp_ptod(), Pdp_dtop(), Phomogenize();
! 67: void Pdp_ptozp(), Pdp_ptozp2(), Pdp_red(), Pdp_red2(), Pdp_lcm(), Pdp_redble();
! 68: void Pdp_sp(), Pdp_hm(), Pdp_ht(), Pdp_hc(), Pdp_rest(), Pdp_td(), Pdp_sugar();
! 69: void Pdp_set_sugar();
! 70: void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv();
! 71: void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat();
! 72: void Pdp_nf(),Pdp_true_nf(),Pdp_true_nf_marked(),Pdp_true_nf_marked_mod();
! 73:
! 74: void Pdp_true_nf_and_quotient(),Pdp_true_nf_and_quotient_mod();
! 75: void Pdp_true_nf_and_quotient_marked(),Pdp_true_nf_and_quotient_marked_mod();
! 76:
! 77: void Pdp_nf_mod(),Pdp_true_nf_mod();
! 78: void Pdp_criB(),Pdp_nelim();
! 79: void Pdp_minp(),Pdp_sp_mod();
! 80: void Pdp_homo(),Pdp_dehomo();
! 81: void Pdp_gr_mod_main(),Pdp_gr_f_main();
! 82: void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags();
! 83: void Pdp_interreduce();
! 84: void Pdp_f4_main(),Pdp_f4_mod_main(),Pdp_f4_f_main();
! 85: void Pdp_gr_print();
! 86: void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_mdtod(), Pdp_nf_tab_f();
! 87: void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
! 88: void Pdp_cont();
! 89: void Pdp_gr_checklist();
! 90: void Pdp_ltod(),Pdpv_ord(),Pdpv_ht(),Pdpv_hm(),Pdpv_hc();
! 91: void Pdpm_ltod(),Pdpm_dtol(),Pdpm_ord(),Pdpm_nf(),Pdpm_weyl_nf(),Pdpm_sp(),Pdpm_weyl_sp();
! 92: void Pdpm_hm(),Pdpm_ht(),Pdpm_hc();
! 93:
! 94: void Pdp_weyl_red();
! 95: void Pdp_weyl_sp();
! 96:
! 97: void Pdp_weyl_nf(),Pdp_weyl_nf_mod();
! 98: void Pdp_weyl_true_nf_and_quotient(),Pdp_weyl_true_nf_and_quotient_mod();
! 99: void Pdp_weyl_true_nf_and_quotient_marked(),Pdp_weyl_true_nf_and_quotient_marked_mod();
! 100:
! 101: void Pdp_weyl_gr_main(),Pdp_weyl_gr_mod_main(),Pdp_weyl_gr_f_main();
! 102: void Pdp_weyl_f4_main(),Pdp_weyl_f4_mod_main(),Pdp_weyl_f4_f_main();
! 103: void Pdp_weyl_mul(),Pdp_weyl_mul_mod(),Pdp_weyl_act();
! 104: void Pdp_weyl_set_weight();
! 105: void Pdp_set_weight(),Pdp_set_top_weight(),Pdp_set_module_weight();
! 106: void Pdp_nf_f(),Pdp_weyl_nf_f();
! 107: void Pdpm_nf_f(),Pdpm_weyl_nf_f();
! 108: void Pdp_lnf_f();
! 109: void Pnd_gr(),Pnd_gr_trace(),Pnd_f4(),Pnd_f4_trace();
! 110: void Pnd_gr_postproc(), Pnd_weyl_gr_postproc();
! 111: void Pnd_gr_recompute_trace(), Pnd_btog();
! 112: void Pnd_weyl_gr(),Pnd_weyl_gr_trace();
! 113: void Pnd_nf(),Pnd_weyl_nf();
! 114: void Pdp_initial_term();
! 115: void Pdp_order();
! 116: void Pdp_inv_or_split();
! 117: void Pdp_compute_last_t();
! 118: void Pdp_compute_last_w();
! 119: void Pdp_compute_essential_df();
! 120: void Pdp_get_denomlist();
! 121: void Pdp_symb_add();
! 122: void Pdp_mono_raddec();
! 123: void Pdp_mono_reduce();
! 124: void Pdp_rref2(),Psumi_updatepairs(),Psumi_symbolic();
! 125:
! 126: LIST dp_initial_term();
! 127: LIST dp_order();
! 128: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
! 129: int *modular,struct order_spec **ord);
! 130: NODE dp_inv_or_split(NODE gb,DP f,struct order_spec *spec, DP *inv);
! 131:
! 132: LIST remove_zero_from_list(LIST);
! 133:
! 134: struct ftab dp_tab[] = {
! 135: /* content reduction */
! 136: {"dp_ptozp",Pdp_ptozp,1},
! 137: {"dp_ptozp2",Pdp_ptozp2,2},
! 138: {"dp_prim",Pdp_prim,1},
! 139: {"dp_red_coef",Pdp_red_coef,2},
! 140: {"dp_cont",Pdp_cont,1},
! 141:
! 142: /* polynomial ring */
! 143: /* special operations */
! 144: {"dp_mul_trunc",Pdp_mul_trunc,3},
! 145: {"dp_quo",Pdp_quo,2},
! 146:
! 147: /* s-poly */
! 148: {"dp_sp",Pdp_sp,2},
! 149: {"dp_sp_mod",Pdp_sp_mod,3},
! 150:
! 151: /* m-reduction */
! 152: {"dp_red",Pdp_red,3},
! 153: {"dp_red_mod",Pdp_red_mod,4},
! 154:
! 155: /* normal form */
! 156: {"dp_nf",Pdp_nf,4},
! 157: {"dp_nf_mod",Pdp_nf_mod,5},
! 158: {"dp_nf_f",Pdp_nf_f,4},
! 159: {"dpm_nf_f",Pdpm_nf_f,4},
! 160: {"dpm_weyl_nf_f",Pdpm_weyl_nf_f,4},
! 161: {"dpm_nf",Pdpm_nf,4},
! 162: {"dpm_sp",Pdpm_sp,2},
! 163: {"dpm_weyl_sp",Pdpm_weyl_sp,2},
! 164:
! 165: {"dp_true_nf",Pdp_true_nf,4},
! 166: {"dp_true_nf_mod",Pdp_true_nf_mod,5},
! 167: {"dp_true_nf_marked",Pdp_true_nf_marked,4},
! 168: {"dp_true_nf_marked_mod",Pdp_true_nf_marked_mod,5},
! 169:
! 170: {"dp_true_nf_and_quotient",Pdp_true_nf_and_quotient,3},
! 171: {"dp_true_nf_and_quotient_mod",Pdp_true_nf_and_quotient_mod,4},
! 172: {"dp_true_nf_and_quotient_marked",Pdp_true_nf_and_quotient_marked,4},
! 173: {"dp_true_nf_and_quotient_marked_mod",Pdp_true_nf_and_quotient_marked_mod,5},
! 174:
! 175: {"dp_lnf_mod",Pdp_lnf_mod,3},
! 176: {"dp_nf_tab_f",Pdp_nf_tab_f,2},
! 177: {"dp_nf_tab_mod",Pdp_nf_tab_mod,3},
! 178: {"dp_lnf_f",Pdp_lnf_f,2},
! 179:
! 180: /* Buchberger algorithm */
! 181: {"dp_gr_main",Pdp_gr_main,-5},
! 182: {"dp_interreduce",Pdp_interreduce,3},
! 183: {"dp_gr_mod_main",Pdp_gr_mod_main,5},
! 184: {"dp_gr_f_main",Pdp_gr_f_main,4},
! 185: {"dp_gr_checklist",Pdp_gr_checklist,2},
! 186: {"nd_f4",Pnd_f4,-4},
! 187: {"nd_gr",Pnd_gr,-4},
! 188: {"nd_gr_trace",Pnd_gr_trace,-5},
! 189: {"nd_f4_trace",Pnd_f4_trace,-5},
! 190: {"nd_gr_postproc",Pnd_gr_postproc,5},
! 191: {"nd_gr_recompute_trace",Pnd_gr_recompute_trace,5},
! 192: {"nd_btog",Pnd_btog,-6},
! 193: {"nd_weyl_gr_postproc",Pnd_weyl_gr_postproc,5},
! 194: {"nd_weyl_gr",Pnd_weyl_gr,-4},
! 195: {"nd_weyl_gr_trace",Pnd_weyl_gr_trace,-5},
! 196: {"nd_nf",Pnd_nf,5},
! 197: {"nd_weyl_nf",Pnd_weyl_nf,5},
! 198:
! 199: /* F4 algorithm */
! 200: {"dp_f4_main",Pdp_f4_main,3},
! 201: {"dp_f4_mod_main",Pdp_f4_mod_main,4},
! 202:
! 203: /* weyl algebra */
! 204: /* multiplication */
! 205: {"dp_weyl_mul",Pdp_weyl_mul,2},
! 206: {"dp_weyl_mul_mod",Pdp_weyl_mul_mod,3},
! 207: {"dp_weyl_act",Pdp_weyl_act,2},
! 208:
! 209: /* s-poly */
! 210: {"dp_weyl_sp",Pdp_weyl_sp,2},
! 211:
! 212: /* m-reduction */
! 213: {"dp_weyl_red",Pdp_weyl_red,3},
! 214:
! 215: /* normal form */
! 216: {"dp_weyl_nf",Pdp_weyl_nf,4},
! 217: {"dpm_weyl_nf",Pdpm_weyl_nf,4},
! 218: {"dp_weyl_nf_mod",Pdp_weyl_nf_mod,5},
! 219: {"dp_weyl_nf_f",Pdp_weyl_nf_f,4},
! 220:
! 221: {"dp_weyl_true_nf_and_quotient",Pdp_weyl_true_nf_and_quotient,3},
! 222: {"dp_weyl_true_nf_and_quotient_mod",Pdp_weyl_true_nf_and_quotient_mod,4},
! 223: {"dp_weyl_true_nf_and_quotient_marked",Pdp_weyl_true_nf_and_quotient_marked,4},
! 224: {"dp_weyl_true_nf_and_quotient_marked_mod",Pdp_weyl_true_nf_and_quotient_marked_mod,5},
! 225:
! 226:
! 227: /* Buchberger algorithm */
! 228: {"dp_weyl_gr_main",Pdp_weyl_gr_main,-5},
! 229: {"dp_weyl_gr_mod_main",Pdp_weyl_gr_mod_main,5},
! 230: {"dp_weyl_gr_f_main",Pdp_weyl_gr_f_main,4},
! 231:
! 232: /* F4 algorithm */
! 233: {"dp_weyl_f4_main",Pdp_weyl_f4_main,3},
! 234: {"dp_weyl_f4_mod_main",Pdp_weyl_f4_mod_main,4},
! 235:
! 236: /* misc */
! 237: {"dp_inv_or_split",Pdp_inv_or_split,3},
! 238: {"dp_set_weight",Pdp_set_weight,-1},
! 239: {"dp_set_module_weight",Pdp_set_module_weight,-1},
! 240: {"dp_set_top_weight",Pdp_set_top_weight,-1},
! 241: {"dp_weyl_set_weight",Pdp_weyl_set_weight,-1},
! 242:
! 243: {"dp_get_denomlist",Pdp_get_denomlist,0},
! 244: {0,0,0},
! 245: };
! 246:
! 247: struct ftab dp_supp_tab[] = {
! 248: /* setting flags */
! 249: {"dp_sort",Pdp_sort,1},
! 250: {"dp_ord",Pdp_ord,-1},
! 251: {"dpm_ord",Pdpm_ord,-1},
! 252: {"dpv_ord",Pdpv_ord,-2},
! 253: {"dp_set_kara",Pdp_set_kara,-1},
! 254: {"dp_nelim",Pdp_nelim,-1},
! 255: {"dp_gr_flags",Pdp_gr_flags,-1},
! 256: {"dp_gr_print",Pdp_gr_print,-1},
! 257:
! 258: /* converters */
! 259: {"homogenize",Phomogenize,3},
! 260: {"dp_ptod",Pdp_ptod,-2},
! 261: {"dp_dtop",Pdp_dtop,2},
! 262: {"dp_homo",Pdp_homo,1},
! 263: {"dp_dehomo",Pdp_dehomo,1},
! 264: {"dp_etov",Pdp_etov,1},
! 265: {"dp_vtoe",Pdp_vtoe,1},
! 266: {"dp_dtov",Pdp_dtov,1},
! 267: {"dp_mdtod",Pdp_mdtod,1},
! 268: {"dp_mod",Pdp_mod,3},
! 269: {"dp_rat",Pdp_rat,1},
! 270: {"dp_ltod",Pdp_ltod,-2},
! 271:
! 272: {"dpm_ltod",Pdpm_ltod,2},
! 273: {"dpm_dtol",Pdpm_dtol,3},
! 274:
! 275: /* criteria */
! 276: {"dp_cri1",Pdp_cri1,2},
! 277: {"dp_cri2",Pdp_cri2,2},
! 278: {"dp_criB",Pdp_criB,3},
! 279:
! 280: /* simple operation */
! 281: {"dp_subd",Pdp_subd,2},
! 282: {"dp_lcm",Pdp_lcm,2},
! 283: {"dp_hm",Pdp_hm,1},
! 284: {"dp_ht",Pdp_ht,1},
! 285: {"dp_hc",Pdp_hc,1},
! 286: {"dpv_hm",Pdpv_hm,1},
! 287: {"dpv_ht",Pdpv_ht,1},
! 288: {"dpv_hc",Pdpv_hc,1},
! 289: {"dpm_hm",Pdpm_hm,1},
! 290: {"dpm_ht",Pdpm_ht,1},
! 291: {"dpm_hc",Pdpm_hc,1},
! 292: {"dp_rest",Pdp_rest,1},
! 293: {"dp_initial_term",Pdp_initial_term,1},
! 294: {"dp_order",Pdp_order,1},
! 295: {"dp_symb_add",Pdp_symb_add,2},
! 296:
! 297: /* degree and size */
! 298: {"dp_td",Pdp_td,1},
! 299: {"dp_mag",Pdp_mag,1},
! 300: {"dp_sugar",Pdp_sugar,1},
! 301: {"dp_set_sugar",Pdp_set_sugar,2},
! 302:
! 303: /* misc */
! 304: {"dp_mbase",Pdp_mbase,1},
! 305: {"dp_redble",Pdp_redble,2},
! 306: {"dp_sep",Pdp_sep,2},
! 307: {"dp_idiv",Pdp_idiv,2},
! 308: {"dp_tdiv",Pdp_tdiv,2},
! 309: {"dp_minp",Pdp_minp,2},
! 310: {"dp_compute_last_w",Pdp_compute_last_w,5},
! 311: {"dp_compute_last_t",Pdp_compute_last_t,5},
! 312: {"dp_compute_essential_df",Pdp_compute_essential_df,2},
! 313: {"dp_mono_raddec",Pdp_mono_raddec,2},
! 314: {"dp_mono_reduce",Pdp_mono_reduce,2},
! 315:
! 316: {"dp_rref2",Pdp_rref2,2},
! 317: {"sumi_updatepairs",Psumi_updatepairs,3},
! 318: {"sumi_symbolic",Psumi_symbolic,5},
! 319:
! 320: {0,0,0}
! 321: };
! 322:
! 323: NODE compute_last_w(NODE g,NODE gh,int n,int **v,int row1,int **m1,int row2,int **m2);
! 324: Q compute_last_t(NODE g,NODE gh,Q t,VECT w1,VECT w2,NODE *homo,VECT *wp);
! 325:
! 326: void Pdp_compute_last_t(NODE arg,LIST *rp)
! 327: {
! 328: NODE g,gh,homo,n;
! 329: LIST hlist;
! 330: VECT v1,v2,w;
! 331: Q t;
! 332:
! 333: g = (NODE)BDY((LIST)ARG0(arg));
! 334: gh = (NODE)BDY((LIST)ARG1(arg));
! 335: t = (Q)ARG2(arg);
! 336: v1 = (VECT)ARG3(arg);
! 337: v2 = (VECT)ARG4(arg);
! 338: t = compute_last_t(g,gh,t,v1,v2,&homo,&w);
! 339: MKLIST(hlist,homo);
! 340: n = mknode(3,t,w,hlist);
! 341: MKLIST(*rp,n);
! 342: }
! 343:
! 344: void Pdp_compute_last_w(NODE arg,LIST *rp)
! 345: {
! 346: NODE g,gh,r;
! 347: VECT w,rv;
! 348: LIST l;
! 349: MAT w1,w2;
! 350: int row1,row2,i,j,n;
! 351: int *v;
! 352: int **m1,**m2;
! 353: Z q;
! 354:
! 355: g = (NODE)BDY((LIST)ARG0(arg));
! 356: gh = (NODE)BDY((LIST)ARG1(arg));
! 357: w = (VECT)ARG2(arg);
! 358: w1 = (MAT)ARG3(arg);
! 359: w2 = (MAT)ARG4(arg);
! 360: n = w1->col;
! 361: row1 = w1->row;
! 362: row2 = w2->row;
! 363: if ( w ) {
! 364: v = W_ALLOC(n);
! 365: for ( i = 0; i < n; i++ ) v[i] = QTOS((Q)w->body[i]);
! 366: } else v = 0;
! 367: m1 = almat(row1,n);
! 368: for ( i = 0; i < row1; i++ )
! 369: for ( j = 0; j < n; j++ ) m1[i][j] = QTOS((Q)w1->body[i][j]);
! 370: m2 = almat(row2,n);
! 371: for ( i = 0; i < row2; i++ )
! 372: for ( j = 0; j < n; j++ ) m2[i][j] = QTOS((Q)w2->body[i][j]);
! 373: r = compute_last_w(g,gh,n,&v,row1,m1,row2,m2);
! 374: if ( !r ) *rp = 0;
! 375: else {
! 376: MKVECT(rv,n);
! 377: for ( i = 0; i < n; i++ ) {
! 378: STOQ(v[i],q); rv->body[i] = (pointer)q;
! 379: }
! 380: MKLIST(l,r);
! 381: r = mknode(2,rv,l);
! 382: MKLIST(*rp,r);
! 383: }
! 384: }
! 385:
! 386: NODE compute_essential_df(DP *g,DP *gh,int n);
! 387:
! 388: void Pdp_compute_essential_df(NODE arg,LIST *rp)
! 389: {
! 390: VECT g,gh;
! 391: NODE r;
! 392:
! 393: g = (VECT)ARG0(arg);
! 394: gh = (VECT)ARG1(arg);
! 395: r = (NODE)compute_essential_df((DP *)BDY(g),(DP *)BDY(gh),g->len);
! 396: MKLIST(*rp,r);
! 397: }
! 398:
! 399: void Pdp_inv_or_split(NODE arg,Obj *rp)
! 400: {
! 401: NODE gb,newgb;
! 402: DP f,inv;
! 403: struct order_spec *spec;
! 404: LIST list;
! 405:
! 406: do_weyl = 0; dp_fcoeffs = 0;
! 407: asir_assert(ARG0(arg),O_LIST,"dp_inv_or_split");
! 408: asir_assert(ARG1(arg),O_DP,"dp_inv_or_split");
! 409: if ( !create_order_spec(0,(Obj)ARG2(arg),&spec) )
! 410: error("dp_inv_or_split : invalid order specification");
! 411: gb = BDY((LIST)ARG0(arg));
! 412: f = (DP)ARG1(arg);
! 413: newgb = (NODE)dp_inv_or_split(gb,f,spec,&inv);
! 414: if ( !newgb ) {
! 415: /* invertible */
! 416: *rp = (Obj)inv;
! 417: } else {
! 418: MKLIST(list,newgb);
! 419: *rp = (Obj)list;
! 420: }
! 421: }
! 422:
! 423: void Pdp_sort(NODE arg,DP *rp)
! 424: {
! 425: dp_sort((DP)ARG0(arg),rp);
! 426: }
! 427:
! 428: void Pdp_mdtod(NODE arg,DP *rp)
! 429: {
! 430: MP m,mr,mr0;
! 431: DP p;
! 432: P t;
! 433:
! 434: p = (DP)ARG0(arg);
! 435: if ( !p )
! 436: *rp = 0;
! 437: else {
! 438: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
! 439: mptop((P)m->c,&t); NEXTMP(mr0,mr); mr->c = (Obj)t; mr->dl = m->dl;
! 440: }
! 441: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
! 442: }
! 443: }
! 444:
! 445: void Pdp_sep(NODE arg,VECT *rp)
! 446: {
! 447: DP p,r;
! 448: MP m,t;
! 449: MP *w0,*w;
! 450: int i,n,d,nv,sugar;
! 451: VECT v;
! 452: pointer *pv;
! 453:
! 454: p = (DP)ARG0(arg); m = BDY(p);
! 455: d = QTOS((Q)ARG1(arg));
! 456: for ( t = m, n = 0; t; t = NEXT(t), n++ );
! 457: if ( d > n )
! 458: d = n;
! 459: MKVECT(v,d); *rp = v;
! 460: pv = BDY(v); nv = p->nv; sugar = p->sugar;
! 461: w0 = (MP *)MALLOC(d*sizeof(MP)); bzero(w0,d*sizeof(MP));
! 462: w = (MP *)MALLOC(d*sizeof(MP)); bzero(w,d*sizeof(MP));
! 463: for ( t = BDY(p), i = 0; t; t = NEXT(t), i++, i %= d ) {
! 464: NEXTMP(w0[i],w[i]); w[i]->c = t->c; w[i]->dl = t->dl;
! 465: }
! 466: for ( i = 0; i < d; i++ ) {
! 467: NEXT(w[i]) = 0; MKDP(nv,w0[i],r); r->sugar = sugar;
! 468: pv[i] = (pointer)r;
! 469: }
! 470: }
! 471:
! 472: void Pdp_idiv(NODE arg,DP *rp)
! 473: {
! 474: dp_idiv((DP)ARG0(arg),(Z)ARG1(arg),rp);
! 475: }
! 476:
! 477: void Pdp_cont(NODE arg,Z *rp)
! 478: {
! 479: dp_cont((DP)ARG0(arg),rp);
! 480: }
! 481:
! 482: void Pdp_dtov(NODE arg,VECT *rp)
! 483: {
! 484: dp_dtov((DP)ARG0(arg),rp);
! 485: }
! 486:
! 487: void Pdp_mbase(NODE arg,LIST *rp)
! 488: {
! 489: NODE mb;
! 490:
! 491: asir_assert(ARG0(arg),O_LIST,"dp_mbase");
! 492: dp_mbase(BDY((LIST)ARG0(arg)),&mb);
! 493: MKLIST(*rp,mb);
! 494: }
! 495:
! 496: void Pdp_etov(NODE arg,VECT *rp)
! 497: {
! 498: DP dp;
! 499: int n,i;
! 500: int *d;
! 501: VECT v;
! 502: Z t;
! 503:
! 504: dp = (DP)ARG0(arg);
! 505: asir_assert(dp,O_DP,"dp_etov");
! 506: n = dp->nv; d = BDY(dp)->dl->d;
! 507: MKVECT(v,n);
! 508: for ( i = 0; i < n; i++ ) {
! 509: STOQ(d[i],t); v->body[i] = (pointer)t;
! 510: }
! 511: *rp = v;
! 512: }
! 513:
! 514: void Pdp_vtoe(NODE arg,DP *rp)
! 515: {
! 516: DP dp;
! 517: DL dl;
! 518: MP m;
! 519: int n,i,td;
! 520: int *d;
! 521: VECT v;
! 522:
! 523: v = (VECT)ARG0(arg);
! 524: asir_assert(v,O_VECT,"dp_vtoe");
! 525: n = v->len;
! 526: NEWDL(dl,n); d = dl->d;
! 527: for ( i = 0, td = 0; i < n; i++ ) {
! 528: d[i] = QTOS((Q)(v->body[i])); td += MUL_WEIGHT(d[i],i);
! 529: }
! 530: dl->td = td;
! 531: NEWMP(m); m->dl = dl; m->c = (Obj)ONE; NEXT(m) = 0;
! 532: MKDP(n,m,dp); dp->sugar = td;
! 533: *rp = dp;
! 534: }
! 535:
! 536: void Pdp_lnf_mod(NODE arg,LIST *rp)
! 537: {
! 538: DP r1,r2;
! 539: NODE b,g,n;
! 540: int mod;
! 541:
! 542: asir_assert(ARG0(arg),O_LIST,"dp_lnf_mod");
! 543: asir_assert(ARG1(arg),O_LIST,"dp_lnf_mod");
! 544: asir_assert(ARG2(arg),O_N,"dp_lnf_mod");
! 545: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
! 546: mod = QTOS((Q)ARG2(arg));
! 547: dp_lnf_mod((DP)BDY(b),(DP)BDY(NEXT(b)),g,mod,&r1,&r2);
! 548: NEWNODE(n); BDY(n) = (pointer)r1;
! 549: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
! 550: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
! 551: }
! 552:
! 553: void Pdp_lnf_f(NODE arg,LIST *rp)
! 554: {
! 555: DP r1,r2;
! 556: NODE b,g,n;
! 557:
! 558: asir_assert(ARG0(arg),O_LIST,"dp_lnf_f");
! 559: asir_assert(ARG1(arg),O_LIST,"dp_lnf_f");
! 560: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
! 561: dp_lnf_f((DP)BDY(b),(DP)BDY(NEXT(b)),g,&r1,&r2);
! 562: NEWNODE(n); BDY(n) = (pointer)r1;
! 563: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
! 564: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
! 565: }
! 566:
! 567: void Pdp_nf_tab_mod(NODE arg,DP *rp)
! 568: {
! 569: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_mod");
! 570: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_mod");
! 571: asir_assert(ARG2(arg),O_N,"dp_nf_tab_mod");
! 572: dp_nf_tab_mod((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),
! 573: QTOS((Q)ARG2(arg)),rp);
! 574: }
! 575:
! 576: void Pdp_nf_tab_f(NODE arg,DP *rp)
! 577: {
! 578: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_f");
! 579: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_f");
! 580: dp_nf_tab_f((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),rp);
! 581: }
! 582:
! 583: void Pdp_ord(NODE arg,Obj *rp)
! 584: {
! 585: struct order_spec *spec;
! 586: LIST v;
! 587: struct oLIST f;
! 588: Num homo;
! 589: int modular;
! 590:
! 591: f.id = O_LIST; f.body = 0;
! 592: if ( !arg && !current_option )
! 593: *rp = dp_current_spec->obj;
! 594: else {
! 595: if ( current_option )
! 596: parse_gr_option(&f,current_option,&v,&homo,&modular,&spec);
! 597: else if ( !create_order_spec(0,(Obj)ARG0(arg),&spec) )
! 598: error("dp_ord : invalid order specification");
! 599: initd(spec); *rp = spec->obj;
! 600: }
! 601: }
! 602:
! 603: void Pdp_ptod(NODE arg,DP *rp)
! 604: {
! 605: P p;
! 606: NODE n;
! 607: VL vl,tvl;
! 608: struct oLIST f;
! 609: int ac;
! 610: LIST v;
! 611: Num homo;
! 612: int modular;
! 613: struct order_spec *ord;
! 614:
! 615: asir_assert(ARG0(arg),O_P,"dp_ptod");
! 616: p = (P)ARG0(arg);
! 617: ac = argc(arg);
! 618: if ( ac == 1 ) {
! 619: if ( current_option ) {
! 620: f.id = O_LIST; f.body = mknode(1,p);
! 621: parse_gr_option(&f,current_option,&v,&homo,&modular,&ord);
! 622: initd(ord);
! 623: } else
! 624: error("dp_ptod : invalid argument");
! 625: } else {
! 626: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
! 627: v = (LIST)ARG1(arg);
! 628: }
! 629: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
! 630: if ( !vl ) {
! 631: NEWVL(vl); tvl = vl;
! 632: } else {
! 633: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
! 634: }
! 635: VR(tvl) = VR((P)BDY(n));
! 636: }
! 637: if ( vl )
! 638: NEXT(tvl) = 0;
! 639: ptod(CO,vl,p,rp);
! 640: }
! 641:
! 642: void Phomogenize(NODE arg,Obj *rp)
! 643: {
! 644: P p;
! 645: DP d,h;
! 646: NODE n;
! 647: V hv;
! 648: VL vl,tvl,last;
! 649: struct oLIST f;
! 650: LIST v;
! 651:
! 652: asir_assert(ARG0(arg),O_P,"homogenize");
! 653: p = (P)ARG0(arg);
! 654: asir_assert(ARG1(arg),O_LIST,"homogenize");
! 655: v = (LIST)ARG1(arg);
! 656: asir_assert(ARG2(arg),O_P,"homogenize");
! 657: hv = VR((P)ARG2(arg));
! 658: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
! 659: if ( !vl ) {
! 660: NEWVL(vl); tvl = vl;
! 661: } else {
! 662: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
! 663: }
! 664: VR(tvl) = VR((P)BDY(n));
! 665: }
! 666: if ( vl ) {
! 667: last = tvl;
! 668: NEXT(tvl) = 0;
! 669: }
! 670: ptod(CO,vl,p,&d);
! 671: dp_homo(d,&h);
! 672: NEWVL(NEXT(last)); last = NEXT(last);
! 673: VR(last) = hv; NEXT(last) = 0;
! 674: dtop(CO,vl,h,rp);
! 675: }
! 676:
! 677: void Pdp_ltod(NODE arg,DPV *rp)
! 678: {
! 679: NODE n;
! 680: VL vl,tvl;
! 681: LIST f,v;
! 682: int sugar,i,len,ac,modular;
! 683: Num homo;
! 684: struct order_spec *ord;
! 685: DP *e;
! 686: NODE nd,t;
! 687:
! 688: ac = argc(arg);
! 689: asir_assert(ARG0(arg),O_LIST,"dp_ptod");
! 690: f = (LIST)ARG0(arg);
! 691: if ( ac == 1 ) {
! 692: if ( current_option ) {
! 693: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
! 694: initd(ord);
! 695: } else
! 696: error("dp_ltod : invalid argument");
! 697: } else {
! 698: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
! 699: v = (LIST)ARG1(arg);
! 700: }
! 701: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
! 702: if ( !vl ) {
! 703: NEWVL(vl); tvl = vl;
! 704: } else {
! 705: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
! 706: }
! 707: VR(tvl) = VR((P)BDY(n));
! 708: }
! 709: if ( vl )
! 710: NEXT(tvl) = 0;
! 711:
! 712: nd = BDY(f);
! 713: len = length(nd);
! 714: e = (DP *)MALLOC(len*sizeof(DP));
! 715: sugar = 0;
! 716: for ( i = 0, t = nd; i < len; i++, t = NEXT(t) ) {
! 717: ptod(CO,vl,(P)BDY(t),&e[i]);
! 718: if ( e[i] )
! 719: sugar = MAX(sugar,e[i]->sugar);
! 720: }
! 721: MKDPV(len,e,*rp);
! 722: }
! 723:
! 724: void Pdpm_ltod(NODE arg,DPM *rp)
! 725: {
! 726: NODE n;
! 727: VL vl,tvl;
! 728: LIST f,v;
! 729: int i,len;
! 730: NODE nd;
! 731: NODE t;
! 732: DP d;
! 733: DPM s,u,w;
! 734:
! 735: f = (LIST)ARG0(arg);
! 736: v = (LIST)ARG1(arg);
! 737: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
! 738: if ( !vl ) {
! 739: NEWVL(vl); tvl = vl;
! 740: } else {
! 741: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
! 742: }
! 743: VR(tvl) = VR((P)BDY(n));
! 744: }
! 745: if ( vl )
! 746: NEXT(tvl) = 0;
! 747:
! 748: nd = BDY(f);
! 749: len = length(nd);
! 750: for ( i = 0, t = nd, s = 0; i < len; i++, t = NEXT(t) ) {
! 751: ptod(CO,vl,(P)BDY(t),&d);
! 752: dtodpm(d,i,&u);
! 753: adddpm(CO,s,u,&w); s = w;
! 754: }
! 755: *rp = s;
! 756: }
! 757:
! 758: void Pdpm_dtol(NODE arg,LIST *rp)
! 759: {
! 760: DPM a;
! 761: NODE nd,nd1;
! 762: VL vl,tvl;
! 763: int n,len,i,pos,nv;
! 764: MP *w;
! 765: DMM t;
! 766: DMM *wa;
! 767: MP m;
! 768: DP u;
! 769: Obj s;
! 770:
! 771: a = (DPM)ARG0(arg);
! 772: for ( vl = 0, nd = BDY((LIST)ARG1(arg)), nv = 0; nd; nd = NEXT(nd), nv++ ) {
! 773: if ( !vl ) {
! 774: NEWVL(vl); tvl = vl;
! 775: } else {
! 776: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
! 777: }
! 778: VR(tvl) = VR((P)BDY(nd));
! 779: }
! 780: if ( vl )
! 781: NEXT(tvl) = 0;
! 782: n = QTOS((Q)ARG2(arg));
! 783: w = (MP *)CALLOC(n,sizeof(MP));
! 784: for ( t = BDY(a), len = 0; t; t = NEXT(t) ) len++;
! 785: wa = (DMM *)MALLOC(len*sizeof(DMM));
! 786: for ( t = BDY(a), i = 0; t; t = NEXT(t), i++ ) wa[i] = t;
! 787: for ( i = len-1; i >= 0; i-- ) {
! 788: NEWMP(m); m->dl = wa[i]->dl; C(m) = C(wa[i]);
! 789: pos = wa[i]->pos;
! 790: NEXT(m) = w[pos];
! 791: w[pos] = m;
! 792: }
! 793: nd = 0;
! 794: for ( i = n-1; i >= 0; i-- ) {
! 795: MKDP(nv,w[i],u); u->sugar = a->sugar; /* XXX */
! 796: dtop(CO,vl,u,&s);
! 797: MKNODE(nd1,s,nd); nd = nd1;
! 798: }
! 799: MKLIST(*rp,nd);
! 800: }
! 801:
! 802: void Pdp_dtop(NODE arg,Obj *rp)
! 803: {
! 804: NODE n;
! 805: VL vl,tvl;
! 806:
! 807: asir_assert(ARG0(arg),O_DP,"dp_dtop");
! 808: asir_assert(ARG1(arg),O_LIST,"dp_dtop");
! 809: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
! 810: if ( !vl ) {
! 811: NEWVL(vl); tvl = vl;
! 812: } else {
! 813: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
! 814: }
! 815: VR(tvl) = VR((P)BDY(n));
! 816: }
! 817: if ( vl )
! 818: NEXT(tvl) = 0;
! 819: dtop(CO,vl,(DP)ARG0(arg),rp);
! 820: }
! 821:
! 822: extern LIST Dist;
! 823:
! 824: void Pdp_ptozp(NODE arg,Obj *rp)
! 825: {
! 826: Z t;
! 827: NODE tt,p;
! 828: NODE n,n0;
! 829: char *key;
! 830: DP pp;
! 831: LIST list;
! 832: int get_factor=0;
! 833:
! 834: asir_assert(ARG0(arg),O_DP,"dp_ptozp");
! 835:
! 836: /* analyze the option */
! 837: if ( current_option ) {
! 838: for ( tt = current_option; tt; tt = NEXT(tt) ) {
! 839: p = BDY((LIST)BDY(tt));
! 840: key = BDY((STRING)BDY(p));
! 841: /* value = (Obj)BDY(NEXT(p)); */
! 842: if ( !strcmp(key,"factor") ) get_factor=1;
! 843: else {
! 844: error("ptozp: unknown option.");
! 845: }
! 846: }
! 847: }
! 848:
! 849: dp_ptozp3((DP)ARG0(arg),&t,&pp);
! 850:
! 851: /* printexpr(NULL,t); */
! 852: /* if the option factor is given, then it returns the answer
! 853: in the format [zpoly, num] where num*zpoly is equal to the argument.*/
! 854: if (get_factor) {
! 855: n0 = mknode(2,pp,t);
! 856: MKLIST(list,n0);
! 857: *rp = (Obj)list;
! 858: } else
! 859: *rp = (Obj)pp;
! 860: }
! 861:
! 862: void Pdp_ptozp2(NODE arg,LIST *rp)
! 863: {
! 864: DP p0,p1,h,r;
! 865: NODE n0;
! 866:
! 867: p0 = (DP)ARG0(arg); p1 = (DP)ARG1(arg);
! 868: asir_assert(p0,O_DP,"dp_ptozp2");
! 869: asir_assert(p1,O_DP,"dp_ptozp2");
! 870: dp_ptozp2(p0,p1,&h,&r);
! 871: NEWNODE(n0); BDY(n0) = (pointer)h;
! 872: NEWNODE(NEXT(n0)); BDY(NEXT(n0)) = (pointer)r;
! 873: NEXT(NEXT(n0)) = 0;
! 874: MKLIST(*rp,n0);
! 875: }
! 876:
! 877: void Pdp_prim(NODE arg,DP *rp)
! 878: {
! 879: DP t;
! 880:
! 881: asir_assert(ARG0(arg),O_DP,"dp_prim");
! 882: dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
! 883: }
! 884:
! 885: void Pdp_mod(NODE arg,DP *rp)
! 886: {
! 887: DP p;
! 888: int mod;
! 889: NODE subst;
! 890:
! 891: asir_assert(ARG0(arg),O_DP,"dp_mod");
! 892: asir_assert(ARG1(arg),O_N,"dp_mod");
! 893: asir_assert(ARG2(arg),O_LIST,"dp_mod");
! 894: p = (DP)ARG0(arg); mod = QTOS((Q)ARG1(arg));
! 895: subst = BDY((LIST)ARG2(arg));
! 896: dp_mod(p,mod,subst,rp);
! 897: }
! 898:
! 899: void Pdp_rat(NODE arg,DP *rp)
! 900: {
! 901: asir_assert(ARG0(arg),O_DP,"dp_rat");
! 902: dp_rat((DP)ARG0(arg),rp);
! 903: }
! 904:
! 905: extern int DP_Multiple;
! 906:
! 907: void Pdp_nf(NODE arg,DP *rp)
! 908: {
! 909: NODE b;
! 910: DP *ps;
! 911: DP g;
! 912: int full;
! 913:
! 914: do_weyl = 0; dp_fcoeffs = 0;
! 915: asir_assert(ARG0(arg),O_LIST,"dp_nf");
! 916: asir_assert(ARG1(arg),O_DP,"dp_nf");
! 917: asir_assert(ARG2(arg),O_VECT,"dp_nf");
! 918: asir_assert(ARG3(arg),O_N,"dp_nf");
! 919: if ( !(g = (DP)ARG1(arg)) ) {
! 920: *rp = 0; return;
! 921: }
! 922: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
! 923: full = (Q)ARG3(arg) ? 1 : 0;
! 924: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
! 925: }
! 926:
! 927: void Pdp_weyl_nf(NODE arg,DP *rp)
! 928: {
! 929: NODE b;
! 930: DP *ps;
! 931: DP g;
! 932: int full;
! 933:
! 934: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf");
! 935: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf");
! 936: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf");
! 937: asir_assert(ARG3(arg),O_N,"dp_weyl_nf");
! 938: if ( !(g = (DP)ARG1(arg)) ) {
! 939: *rp = 0; return;
! 940: }
! 941: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
! 942: full = (Q)ARG3(arg) ? 1 : 0;
! 943: do_weyl = 1;
! 944: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
! 945: do_weyl = 0;
! 946: }
! 947:
! 948: void Pdpm_nf(NODE arg,DPM *rp)
! 949: {
! 950: NODE b;
! 951: DPM *ps;
! 952: DPM g;
! 953: int full;
! 954:
! 955: if ( !(g = (DPM)ARG1(arg)) ) {
! 956: *rp = 0; return;
! 957: }
! 958: do_weyl = 0; dp_fcoeffs = 0;
! 959: asir_assert(ARG0(arg),O_LIST,"dpm_nf");
! 960: asir_assert(ARG1(arg),O_DPM,"dpm_nf");
! 961: asir_assert(ARG2(arg),O_VECT,"dpm_nf");
! 962: asir_assert(ARG3(arg),O_N,"dpm_nf");
! 963: b = BDY((LIST)ARG0(arg)); ps = (DPM *)BDY((VECT)ARG2(arg));
! 964: full = (Q)ARG3(arg) ? 1 : 0;
! 965: dpm_nf_z(b,g,ps,full,DP_Multiple,rp);
! 966: }
! 967:
! 968: void Pdpm_weyl_nf(NODE arg,DPM *rp)
! 969: {
! 970: NODE b;
! 971: DPM *ps;
! 972: DPM g;
! 973: int full;
! 974:
! 975: if ( !(g = (DPM)ARG1(arg)) ) {
! 976: *rp = 0; return;
! 977: }
! 978: asir_assert(ARG0(arg),O_LIST,"dpm_weyl_nf");
! 979: asir_assert(ARG1(arg),O_DPM,"dpm_weyl_nf");
! 980: asir_assert(ARG2(arg),O_VECT,"dpm_weyl_nf");
! 981: asir_assert(ARG3(arg),O_N,"dpm_weyl_nf");
! 982: b = BDY((LIST)ARG0(arg)); ps = (DPM *)BDY((VECT)ARG2(arg));
! 983: full = (Q)ARG3(arg) ? 1 : 0;
! 984: do_weyl = 1;
! 985: dpm_nf_z(b,g,ps,full,DP_Multiple,rp);
! 986: do_weyl = 0;
! 987: }
! 988:
! 989: /* nf computation using field operations */
! 990:
! 991: void Pdp_nf_f(NODE arg,DP *rp)
! 992: {
! 993: NODE b;
! 994: DP *ps;
! 995: DP g;
! 996: int full;
! 997:
! 998: do_weyl = 0;
! 999: asir_assert(ARG0(arg),O_LIST,"dp_nf_f");
! 1000: asir_assert(ARG1(arg),O_DP,"dp_nf_f");
! 1001: asir_assert(ARG2(arg),O_VECT,"dp_nf_f");
! 1002: asir_assert(ARG3(arg),O_N,"dp_nf_f");
! 1003: if ( !(g = (DP)ARG1(arg)) ) {
! 1004: *rp = 0; return;
! 1005: }
! 1006: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
! 1007: full = (Q)ARG3(arg) ? 1 : 0;
! 1008: dp_nf_f(b,g,ps,full,rp);
! 1009: }
! 1010:
! 1011: void Pdp_weyl_nf_f(NODE arg,DP *rp)
! 1012: {
! 1013: NODE b;
! 1014: DP *ps;
! 1015: DP g;
! 1016: int full;
! 1017:
! 1018: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_f");
! 1019: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_f");
! 1020: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_f");
! 1021: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_f");
! 1022: if ( !(g = (DP)ARG1(arg)) ) {
! 1023: *rp = 0; return;
! 1024: }
! 1025: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
! 1026: full = (Q)ARG3(arg) ? 1 : 0;
! 1027: do_weyl = 1;
! 1028: dp_nf_f(b,g,ps,full,rp);
! 1029: do_weyl = 0;
! 1030: }
! 1031:
! 1032: void Pdpm_nf_f(NODE arg,DPM *rp)
! 1033: {
! 1034: NODE b;
! 1035: DPM *ps;
! 1036: DPM g;
! 1037: int full;
! 1038:
! 1039: if ( !(g = (DPM)ARG1(arg)) ) {
! 1040: *rp = 0; return;
! 1041: }
! 1042: asir_assert(ARG0(arg),O_LIST,"dpm_nf_f");
! 1043: asir_assert(ARG1(arg),O_DPM,"dpm_nf_f");
! 1044: asir_assert(ARG2(arg),O_VECT,"dpm_nf_f");
! 1045: asir_assert(ARG3(arg),O_N,"dpm_nf_f");
! 1046: b = BDY((LIST)ARG0(arg)); ps = (DPM *)BDY((VECT)ARG2(arg));
! 1047: full = (Q)ARG3(arg) ? 1 : 0;
! 1048: dpm_nf_f(b,g,ps,full,rp);
! 1049: }
! 1050:
! 1051: void Pdpm_weyl_nf_f(NODE arg,DPM *rp)
! 1052: {
! 1053: NODE b;
! 1054: DPM *ps;
! 1055: DPM g;
! 1056: int full;
! 1057:
! 1058: if ( !(g = (DPM)ARG1(arg)) ) {
! 1059: *rp = 0; return;
! 1060: }
! 1061: asir_assert(ARG0(arg),O_LIST,"dpm_weyl_nf_f");
! 1062: asir_assert(ARG1(arg),O_DP,"dpm_weyl_nf_f");
! 1063: asir_assert(ARG2(arg),O_VECT,"dpm_weyl_nf_f");
! 1064: asir_assert(ARG3(arg),O_N,"dpm_weyl_nf_f");
! 1065: b = BDY((LIST)ARG0(arg)); ps = (DPM *)BDY((VECT)ARG2(arg));
! 1066: full = (Q)ARG3(arg) ? 1 : 0;
! 1067: do_weyl = 1;
! 1068: dpm_nf_f(b,g,ps,full,rp);
! 1069: do_weyl = 0;
! 1070: }
! 1071:
! 1072:
! 1073: void Pdp_nf_mod(NODE arg,DP *rp)
! 1074: {
! 1075: NODE b;
! 1076: DP g;
! 1077: DP *ps;
! 1078: int mod,full,ac;
! 1079: NODE n,n0;
! 1080:
! 1081: do_weyl = 0;
! 1082: ac = argc(arg);
! 1083: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
! 1084: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
! 1085: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
! 1086: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
! 1087: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
! 1088: if ( !(g = (DP)ARG1(arg)) ) {
! 1089: *rp = 0; return;
! 1090: }
! 1091: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
! 1092: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
! 1093: for ( n0 = n = 0; b; b = NEXT(b) ) {
! 1094: NEXTNODE(n0,n);
! 1095: BDY(n) = (pointer)QTOS((Q)BDY(b));
! 1096: }
! 1097: if ( n0 )
! 1098: NEXT(n) = 0;
! 1099: dp_nf_mod(n0,g,ps,mod,full,rp);
! 1100: }
! 1101:
! 1102: void Pdp_true_nf(NODE arg,LIST *rp)
! 1103: {
! 1104: NODE b,n;
! 1105: DP *ps;
! 1106: DP g;
! 1107: DP nm;
! 1108: P dn;
! 1109: int full;
! 1110:
! 1111: do_weyl = 0; dp_fcoeffs = 0;
! 1112: asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
! 1113: asir_assert(ARG1(arg),O_DP,"dp_true_nf");
! 1114: asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
! 1115: asir_assert(ARG3(arg),O_N,"dp_nf");
! 1116: if ( !(g = (DP)ARG1(arg)) ) {
! 1117: nm = 0; dn = (P)ONE;
! 1118: } else {
! 1119: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
! 1120: full = (Q)ARG3(arg) ? 1 : 0;
! 1121: dp_true_nf(b,g,ps,full,&nm,&dn);
! 1122: }
! 1123: NEWNODE(n); BDY(n) = (pointer)nm;
! 1124: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
! 1125: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
! 1126: }
! 1127:
! 1128: DP *dp_true_nf_and_quotient_marked(NODE b,DP g,DP *ps,DP *hps,DP *rp,P *dnp);
! 1129:
! 1130: void Pdp_true_nf_and_quotient_marked(NODE arg,LIST *rp)
! 1131: {
! 1132: NODE b,n;
! 1133: DP *ps,*hps;
! 1134: DP g;
! 1135: DP nm;
! 1136: VECT quo;
! 1137: P dn;
! 1138: int full;
! 1139:
! 1140: do_weyl = 0; dp_fcoeffs = 0;
! 1141: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_and_quotient_marked");
! 1142: asir_assert(ARG1(arg),O_DP,"dp_true_nf_and_quotient_marked");
! 1143: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_and_quotient_marked");
! 1144: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_and_quotient_marked");
! 1145: if ( !(g = (DP)ARG1(arg)) ) {
! 1146: nm = 0; dn = (P)ONE;
! 1147: } else {
! 1148: b = BDY((LIST)ARG0(arg));
! 1149: ps = (DP *)BDY((VECT)ARG2(arg));
! 1150: hps = (DP *)BDY((VECT)ARG3(arg));
! 1151: NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
! 1152: quo->body = (pointer *)dp_true_nf_and_quotient_marked(b,g,ps,hps,&nm,&dn);
! 1153: }
! 1154: n = mknode(3,nm,dn,quo);
! 1155: MKLIST(*rp,n);
! 1156: }
! 1157:
! 1158: void Pdp_true_nf_and_quotient(NODE arg,LIST *rp)
! 1159: {
! 1160: NODE narg = mknode(4,ARG0(arg),ARG1(arg),ARG2(arg),ARG2(arg));
! 1161: Pdp_true_nf_and_quotient_marked(narg,rp);
! 1162: }
! 1163:
! 1164:
! 1165: DP *dp_true_nf_and_quotient_marked_mod (NODE b,DP g,DP *ps,DP *hps,int mod,DP *rp,P *dnp);
! 1166:
! 1167: void Pdp_true_nf_and_quotient_marked_mod(NODE arg,LIST *rp)
! 1168: {
! 1169: NODE b,n;
! 1170: DP *ps,*hps;
! 1171: DP g;
! 1172: DP nm;
! 1173: VECT quo;
! 1174: P dn;
! 1175: int full,mod;
! 1176:
! 1177: do_weyl = 0; dp_fcoeffs = 0;
! 1178: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_and_quotient_marked_mod");
! 1179: asir_assert(ARG1(arg),O_DP,"dp_true_nf_and_quotient_marked_mod");
! 1180: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_and_quotient_marked_mod");
! 1181: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_and_quotient_marked_mod");
! 1182: asir_assert(ARG4(arg),O_N,"dp_true_nf_and_quotient_marked_mod");
! 1183: if ( !(g = (DP)ARG1(arg)) ) {
! 1184: nm = 0; dn = (P)ONE;
! 1185: } else {
! 1186: b = BDY((LIST)ARG0(arg));
! 1187: ps = (DP *)BDY((VECT)ARG2(arg));
! 1188: hps = (DP *)BDY((VECT)ARG3(arg));
! 1189: mod = QTOS((Q)ARG4(arg));
! 1190: NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
! 1191: quo->body = (pointer *)dp_true_nf_and_quotient_marked_mod(b,g,ps,hps,mod,&nm,&dn);
! 1192: }
! 1193: n = mknode(3,nm,dn,quo);
! 1194: MKLIST(*rp,n);
! 1195: }
! 1196:
! 1197: void Pdp_true_nf_and_quotient_mod(NODE arg,LIST *rp)
! 1198: {
! 1199: NODE narg = mknode(5,ARG0(arg),ARG1(arg),ARG2(arg),ARG2(arg),ARG3(arg));
! 1200: Pdp_true_nf_and_quotient_marked_mod(narg,rp);
! 1201: }
! 1202:
! 1203: void Pdp_true_nf_marked(NODE arg,LIST *rp)
! 1204: {
! 1205: NODE b,n;
! 1206: DP *ps,*hps;
! 1207: DP g;
! 1208: DP nm;
! 1209: Q cont;
! 1210: P dn;
! 1211: int full;
! 1212:
! 1213: do_weyl = 0; dp_fcoeffs = 0;
! 1214: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_marked");
! 1215: asir_assert(ARG1(arg),O_DP,"dp_true_nf_marked");
! 1216: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_marked");
! 1217: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_marked");
! 1218: if ( !(g = (DP)ARG1(arg)) ) {
! 1219: nm = 0; dn = (P)ONE;
! 1220: } else {
! 1221: b = BDY((LIST)ARG0(arg));
! 1222: ps = (DP *)BDY((VECT)ARG2(arg));
! 1223: hps = (DP *)BDY((VECT)ARG3(arg));
! 1224: dp_true_nf_marked(b,g,ps,hps,&nm,(P *)&cont,(P *)&dn);
! 1225: }
! 1226: n = mknode(3,nm,cont,dn);
! 1227: MKLIST(*rp,n);
! 1228: }
! 1229:
! 1230: void Pdp_true_nf_marked_mod(NODE arg,LIST *rp)
! 1231: {
! 1232: NODE b,n;
! 1233: DP *ps,*hps;
! 1234: DP g;
! 1235: DP nm;
! 1236: P dn;
! 1237: int mod;
! 1238:
! 1239: do_weyl = 0; dp_fcoeffs = 0;
! 1240: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_marked_mod");
! 1241: asir_assert(ARG1(arg),O_DP,"dp_true_nf_marked_mod");
! 1242: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_marked_mod");
! 1243: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_marked_mod");
! 1244: asir_assert(ARG4(arg),O_N,"dp_true_nf_marked_mod");
! 1245: if ( !(g = (DP)ARG1(arg)) ) {
! 1246: nm = 0; dn = (P)ONE;
! 1247: } else {
! 1248: b = BDY((LIST)ARG0(arg));
! 1249: ps = (DP *)BDY((VECT)ARG2(arg));
! 1250: hps = (DP *)BDY((VECT)ARG3(arg));
! 1251: mod = QTOS((Q)ARG4(arg));
! 1252: dp_true_nf_marked_mod(b,g,ps,hps,mod,&nm,&dn);
! 1253: }
! 1254: n = mknode(2,nm,dn);
! 1255: MKLIST(*rp,n);
! 1256: }
! 1257:
! 1258: void Pdp_weyl_nf_mod(NODE arg,DP *rp)
! 1259: {
! 1260: NODE b;
! 1261: DP g;
! 1262: DP *ps;
! 1263: int mod,full,ac;
! 1264: NODE n,n0;
! 1265:
! 1266: ac = argc(arg);
! 1267: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_mod");
! 1268: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_mod");
! 1269: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_mod");
! 1270: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_mod");
! 1271: asir_assert(ARG4(arg),O_N,"dp_weyl_nf_mod");
! 1272: if ( !(g = (DP)ARG1(arg)) ) {
! 1273: *rp = 0; return;
! 1274: }
! 1275: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
! 1276: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
! 1277: for ( n0 = n = 0; b; b = NEXT(b) ) {
! 1278: NEXTNODE(n0,n);
! 1279: BDY(n) = (pointer)QTOS((Q)BDY(b));
! 1280: }
! 1281: if ( n0 )
! 1282: NEXT(n) = 0;
! 1283: do_weyl = 1;
! 1284: dp_nf_mod(n0,g,ps,mod,full,rp);
! 1285: do_weyl = 0;
! 1286: }
! 1287:
! 1288: void Pdp_true_nf_mod(NODE arg,LIST *rp)
! 1289: {
! 1290: NODE b;
! 1291: DP g,nm;
! 1292: P dn;
! 1293: DP *ps;
! 1294: int mod,full;
! 1295: NODE n;
! 1296:
! 1297: do_weyl = 0;
! 1298: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
! 1299: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
! 1300: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
! 1301: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
! 1302: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
! 1303: if ( !(g = (DP)ARG1(arg)) ) {
! 1304: nm = 0; dn = (P)ONEM;
! 1305: } else {
! 1306: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
! 1307: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
! 1308: dp_true_nf_mod(b,g,ps,mod,full,&nm,&dn);
! 1309: }
! 1310: NEWNODE(n); BDY(n) = (pointer)nm;
! 1311: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
! 1312: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
! 1313: }
! 1314:
! 1315: void Pdp_weyl_true_nf_and_quotient_marked(NODE arg,LIST *rp)
! 1316: {
! 1317: NODE b,n;
! 1318: DP *ps,*hps;
! 1319: DP g;
! 1320: DP nm;
! 1321: VECT quo;
! 1322: P dn;
! 1323: int full;
! 1324:
! 1325: do_weyl = 1; dp_fcoeffs = 0;
! 1326: asir_assert(ARG0(arg),O_LIST,"dp_weyl_true_nf_and_quotient_marked");
! 1327: asir_assert(ARG1(arg),O_DP,"dp_weyl_true_nf_and_quotient_marked");
! 1328: asir_assert(ARG2(arg),O_VECT,"dp_weyl_true_nf_and_quotient_marked");
! 1329: asir_assert(ARG3(arg),O_VECT,"dp_weyl_true_nf_and_quotient_marked");
! 1330: if ( !(g = (DP)ARG1(arg)) ) {
! 1331: nm = 0; dn = (P)ONE;
! 1332: } else {
! 1333: b = BDY((LIST)ARG0(arg));
! 1334: ps = (DP *)BDY((VECT)ARG2(arg));
! 1335: hps = (DP *)BDY((VECT)ARG3(arg));
! 1336: NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
! 1337: quo->body = (pointer *)dp_true_nf_and_quotient_marked(b,g,ps,hps,&nm,&dn);
! 1338: }
! 1339: n = mknode(3,nm,dn,quo);
! 1340: MKLIST(*rp,n);
! 1341: }
! 1342:
! 1343: void Pdp_weyl_true_nf_and_quotient(NODE arg,LIST *rp)
! 1344: {
! 1345: NODE narg = mknode(4,ARG0(arg),ARG1(arg),ARG2(arg),ARG2(arg));
! 1346: Pdp_weyl_true_nf_and_quotient_marked(narg,rp);
! 1347: }
! 1348:
! 1349:
! 1350: void Pdp_weyl_true_nf_and_quotient_marked_mod(NODE arg,LIST *rp)
! 1351: {
! 1352: NODE b,n;
! 1353: DP *ps,*hps;
! 1354: DP g;
! 1355: DP nm;
! 1356: VECT quo;
! 1357: P dn;
! 1358: int full,mod;
! 1359:
! 1360: do_weyl = 1; dp_fcoeffs = 0;
! 1361: asir_assert(ARG0(arg),O_LIST,"dp_weyl_true_nf_and_quotient_marked_mod");
! 1362: asir_assert(ARG1(arg),O_DP,"dp_weyl_true_nf_and_quotient_marked_mod");
! 1363: asir_assert(ARG2(arg),O_VECT,"dp_weyl_true_nf_and_quotient_marked_mod");
! 1364: asir_assert(ARG3(arg),O_VECT,"dp_weyl_true_nf_and_quotient_marked_mod");
! 1365: asir_assert(ARG4(arg),O_N,"dp_weyl_true_nf_and_quotient_marked_mod");
! 1366: if ( !(g = (DP)ARG1(arg)) ) {
! 1367: nm = 0; dn = (P)ONE;
! 1368: } else {
! 1369: b = BDY((LIST)ARG0(arg));
! 1370: ps = (DP *)BDY((VECT)ARG2(arg));
! 1371: hps = (DP *)BDY((VECT)ARG3(arg));
! 1372: mod = QTOS((Q)ARG4(arg));
! 1373: NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
! 1374: quo->body = (pointer *)dp_true_nf_and_quotient_marked_mod(b,g,ps,hps,mod,&nm,&dn);
! 1375: }
! 1376: n = mknode(3,nm,dn,quo);
! 1377: MKLIST(*rp,n);
! 1378: }
! 1379:
! 1380: void Pdp_weyl_true_nf_and_quotient_mod(NODE arg,LIST *rp)
! 1381: {
! 1382: NODE narg = mknode(5,ARG0(arg),ARG1(arg),ARG2(arg),ARG2(arg),ARG3(arg));
! 1383: Pdp_weyl_true_nf_and_quotient_marked_mod(narg,rp);
! 1384: }
! 1385:
! 1386:
! 1387: void Pdp_tdiv(NODE arg,DP *rp)
! 1388: {
! 1389: MP m,mr,mr0;
! 1390: DP p;
! 1391: Z d,q,r;
! 1392: int sgn;
! 1393:
! 1394: asir_assert(ARG0(arg),O_DP,"dp_tdiv");
! 1395: asir_assert(ARG1(arg),O_N,"dp_tdiv");
! 1396: p = (DP)ARG0(arg); d = (Z)ARG1(arg);
! 1397: if ( !p )
! 1398: *rp = 0;
! 1399: else {
! 1400: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
! 1401: divqrz((Z)m->c,d,&q,&r);
! 1402: if ( r ) {
! 1403: *rp = 0; return;
! 1404: } else {
! 1405: NEXTMP(mr0,mr);
! 1406: mr->c = (Obj)q; mr->dl = m->dl;
! 1407: }
! 1408: }
! 1409: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
! 1410: }
! 1411: }
! 1412:
! 1413: void Pdp_red_coef(NODE arg,DP *rp)
! 1414: {
! 1415: MP m,mr,mr0;
! 1416: P q,r;
! 1417: DP p;
! 1418: P mod;
! 1419:
! 1420: p = (DP)ARG0(arg); mod = (P)ARG1(arg);
! 1421: asir_assert(p,O_DP,"dp_red_coef");
! 1422: asir_assert(mod,O_P,"dp_red_coef");
! 1423: if ( !p )
! 1424: *rp = 0;
! 1425: else {
! 1426: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
! 1427: divsrp(CO,(P)m->c,mod,&q,&r);
! 1428: if ( r ) {
! 1429: NEXTMP(mr0,mr); mr->c = (Obj)r; mr->dl = m->dl;
! 1430: }
! 1431: }
! 1432: if ( mr0 ) {
! 1433: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
! 1434: } else
! 1435: *rp = 0;
! 1436: }
! 1437: }
! 1438:
! 1439: void Pdp_redble(NODE arg,Z *rp)
! 1440: {
! 1441: asir_assert(ARG0(arg),O_DP,"dp_redble");
! 1442: asir_assert(ARG1(arg),O_DP,"dp_redble");
! 1443: if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
! 1444: *rp = ONE;
! 1445: else
! 1446: *rp = 0;
! 1447: }
! 1448:
! 1449: void Pdp_red_mod(NODE arg,LIST *rp)
! 1450: {
! 1451: DP h,r;
! 1452: P dmy;
! 1453: NODE n;
! 1454:
! 1455: do_weyl = 0;
! 1456: asir_assert(ARG0(arg),O_DP,"dp_red_mod");
! 1457: asir_assert(ARG1(arg),O_DP,"dp_red_mod");
! 1458: asir_assert(ARG2(arg),O_DP,"dp_red_mod");
! 1459: asir_assert(ARG3(arg),O_N,"dp_red_mod");
! 1460: dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),QTOS((Q)ARG3(arg)),
! 1461: &h,&r,&dmy);
! 1462: NEWNODE(n); BDY(n) = (pointer)h;
! 1463: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
! 1464: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
! 1465: }
! 1466:
! 1467: void Pdp_subd(NODE arg,DP *rp)
! 1468: {
! 1469: DP p1,p2;
! 1470:
! 1471: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1472: asir_assert(p1,O_DP,"dp_subd");
! 1473: asir_assert(p2,O_DP,"dp_subd");
! 1474: dp_subd(p1,p2,rp);
! 1475: }
! 1476:
! 1477: void Pdp_symb_add(NODE arg,DP *rp)
! 1478: {
! 1479: DP p1,p2,r;
! 1480: NODE s0;
! 1481: MP mp0,mp;
! 1482: int nv;
! 1483:
! 1484: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1485: asir_assert(p1,O_DP,"dp_symb_add");
! 1486: asir_assert(p2,O_DP,"dp_symb_add");
! 1487: if ( !p1 ) { *rp = p2; return; }
! 1488: else if ( !p2 ) { *rp = p1; return; }
! 1489: if ( p1->nv != p2->nv )
! 1490: error("dp_sumb_add : invalid input");
! 1491: nv = p1->nv;
! 1492: s0 = symb_merge(dp_dllist(p1),dp_dllist(p2),nv);
! 1493: for ( mp0 = 0; s0; s0 = NEXT(s0) ) {
! 1494: NEXTMP(mp0,mp); mp->dl = (DL)BDY(s0); mp->c = (Obj)ONE;
! 1495: }
! 1496: NEXT(mp) = 0;
! 1497: MKDP(nv,mp0,r); r->sugar = MAX(p1->sugar,p2->sugar);
! 1498: *rp = r;
! 1499: }
! 1500:
! 1501: void Pdp_mul_trunc(NODE arg,DP *rp)
! 1502: {
! 1503: DP p1,p2,p;
! 1504:
! 1505: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); p = (DP)ARG2(arg);
! 1506: asir_assert(p1,O_DP,"dp_mul_trunc");
! 1507: asir_assert(p2,O_DP,"dp_mul_trunc");
! 1508: asir_assert(p,O_DP,"dp_mul_trunc");
! 1509: comm_muld_trunc(CO,p1,p2,BDY(p)->dl,rp);
! 1510: }
! 1511:
! 1512: void Pdp_quo(NODE arg,DP *rp)
! 1513: {
! 1514: DP p1,p2;
! 1515:
! 1516: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1517: asir_assert(p1,O_DP,"dp_quo");
! 1518: asir_assert(p2,O_DP,"dp_quo");
! 1519: comm_quod(CO,p1,p2,rp);
! 1520: }
! 1521:
! 1522: void Pdp_weyl_mul(NODE arg,DP *rp)
! 1523: {
! 1524: DP p1,p2;
! 1525:
! 1526: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1527: asir_assert(p1,O_DP,"dp_weyl_mul"); asir_assert(p2,O_DP,"dp_weyl_mul");
! 1528: do_weyl = 1;
! 1529: muld(CO,p1,p2,rp);
! 1530: do_weyl = 0;
! 1531: }
! 1532:
! 1533: void Pdp_weyl_act(NODE arg,DP *rp)
! 1534: {
! 1535: DP p1,p2;
! 1536:
! 1537: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1538: asir_assert(p1,O_DP,"dp_weyl_act"); asir_assert(p2,O_DP,"dp_weyl_act");
! 1539: weyl_actd(CO,p1,p2,rp);
! 1540: }
! 1541:
! 1542:
! 1543: void Pdp_weyl_mul_mod(NODE arg,DP *rp)
! 1544: {
! 1545: DP p1,p2;
! 1546: Q m;
! 1547:
! 1548: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); m = (Q)ARG2(arg);
! 1549: asir_assert(p1,O_DP,"dp_weyl_mul_mod");
! 1550: asir_assert(p2,O_DP,"dp_mul_mod");
! 1551: asir_assert(m,O_N,"dp_mul_mod");
! 1552: do_weyl = 1;
! 1553: mulmd(CO,QTOS(m),p1,p2,rp);
! 1554: do_weyl = 0;
! 1555: }
! 1556:
! 1557: void Pdp_red(NODE arg,LIST *rp)
! 1558: {
! 1559: NODE n;
! 1560: DP head,rest,dmy1;
! 1561: P dmy;
! 1562:
! 1563: do_weyl = 0;
! 1564: asir_assert(ARG0(arg),O_DP,"dp_red");
! 1565: asir_assert(ARG1(arg),O_DP,"dp_red");
! 1566: asir_assert(ARG2(arg),O_DP,"dp_red");
! 1567: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
! 1568: NEWNODE(n); BDY(n) = (pointer)head;
! 1569: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
! 1570: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
! 1571: }
! 1572:
! 1573: void Pdp_weyl_red(NODE arg,LIST *rp)
! 1574: {
! 1575: NODE n;
! 1576: DP head,rest,dmy1;
! 1577: P dmy;
! 1578:
! 1579: asir_assert(ARG0(arg),O_DP,"dp_weyl_red");
! 1580: asir_assert(ARG1(arg),O_DP,"dp_weyl_red");
! 1581: asir_assert(ARG2(arg),O_DP,"dp_weyl_red");
! 1582: do_weyl = 1;
! 1583: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
! 1584: do_weyl = 0;
! 1585: NEWNODE(n); BDY(n) = (pointer)head;
! 1586: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
! 1587: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
! 1588: }
! 1589:
! 1590: void Pdp_sp(NODE arg,DP *rp)
! 1591: {
! 1592: DP p1,p2;
! 1593:
! 1594: do_weyl = 0;
! 1595: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1596: asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
! 1597: dp_sp(p1,p2,rp);
! 1598: }
! 1599:
! 1600: void Pdp_weyl_sp(NODE arg,DP *rp)
! 1601: {
! 1602: DP p1,p2;
! 1603:
! 1604: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1605: asir_assert(p1,O_DP,"dp_weyl_sp"); asir_assert(p2,O_DP,"dp_weyl_sp");
! 1606: do_weyl = 1;
! 1607: dp_sp(p1,p2,rp);
! 1608: do_weyl = 0;
! 1609: }
! 1610:
! 1611: void Pdpm_sp(NODE arg,DPM *rp)
! 1612: {
! 1613: DPM p1,p2;
! 1614:
! 1615: do_weyl = 0;
! 1616: p1 = (DPM)ARG0(arg); p2 = (DPM)ARG1(arg);
! 1617: asir_assert(p1,O_DPM,"dpm_sp"); asir_assert(p2,O_DPM,"dpm_sp");
! 1618: dpm_sp(p1,p2,rp);
! 1619: }
! 1620:
! 1621: void Pdpm_weyl_sp(NODE arg,DPM *rp)
! 1622: {
! 1623: DPM p1,p2;
! 1624:
! 1625: p1 = (DPM)ARG0(arg); p2 = (DPM)ARG1(arg);
! 1626: asir_assert(p1,O_DPM,"dpm_weyl_sp"); asir_assert(p2,O_DPM,"dpm_weyl_sp");
! 1627: do_weyl = 1;
! 1628: dpm_sp(p1,p2,rp);
! 1629: do_weyl = 0;
! 1630: }
! 1631:
! 1632: void Pdp_sp_mod(NODE arg,DP *rp)
! 1633: {
! 1634: DP p1,p2;
! 1635: int mod;
! 1636:
! 1637: do_weyl = 0;
! 1638: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1639: asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
! 1640: asir_assert(ARG2(arg),O_N,"dp_sp_mod");
! 1641: mod = QTOS((Q)ARG2(arg));
! 1642: dp_sp_mod(p1,p2,mod,rp);
! 1643: }
! 1644:
! 1645: void Pdp_lcm(NODE arg,DP *rp)
! 1646: {
! 1647: int i,n,td;
! 1648: DL d1,d2,d;
! 1649: MP m;
! 1650: DP p1,p2;
! 1651:
! 1652: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1653: asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
! 1654: n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
! 1655: NEWDL(d,n);
! 1656: for ( i = 0, td = 0; i < n; i++ ) {
! 1657: d->d[i] = MAX(d1->d[i],d2->d[i]); td += MUL_WEIGHT(d->d[i],i);
! 1658: }
! 1659: d->td = td;
! 1660: NEWMP(m); m->dl = d; m->c = (Obj)ONE; NEXT(m) = 0;
! 1661: MKDP(n,m,*rp); (*rp)->sugar = td; /* XXX */
! 1662: }
! 1663:
! 1664: void Pdp_hm(NODE arg,DP *rp)
! 1665: {
! 1666: DP p;
! 1667:
! 1668: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
! 1669: dp_hm(p,rp);
! 1670: }
! 1671:
! 1672: void Pdp_ht(NODE arg,DP *rp)
! 1673: {
! 1674: DP p;
! 1675: MP m,mr;
! 1676:
! 1677: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
! 1678: dp_ht(p,rp);
! 1679: }
! 1680:
! 1681: void Pdp_hc(NODE arg,Obj *rp)
! 1682: {
! 1683: asir_assert(ARG0(arg),O_DP,"dp_hc");
! 1684: if ( !ARG0(arg) )
! 1685: *rp = 0;
! 1686: else
! 1687: *rp = BDY((DP)ARG0(arg))->c;
! 1688: }
! 1689:
! 1690: void Pdp_rest(NODE arg,DP *rp)
! 1691: {
! 1692: asir_assert(ARG0(arg),O_DP,"dp_rest");
! 1693: if ( !ARG0(arg) )
! 1694: *rp = 0;
! 1695: else
! 1696: dp_rest((DP)ARG0(arg),rp);
! 1697: }
! 1698:
! 1699: void Pdp_td(NODE arg,Z *rp)
! 1700: {
! 1701: DP p;
! 1702:
! 1703: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
! 1704: if ( !p )
! 1705: *rp = 0;
! 1706: else
! 1707: STOQ(BDY(p)->dl->td,*rp);
! 1708: }
! 1709:
! 1710: void Pdp_sugar(NODE arg,Z *rp)
! 1711: {
! 1712: DP p;
! 1713:
! 1714: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
! 1715: if ( !p )
! 1716: *rp = 0;
! 1717: else
! 1718: STOQ(p->sugar,*rp);
! 1719: }
! 1720:
! 1721: void Pdp_initial_term(NODE arg,Obj *rp)
! 1722: {
! 1723: struct order_spec *ord;
! 1724: Num homo;
! 1725: int modular,is_list;
! 1726: LIST v,f,l,initiallist;
! 1727: NODE n;
! 1728:
! 1729: f = (LIST)ARG0(arg);
! 1730: if ( f && OID(f) == O_LIST )
! 1731: is_list = 1;
! 1732: else {
! 1733: n = mknode(1,f); MKLIST(l,n); f = l;
! 1734: is_list = 0;
! 1735: }
! 1736: if ( current_option ) {
! 1737: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
! 1738: initd(ord);
! 1739: } else
! 1740: ord = dp_current_spec;
! 1741: initiallist = dp_initial_term(f,ord);
! 1742: if ( !is_list )
! 1743: *rp = (Obj)BDY(BDY(initiallist));
! 1744: else
! 1745: *rp = (Obj)initiallist;
! 1746: }
! 1747:
! 1748: void Pdp_order(NODE arg,Obj *rp)
! 1749: {
! 1750: struct order_spec *ord;
! 1751: Num homo;
! 1752: int modular,is_list;
! 1753: LIST v,f,l,ordlist;
! 1754: NODE n;
! 1755:
! 1756: f = (LIST)ARG0(arg);
! 1757: if ( f && OID(f) == O_LIST )
! 1758: is_list = 1;
! 1759: else {
! 1760: n = mknode(1,f); MKLIST(l,n); f = l;
! 1761: is_list = 0;
! 1762: }
! 1763: if ( current_option ) {
! 1764: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
! 1765: initd(ord);
! 1766: } else
! 1767: ord = dp_current_spec;
! 1768: ordlist = dp_order(f,ord);
! 1769: if ( !is_list )
! 1770: *rp = (Obj)BDY(BDY(ordlist));
! 1771: else
! 1772: *rp = (Obj)ordlist;
! 1773: }
! 1774:
! 1775: void Pdp_set_sugar(NODE arg,Q *rp)
! 1776: {
! 1777: DP p;
! 1778: Q q;
! 1779: int i;
! 1780:
! 1781: p = (DP)ARG0(arg);
! 1782: q = (Q)ARG1(arg);
! 1783: if ( p && q) {
! 1784: asir_assert(p,O_DP,"dp_set_sugar");
! 1785: asir_assert(q,O_N, "dp_set_sugar");
! 1786: i = QTOS(q);
! 1787: if (p->sugar < i) {
! 1788: p->sugar = i;
! 1789: }
! 1790: }
! 1791: *rp = 0;
! 1792: }
! 1793:
! 1794: void Pdp_cri1(NODE arg,Z *rp)
! 1795: {
! 1796: DP p1,p2;
! 1797: int *d1,*d2;
! 1798: int i,n;
! 1799:
! 1800: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1801: asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
! 1802: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
! 1803: for ( i = 0; i < n; i++ )
! 1804: if ( d1[i] > d2[i] )
! 1805: break;
! 1806: *rp = i == n ? ONE : 0;
! 1807: }
! 1808:
! 1809: void Pdp_cri2(NODE arg,Z *rp)
! 1810: {
! 1811: DP p1,p2;
! 1812: int *d1,*d2;
! 1813: int i,n;
! 1814:
! 1815: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1816: asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
! 1817: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
! 1818: for ( i = 0; i < n; i++ )
! 1819: if ( MIN(d1[i],d2[i]) >= 1 )
! 1820: break;
! 1821: *rp = i == n ? ONE : 0;
! 1822: }
! 1823:
! 1824: void Pdp_minp(NODE arg,LIST *rp)
! 1825: {
! 1826: NODE tn,tn1,d,dd,dd0,p,tp;
! 1827: LIST l,minp;
! 1828: DP lcm,tlcm;
! 1829: int s,ts;
! 1830:
! 1831: asir_assert(ARG0(arg),O_LIST,"dp_minp");
! 1832: d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
! 1833: p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
! 1834: if ( !ARG1(arg) ) {
! 1835: s = QTOS((Q)BDY(p)); p = NEXT(p);
! 1836: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
! 1837: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
! 1838: tlcm = (DP)BDY(tp); tp = NEXT(tp);
! 1839: ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
! 1840: NEXTNODE(dd0,dd);
! 1841: if ( ts < s ) {
! 1842: BDY(dd) = (pointer)minp;
! 1843: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
! 1844: } else if ( ts == s ) {
! 1845: if ( compd(CO,lcm,tlcm) > 0 ) {
! 1846: BDY(dd) = (pointer)minp;
! 1847: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
! 1848: } else
! 1849: BDY(dd) = BDY(d);
! 1850: } else
! 1851: BDY(dd) = BDY(d);
! 1852: }
! 1853: } else {
! 1854: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
! 1855: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
! 1856: tlcm = (DP)BDY(tp);
! 1857: NEXTNODE(dd0,dd);
! 1858: if ( compd(CO,lcm,tlcm) > 0 ) {
! 1859: BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
! 1860: } else
! 1861: BDY(dd) = BDY(d);
! 1862: }
! 1863: }
! 1864: if ( dd0 )
! 1865: NEXT(dd) = 0;
! 1866: MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
! 1867: }
! 1868:
! 1869: void Pdp_criB(NODE arg,LIST *rp)
! 1870: {
! 1871: NODE d,ij,dd,ddd;
! 1872: int i,j,s,n;
! 1873: DP *ps;
! 1874: DL ts,ti,tj,lij,tdl;
! 1875:
! 1876: asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
! 1877: asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
! 1878: asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
! 1879: if ( !d )
! 1880: *rp = (LIST)ARG0(arg);
! 1881: else {
! 1882: ts = BDY(ps[s])->dl;
! 1883: n = ps[s]->nv;
! 1884: NEWDL(tdl,n);
! 1885: for ( dd = 0; d; d = NEXT(d) ) {
! 1886: ij = BDY((LIST)BDY(d));
! 1887: i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
! 1888: j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
! 1889: lij = BDY((DP)BDY(ij))->dl;
! 1890: ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
! 1891: if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
! 1892: || !dl_equal(n,lij,tdl)
! 1893: || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
! 1894: && dl_equal(n,tdl,lij))
! 1895: || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
! 1896: && dl_equal(n,tdl,lij)) ) {
! 1897: MKNODE(ddd,BDY(d),dd);
! 1898: dd = ddd;
! 1899: }
! 1900: }
! 1901: MKLIST(*rp,dd);
! 1902: }
! 1903: }
! 1904:
! 1905: void Pdp_nelim(NODE arg,Z *rp)
! 1906: {
! 1907: if ( arg ) {
! 1908: asir_assert(ARG0(arg),O_N,"dp_nelim");
! 1909: dp_nelim = QTOS((Q)ARG0(arg));
! 1910: }
! 1911: STOQ(dp_nelim,*rp);
! 1912: }
! 1913:
! 1914: void Pdp_mag(NODE arg,Z *rp)
! 1915: {
! 1916: DP p;
! 1917: int s;
! 1918: MP m;
! 1919:
! 1920: p = (DP)ARG0(arg);
! 1921: asir_assert(p,O_DP,"dp_mag");
! 1922: if ( !p )
! 1923: *rp = 0;
! 1924: else {
! 1925: for ( s = 0, m = BDY(p); m; m = NEXT(m) )
! 1926: s += p_mag((P)m->c);
! 1927: STOQ(s,*rp);
! 1928: }
! 1929: }
! 1930:
! 1931: /* kara_mag is no longer used. */
! 1932:
! 1933: void Pdp_set_kara(NODE arg,Z *rp)
! 1934: {
! 1935: *rp = 0;
! 1936: }
! 1937:
! 1938: void Pdp_homo(NODE arg,DP *rp)
! 1939: {
! 1940: asir_assert(ARG0(arg),O_DP,"dp_homo");
! 1941: dp_homo((DP)ARG0(arg),rp);
! 1942: }
! 1943:
! 1944: void Pdp_dehomo(NODE arg,DP *rp)
! 1945: {
! 1946: asir_assert(ARG0(arg),O_DP,"dp_dehomo");
! 1947: dp_dehomo((DP)ARG0(arg),rp);
! 1948: }
! 1949:
! 1950: void Pdp_gr_flags(NODE arg,LIST *rp)
! 1951: {
! 1952: Obj name,value;
! 1953: NODE n;
! 1954:
! 1955: if ( arg ) {
! 1956: asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
! 1957: n = BDY((LIST)ARG0(arg));
! 1958: while ( n ) {
! 1959: name = (Obj)BDY(n); n = NEXT(n);
! 1960: if ( !n )
! 1961: break;
! 1962: else {
! 1963: value = (Obj)BDY(n); n = NEXT(n);
! 1964: }
! 1965: dp_set_flag(name,value);
! 1966: }
! 1967: }
! 1968: dp_make_flaglist(rp);
! 1969: }
! 1970:
! 1971: extern int DP_Print, DP_PrintShort;
! 1972:
! 1973: void Pdp_gr_print(NODE arg,Z *rp)
! 1974: {
! 1975: Z q;
! 1976: int s;
! 1977:
! 1978: if ( arg ) {
! 1979: asir_assert(ARG0(arg),O_N,"dp_gr_print");
! 1980: q = (Z)ARG0(arg);
! 1981: s = QTOS(q);
! 1982: switch ( s ) {
! 1983: case 0:
! 1984: DP_Print = 0; DP_PrintShort = 0;
! 1985: break;
! 1986: case 1:
! 1987: DP_Print = 1;
! 1988: break;
! 1989: case 2:
! 1990: DP_Print = 0; DP_PrintShort = 1;
! 1991: break;
! 1992: default:
! 1993: DP_Print = s; DP_PrintShort = 0;
! 1994: break;
! 1995: }
! 1996: } else {
! 1997: if ( DP_Print ) {
! 1998: STOQ(1,q);
! 1999: } else if ( DP_PrintShort ) {
! 2000: STOQ(2,q);
! 2001: } else
! 2002: q = 0;
! 2003: }
! 2004: *rp = q;
! 2005: }
! 2006:
! 2007: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
! 2008: int *modular,struct order_spec **ord)
! 2009: {
! 2010: NODE t,p;
! 2011: Z m,z;
! 2012: char *key;
! 2013: Obj value,dmy;
! 2014: int ord_is_set = 0;
! 2015: int modular_is_set = 0;
! 2016: int homo_is_set = 0;
! 2017: VL vl,vl0;
! 2018: LIST vars;
! 2019: char xiname[BUFSIZ];
! 2020: NODE x0,x;
! 2021: DP d;
! 2022: P xi;
! 2023: int nv,i;
! 2024:
! 2025: /* extract vars */
! 2026: vars = 0;
! 2027: for ( t = opt; t; t = NEXT(t) ) {
! 2028: p = BDY((LIST)BDY(t));
! 2029: key = BDY((STRING)BDY(p));
! 2030: value = (Obj)BDY(NEXT(p));
! 2031: if ( !strcmp(key,"v") ) {
! 2032: /* variable list */
! 2033: vars = (LIST)value;
! 2034: break;
! 2035: }
! 2036: }
! 2037: if ( vars ) {
! 2038: *v = vars; pltovl(vars,&vl);
! 2039: } else {
! 2040: for ( t = BDY(f); t; t = NEXT(t) )
! 2041: if ( BDY(t) && OID((Obj)BDY(t))==O_DP )
! 2042: break;
! 2043: if ( t ) {
! 2044: /* f is DP list */
! 2045: /* create dummy var list */
! 2046: d = (DP)BDY(t);
! 2047: nv = NV(d);
! 2048: for ( i = 0, vl0 = 0, x0 = 0; i < nv; i++ ) {
! 2049: NEXTVL(vl0,vl);
! 2050: NEXTNODE(x0,x);
! 2051: sprintf(xiname,"x%d",i);
! 2052: makevar(xiname,&xi);
! 2053: x->body = (pointer)xi;
! 2054: vl->v = VR((P)xi);
! 2055: }
! 2056: if ( vl0 ) {
! 2057: NEXT(vl) = 0;
! 2058: NEXT(x) = 0;
! 2059: }
! 2060: MKLIST(vars,x0);
! 2061: *v = vars;
! 2062: vl = vl0;
! 2063: } else {
! 2064: get_vars((Obj)f,&vl); vltopl(vl,v);
! 2065: }
! 2066: }
! 2067:
! 2068: for ( t = opt; t; t = NEXT(t) ) {
! 2069: p = BDY((LIST)BDY(t));
! 2070: key = BDY((STRING)BDY(p));
! 2071: value = (Obj)BDY(NEXT(p));
! 2072: if ( !strcmp(key,"v") ) {
! 2073: /* variable list; ignore */
! 2074: } else if ( !strcmp(key,"order") ) {
! 2075: /* order spec */
! 2076: if ( !vl )
! 2077: error("parse_gr_option : variables must be specified");
! 2078: create_order_spec(vl,value,ord);
! 2079: ord_is_set = 1;
! 2080: } else if ( !strcmp(key,"block") ) {
! 2081: create_order_spec(0,value,ord);
! 2082: ord_is_set = 1;
! 2083: } else if ( !strcmp(key,"matrix") ) {
! 2084: create_order_spec(0,value,ord);
! 2085: ord_is_set = 1;
! 2086: } else if ( !strcmp(key,"sugarweight") ) {
! 2087: /* weight */
! 2088: Pdp_set_weight(NEXT(p),&dmy);
! 2089: } else if ( !strcmp(key,"homo") ) {
! 2090: *homo = (Num)value;
! 2091: homo_is_set = 1;
! 2092: } else if ( !strcmp(key,"trace") ) {
! 2093: m = (Z)value;
! 2094: STOQ(0x80000000,z);
! 2095: if ( !m )
! 2096: *modular = 0;
! 2097: else if ( cmpz(m,z) >= 0 )
! 2098: error("parse_gr_option : too large modulus");
! 2099: else
! 2100: *modular = QTOS(m);
! 2101: modular_is_set = 1;
! 2102: } else if ( !strcmp(key,"dp") ) {
! 2103: /* XXX : ignore */
! 2104: } else
! 2105: error("parse_gr_option : not implemented");
! 2106: }
! 2107: if ( !ord_is_set ) create_order_spec(0,0,ord);
! 2108: if ( !modular_is_set ) *modular = 0;
! 2109: if ( !homo_is_set ) *homo = 0;
! 2110: }
! 2111:
! 2112: void Pdp_gr_main(NODE arg,LIST *rp)
! 2113: {
! 2114: LIST f,v;
! 2115: VL vl;
! 2116: Num homo;
! 2117: Z m,z;
! 2118: int modular,ac;
! 2119: struct order_spec *ord;
! 2120:
! 2121: do_weyl = 0;
! 2122: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
! 2123: f = (LIST)ARG0(arg);
! 2124: f = remove_zero_from_list(f);
! 2125: if ( !BDY(f) ) {
! 2126: *rp = f; return;
! 2127: }
! 2128: if ( (ac = argc(arg)) == 5 ) {
! 2129: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
! 2130: asir_assert(ARG2(arg),O_N,"dp_gr_main");
! 2131: asir_assert(ARG3(arg),O_N,"dp_gr_main");
! 2132: v = (LIST)ARG1(arg);
! 2133: homo = (Num)ARG2(arg);
! 2134: m = (Z)ARG3(arg);
! 2135: STOQ(0x80000000,z);
! 2136: if ( !m )
! 2137: modular = 0;
! 2138: else if ( cmpz(m,z) >= 0 )
! 2139: error("dp_gr_main : too large modulus");
! 2140: else
! 2141: modular = QTOS(m);
! 2142: create_order_spec(0,ARG4(arg),&ord);
! 2143: } else if ( current_option )
! 2144: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
! 2145: else if ( ac == 1 )
! 2146: parse_gr_option(f,0,&v,&homo,&modular,&ord);
! 2147: else
! 2148: error("dp_gr_main : invalid argument");
! 2149: dp_gr_main(f,v,homo,modular,0,ord,rp);
! 2150: }
! 2151:
! 2152: void Pdp_interreduce(NODE arg,LIST *rp)
! 2153: {
! 2154: LIST f,v;
! 2155: VL vl;
! 2156: int ac;
! 2157: struct order_spec *ord;
! 2158:
! 2159: do_weyl = 0;
! 2160: asir_assert(ARG0(arg),O_LIST,"dp_interreduce");
! 2161: f = (LIST)ARG0(arg);
! 2162: f = remove_zero_from_list(f);
! 2163: if ( !BDY(f) ) {
! 2164: *rp = f; return;
! 2165: }
! 2166: if ( (ac = argc(arg)) == 3 ) {
! 2167: asir_assert(ARG1(arg),O_LIST,"dp_interreduce");
! 2168: v = (LIST)ARG1(arg);
! 2169: create_order_spec(0,ARG2(arg),&ord);
! 2170: }
! 2171: dp_interreduce(f,v,0,ord,rp);
! 2172: }
! 2173:
! 2174: void Pdp_gr_f_main(NODE arg,LIST *rp)
! 2175: {
! 2176: LIST f,v;
! 2177: Num homo;
! 2178: int m,field,t;
! 2179: struct order_spec *ord;
! 2180: NODE n;
! 2181:
! 2182: do_weyl = 0;
! 2183: asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
! 2184: asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
! 2185: asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
! 2186: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2187: f = remove_zero_from_list(f);
! 2188: if ( !BDY(f) ) {
! 2189: *rp = f; return;
! 2190: }
! 2191: homo = (Num)ARG2(arg);
! 2192: #if 0
! 2193: asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
! 2194: m = QTOS((Q)ARG3(arg));
! 2195: if ( m )
! 2196: error("dp_gr_f_main : trace lifting is not implemented yet");
! 2197: create_order_spec(0,ARG4(arg),&ord);
! 2198: #else
! 2199: m = 0;
! 2200: create_order_spec(0,ARG3(arg),&ord);
! 2201: #endif
! 2202: field = 0;
! 2203: for ( n = BDY(f); n; n = NEXT(n) ) {
! 2204: t = get_field_type(BDY(n));
! 2205: if ( !t )
! 2206: continue;
! 2207: if ( t < 0 )
! 2208: error("dp_gr_f_main : incosistent coefficients");
! 2209: if ( !field )
! 2210: field = t;
! 2211: else if ( t != field )
! 2212: error("dp_gr_f_main : incosistent coefficients");
! 2213: }
! 2214: dp_gr_main(f,v,homo,m?1:0,field,ord,rp);
! 2215: }
! 2216:
! 2217: void Pdp_f4_main(NODE arg,LIST *rp)
! 2218: {
! 2219: LIST f,v;
! 2220: struct order_spec *ord;
! 2221:
! 2222: do_weyl = 0;
! 2223: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
! 2224: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
! 2225: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2226: f = remove_zero_from_list(f);
! 2227: if ( !BDY(f) ) {
! 2228: *rp = f; return;
! 2229: }
! 2230: create_order_spec(0,ARG2(arg),&ord);
! 2231: dp_f4_main(f,v,ord,rp);
! 2232: }
! 2233:
! 2234: /* dp_gr_checklist(list of dp) */
! 2235:
! 2236: void Pdp_gr_checklist(NODE arg,LIST *rp)
! 2237: {
! 2238: VECT g;
! 2239: LIST dp;
! 2240: NODE r;
! 2241: int n;
! 2242:
! 2243: do_weyl = 0;
! 2244: asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
! 2245: asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
! 2246: n = QTOS((Q)ARG1(arg));
! 2247: gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
! 2248: r = mknode(2,g,dp);
! 2249: MKLIST(*rp,r);
! 2250: }
! 2251:
! 2252: void Pdp_f4_mod_main(NODE arg,LIST *rp)
! 2253: {
! 2254: LIST f,v;
! 2255: int m;
! 2256: struct order_spec *ord;
! 2257:
! 2258: do_weyl = 0;
! 2259: asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
! 2260: asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
! 2261: asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
! 2262: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
! 2263: f = remove_zero_from_list(f);
! 2264: if ( !BDY(f) ) {
! 2265: *rp = f; return;
! 2266: }
! 2267: if ( !m )
! 2268: error("dp_f4_mod_main : invalid argument");
! 2269: create_order_spec(0,ARG3(arg),&ord);
! 2270: dp_f4_mod_main(f,v,m,ord,rp);
! 2271: }
! 2272:
! 2273: void Pdp_gr_mod_main(NODE arg,LIST *rp)
! 2274: {
! 2275: LIST f,v;
! 2276: Num homo;
! 2277: int m;
! 2278: struct order_spec *ord;
! 2279:
! 2280: do_weyl = 0;
! 2281: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
! 2282: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
! 2283: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
! 2284: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
! 2285: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2286: f = remove_zero_from_list(f);
! 2287: if ( !BDY(f) ) {
! 2288: *rp = f; return;
! 2289: }
! 2290: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
! 2291: if ( !m )
! 2292: error("dp_gr_mod_main : invalid argument");
! 2293: create_order_spec(0,ARG4(arg),&ord);
! 2294: dp_gr_mod_main(f,v,homo,m,ord,rp);
! 2295: }
! 2296:
! 2297: void Psetmod_ff(NODE node, Obj *val);
! 2298:
! 2299: void Pnd_f4(NODE arg,LIST *rp)
! 2300: {
! 2301: LIST f,v;
! 2302: int m,homo,retdp,ac;
! 2303: Obj val;
! 2304: Z mq,z;
! 2305: Num nhomo;
! 2306: NODE node;
! 2307: struct order_spec *ord;
! 2308:
! 2309: do_weyl = 0;
! 2310: nd_rref2 = 0;
! 2311: retdp = 0;
! 2312: if ( (ac = argc(arg)) == 4 ) {
! 2313: asir_assert(ARG0(arg),O_LIST,"nd_f4");
! 2314: asir_assert(ARG1(arg),O_LIST,"nd_f4");
! 2315: asir_assert(ARG2(arg),O_N,"nd_f4");
! 2316: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2317: f = remove_zero_from_list(f);
! 2318: if ( !BDY(f) ) {
! 2319: *rp = f; return;
! 2320: }
! 2321: mq = (Z)ARG2(arg);
! 2322: STOQ((unsigned long)0x40000000,z);
! 2323: if ( cmpz(mq,z) >= 0 ) {
! 2324: node = mknode(1,mq);
! 2325: Psetmod_ff(node,&val);
! 2326: m = -2;
! 2327: } else
! 2328: m = QTOS(mq);
! 2329: create_order_spec(0,ARG3(arg),&ord);
! 2330: homo = 0;
! 2331: if ( get_opt("homo",&val) && val ) homo = 1;
! 2332: if ( get_opt("dp",&val) && val ) retdp = 1;
! 2333: if ( get_opt("rref2",&val) && val ) nd_rref2 = 1;
! 2334: } else if ( ac == 1 ) {
! 2335: f = (LIST)ARG0(arg);
! 2336: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
! 2337: homo = QTOS((Q)nhomo);
! 2338: if ( get_opt("dp",&val) && val ) retdp = 1;
! 2339: if ( get_opt("rref2",&val) && val ) nd_rref2 = 1;
! 2340: } else
! 2341: error("nd_f4 : invalid argument");
! 2342: nd_gr(f,v,m,homo,retdp,1,ord,rp);
! 2343: }
! 2344:
! 2345: void Pnd_gr(NODE arg,LIST *rp)
! 2346: {
! 2347: LIST f,v;
! 2348: int m,homo,retdp,ac;
! 2349: Obj val;
! 2350: Z mq,z;
! 2351: Num nhomo;
! 2352: NODE node;
! 2353: struct order_spec *ord;
! 2354:
! 2355: do_weyl = 0;
! 2356: retdp = 0;
! 2357: if ( (ac=argc(arg)) == 4 ) {
! 2358: asir_assert(ARG0(arg),O_LIST,"nd_gr");
! 2359: asir_assert(ARG1(arg),O_LIST,"nd_gr");
! 2360: asir_assert(ARG2(arg),O_N,"nd_gr");
! 2361: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2362: f = remove_zero_from_list(f);
! 2363: if ( !BDY(f) ) {
! 2364: *rp = f; return;
! 2365: }
! 2366: mq = (Z)ARG2(arg);
! 2367: STOQ(0x40000000,z);
! 2368: if ( cmpz(mq,z) >= 0 ) {
! 2369: node = mknode(1,mq);
! 2370: Psetmod_ff(node,&val);
! 2371: m = -2;
! 2372: } else
! 2373: m = QTOS(mq);
! 2374: create_order_spec(0,ARG3(arg),&ord);
! 2375: homo = 0;
! 2376: if ( get_opt("homo",&val) && val ) homo = 1;
! 2377: if ( get_opt("dp",&val) && val ) retdp = 1;
! 2378: } else if ( ac == 1 ) {
! 2379: f = (LIST)ARG0(arg);
! 2380: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
! 2381: homo = QTOS((Q)nhomo);
! 2382: if ( get_opt("dp",&val) && val ) retdp = 1;
! 2383: } else
! 2384: error("nd_gr : invalid argument");
! 2385: nd_gr(f,v,m,homo,retdp,0,ord,rp);
! 2386: }
! 2387:
! 2388: void Pnd_gr_postproc(NODE arg,LIST *rp)
! 2389: {
! 2390: LIST f,v;
! 2391: int m,do_check;
! 2392: Z mq,z;
! 2393: Obj val;
! 2394: NODE node;
! 2395: struct order_spec *ord;
! 2396:
! 2397: do_weyl = 0;
! 2398: asir_assert(ARG0(arg),O_LIST,"nd_gr");
! 2399: asir_assert(ARG1(arg),O_LIST,"nd_gr");
! 2400: asir_assert(ARG2(arg),O_N,"nd_gr");
! 2401: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2402: f = remove_zero_from_list(f);
! 2403: if ( !BDY(f) ) {
! 2404: *rp = f; return;
! 2405: }
! 2406: mq = (Z)ARG2(arg);
! 2407: STOQ(0x40000000,z);
! 2408: if ( cmpz(mq,z) >= 0 ) {
! 2409: node = mknode(1,mq);
! 2410: Psetmod_ff(node,&val);
! 2411: m = -2;
! 2412: } else
! 2413: m = QTOS(mq);
! 2414: create_order_spec(0,ARG3(arg),&ord);
! 2415: do_check = ARG4(arg) ? 1 : 0;
! 2416: nd_gr_postproc(f,v,m,ord,do_check,rp);
! 2417: }
! 2418:
! 2419: void Pnd_gr_recompute_trace(NODE arg,LIST *rp)
! 2420: {
! 2421: LIST f,v,tlist;
! 2422: int m;
! 2423: struct order_spec *ord;
! 2424:
! 2425: do_weyl = 0;
! 2426: asir_assert(ARG0(arg),O_LIST,"nd_gr_recompute_trace");
! 2427: asir_assert(ARG1(arg),O_LIST,"nd_gr_recompute_trace");
! 2428: asir_assert(ARG2(arg),O_N,"nd_gr_recompute_trace");
! 2429: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2430: m = QTOS((Q)ARG2(arg));
! 2431: create_order_spec(0,ARG3(arg),&ord);
! 2432: tlist = (LIST)ARG4(arg);
! 2433: nd_gr_recompute_trace(f,v,m,ord,tlist,rp);
! 2434: }
! 2435:
! 2436: Obj nd_btog_one(LIST f,LIST v,int m,struct order_spec *ord,LIST tlist,int pos);
! 2437: Obj nd_btog(LIST f,LIST v,int m,struct order_spec *ord,LIST tlist);
! 2438:
! 2439: void Pnd_btog(NODE arg,Obj *rp)
! 2440: {
! 2441: LIST f,v,tlist;
! 2442: Z mq,z;
! 2443: int m,ac,pos;
! 2444: struct order_spec *ord;
! 2445: NODE node;
! 2446: pointer val;
! 2447:
! 2448: do_weyl = 0;
! 2449: asir_assert(ARG0(arg),O_LIST,"nd_btog");
! 2450: asir_assert(ARG1(arg),O_LIST,"nd_btog");
! 2451: asir_assert(ARG2(arg),O_N,"nd_btog");
! 2452: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2453: mq = (Z)ARG2(arg);
! 2454: STOQ(0x40000000,z);
! 2455: if ( cmpz(mq,z) >= 0 ) {
! 2456: node = mknode(1,mq);
! 2457: Psetmod_ff(node,(Obj *)&val);
! 2458: m = -2;
! 2459: } else
! 2460: m = QTOS(mq);
! 2461: create_order_spec(0,ARG3(arg),&ord);
! 2462: tlist = (LIST)ARG4(arg);
! 2463: if ( (ac = argc(arg)) == 6 ) {
! 2464: asir_assert(ARG5(arg),O_N,"nd_btog");
! 2465: pos = QTOS((Q)ARG5(arg));
! 2466: *rp = nd_btog_one(f,v,m,ord,tlist,pos);
! 2467: } else if ( ac == 5 )
! 2468: *rp = nd_btog(f,v,m,ord,tlist);
! 2469: else
! 2470: error("nd_btog : argument mismatch");
! 2471: }
! 2472:
! 2473: void Pnd_weyl_gr_postproc(NODE arg,LIST *rp)
! 2474: {
! 2475: LIST f,v;
! 2476: int m,do_check;
! 2477: struct order_spec *ord;
! 2478:
! 2479: do_weyl = 1;
! 2480: asir_assert(ARG0(arg),O_LIST,"nd_gr");
! 2481: asir_assert(ARG1(arg),O_LIST,"nd_gr");
! 2482: asir_assert(ARG2(arg),O_N,"nd_gr");
! 2483: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2484: f = remove_zero_from_list(f);
! 2485: if ( !BDY(f) ) {
! 2486: *rp = f; do_weyl = 0; return;
! 2487: }
! 2488: m = QTOS((Q)ARG2(arg));
! 2489: create_order_spec(0,ARG3(arg),&ord);
! 2490: do_check = ARG4(arg) ? 1 : 0;
! 2491: nd_gr_postproc(f,v,m,ord,do_check,rp);
! 2492: do_weyl = 0;
! 2493: }
! 2494:
! 2495: void Pnd_gr_trace(NODE arg,LIST *rp)
! 2496: {
! 2497: LIST f,v;
! 2498: int m,homo,ac;
! 2499: Num nhomo;
! 2500: struct order_spec *ord;
! 2501:
! 2502: do_weyl = 0;
! 2503: if ( (ac = argc(arg)) == 5 ) {
! 2504: asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
! 2505: asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
! 2506: asir_assert(ARG2(arg),O_N,"nd_gr_trace");
! 2507: asir_assert(ARG3(arg),O_N,"nd_gr_trace");
! 2508: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2509: f = remove_zero_from_list(f);
! 2510: if ( !BDY(f) ) {
! 2511: *rp = f; return;
! 2512: }
! 2513: homo = QTOS((Q)ARG2(arg));
! 2514: m = QTOS((Q)ARG3(arg));
! 2515: create_order_spec(0,ARG4(arg),&ord);
! 2516: } else if ( ac == 1 ) {
! 2517: f = (LIST)ARG0(arg);
! 2518: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
! 2519: homo = QTOS((Q)nhomo);
! 2520: } else
! 2521: error("nd_gr_trace : invalid argument");
! 2522: nd_gr_trace(f,v,m,homo,0,ord,rp);
! 2523: }
! 2524:
! 2525: void Pnd_f4_trace(NODE arg,LIST *rp)
! 2526: {
! 2527: LIST f,v;
! 2528: int m,homo,ac;
! 2529: Num nhomo;
! 2530: struct order_spec *ord;
! 2531:
! 2532: do_weyl = 0;
! 2533: if ( (ac = argc(arg))==5 ) {
! 2534: asir_assert(ARG0(arg),O_LIST,"nd_f4_trace");
! 2535: asir_assert(ARG1(arg),O_LIST,"nd_f4_trace");
! 2536: asir_assert(ARG2(arg),O_N,"nd_f4_trace");
! 2537: asir_assert(ARG3(arg),O_N,"nd_f4_trace");
! 2538: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2539: f = remove_zero_from_list(f);
! 2540: if ( !BDY(f) ) {
! 2541: *rp = f; return;
! 2542: }
! 2543: homo = QTOS((Q)ARG2(arg));
! 2544: m = QTOS((Q)ARG3(arg));
! 2545: create_order_spec(0,ARG4(arg),&ord);
! 2546: } else if ( ac == 1 ) {
! 2547: f = (LIST)ARG0(arg);
! 2548: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
! 2549: homo = QTOS((Q)nhomo);
! 2550: } else
! 2551: error("nd_gr_trace : invalid argument");
! 2552: nd_gr_trace(f,v,m,homo,1,ord,rp);
! 2553: }
! 2554:
! 2555: void Pnd_weyl_gr(NODE arg,LIST *rp)
! 2556: {
! 2557: LIST f,v;
! 2558: int m,homo,retdp,ac;
! 2559: Obj val;
! 2560: Num nhomo;
! 2561: struct order_spec *ord;
! 2562:
! 2563: do_weyl = 1;
! 2564: retdp = 0;
! 2565: if ( (ac = argc(arg)) == 4 ) {
! 2566: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr");
! 2567: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr");
! 2568: asir_assert(ARG2(arg),O_N,"nd_weyl_gr");
! 2569: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2570: f = remove_zero_from_list(f);
! 2571: if ( !BDY(f) ) {
! 2572: *rp = f; do_weyl = 0; return;
! 2573: }
! 2574: m = QTOS((Q)ARG2(arg));
! 2575: create_order_spec(0,ARG3(arg),&ord);
! 2576: homo = 0;
! 2577: if ( get_opt("homo",&val) && val ) homo = 1;
! 2578: if ( get_opt("dp",&val) && val ) retdp = 1;
! 2579: } else if ( ac == 1 ) {
! 2580: f = (LIST)ARG0(arg);
! 2581: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
! 2582: homo = QTOS((Q)nhomo);
! 2583: if ( get_opt("dp",&val) && val ) retdp = 1;
! 2584: } else
! 2585: error("nd_weyl_gr : invalid argument");
! 2586: nd_gr(f,v,m,homo,retdp,0,ord,rp);
! 2587: do_weyl = 0;
! 2588: }
! 2589:
! 2590: void Pnd_weyl_gr_trace(NODE arg,LIST *rp)
! 2591: {
! 2592: LIST f,v;
! 2593: int m,homo,ac;
! 2594: Num nhomo;
! 2595: struct order_spec *ord;
! 2596:
! 2597: do_weyl = 1;
! 2598: if ( (ac = argc(arg)) == 5 ) {
! 2599: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr_trace");
! 2600: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr_trace");
! 2601: asir_assert(ARG2(arg),O_N,"nd_weyl_gr_trace");
! 2602: asir_assert(ARG3(arg),O_N,"nd_weyl_gr_trace");
! 2603: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2604: f = remove_zero_from_list(f);
! 2605: if ( !BDY(f) ) {
! 2606: *rp = f; do_weyl = 0; return;
! 2607: }
! 2608: homo = QTOS((Q)ARG2(arg));
! 2609: m = QTOS((Q)ARG3(arg));
! 2610: create_order_spec(0,ARG4(arg),&ord);
! 2611: } else if ( ac == 1 ) {
! 2612: f = (LIST)ARG0(arg);
! 2613: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
! 2614: homo = QTOS((Q)nhomo);
! 2615: } else
! 2616: error("nd_weyl_gr_trace : invalid argument");
! 2617: nd_gr_trace(f,v,m,homo,0,ord,rp);
! 2618: do_weyl = 0;
! 2619: }
! 2620:
! 2621: void Pnd_nf(NODE arg,Obj *rp)
! 2622: {
! 2623: Obj f;
! 2624: LIST g,v;
! 2625: struct order_spec *ord;
! 2626:
! 2627: do_weyl = 0;
! 2628: asir_assert(ARG1(arg),O_LIST,"nd_nf");
! 2629: asir_assert(ARG2(arg),O_LIST,"nd_nf");
! 2630: asir_assert(ARG4(arg),O_N,"nd_nf");
! 2631: f = (Obj)ARG0(arg);
! 2632: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
! 2633: if ( !BDY(g) ) {
! 2634: *rp = f; return;
! 2635: }
! 2636: v = (LIST)ARG2(arg);
! 2637: create_order_spec(0,ARG3(arg),&ord);
! 2638: nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),ord,rp);
! 2639: }
! 2640:
! 2641: void Pnd_weyl_nf(NODE arg,Obj *rp)
! 2642: {
! 2643: Obj f;
! 2644: LIST g,v;
! 2645: struct order_spec *ord;
! 2646:
! 2647: do_weyl = 1;
! 2648: asir_assert(ARG1(arg),O_LIST,"nd_weyl_nf");
! 2649: asir_assert(ARG2(arg),O_LIST,"nd_weyl_nf");
! 2650: asir_assert(ARG4(arg),O_N,"nd_weyl_nf");
! 2651: f = (Obj)ARG0(arg);
! 2652: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
! 2653: if ( !BDY(g) ) {
! 2654: *rp = f; return;
! 2655: }
! 2656: v = (LIST)ARG2(arg);
! 2657: create_order_spec(0,ARG3(arg),&ord);
! 2658: nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),ord,rp);
! 2659: }
! 2660:
! 2661: /* for Weyl algebra */
! 2662:
! 2663: void Pdp_weyl_gr_main(NODE arg,LIST *rp)
! 2664: {
! 2665: LIST f,v;
! 2666: Num homo;
! 2667: Z m,z;
! 2668: int modular,ac;
! 2669: struct order_spec *ord;
! 2670:
! 2671:
! 2672: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
! 2673: f = (LIST)ARG0(arg);
! 2674: f = remove_zero_from_list(f);
! 2675: if ( !BDY(f) ) {
! 2676: *rp = f; return;
! 2677: }
! 2678: if ( (ac = argc(arg)) == 5 ) {
! 2679: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
! 2680: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
! 2681: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
! 2682: v = (LIST)ARG1(arg);
! 2683: homo = (Num)ARG2(arg);
! 2684: m = (Z)ARG3(arg);
! 2685: STOQ(0x80000000,z);
! 2686: if ( !m )
! 2687: modular = 0;
! 2688: else if ( cmpz(m,z) >= 0 )
! 2689: error("dp_weyl_gr_main : too large modulus");
! 2690: else
! 2691: modular = QTOS(m);
! 2692: create_order_spec(0,ARG4(arg),&ord);
! 2693: } else if ( current_option )
! 2694: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
! 2695: else if ( ac == 1 )
! 2696: parse_gr_option(f,0,&v,&homo,&modular,&ord);
! 2697: else
! 2698: error("dp_weyl_gr_main : invalid argument");
! 2699: do_weyl = 1;
! 2700: dp_gr_main(f,v,homo,modular,0,ord,rp);
! 2701: do_weyl = 0;
! 2702: }
! 2703:
! 2704: void Pdp_weyl_gr_f_main(NODE arg,LIST *rp)
! 2705: {
! 2706: LIST f,v;
! 2707: Num homo;
! 2708: struct order_spec *ord;
! 2709:
! 2710: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
! 2711: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
! 2712: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
! 2713: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
! 2714: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2715: f = remove_zero_from_list(f);
! 2716: if ( !BDY(f) ) {
! 2717: *rp = f; return;
! 2718: }
! 2719: homo = (Num)ARG2(arg);
! 2720: create_order_spec(0,ARG3(arg),&ord);
! 2721: do_weyl = 1;
! 2722: dp_gr_main(f,v,homo,0,1,ord,rp);
! 2723: do_weyl = 0;
! 2724: }
! 2725:
! 2726: void Pdp_weyl_f4_main(NODE arg,LIST *rp)
! 2727: {
! 2728: LIST f,v;
! 2729: struct order_spec *ord;
! 2730:
! 2731: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
! 2732: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
! 2733: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2734: f = remove_zero_from_list(f);
! 2735: if ( !BDY(f) ) {
! 2736: *rp = f; return;
! 2737: }
! 2738: create_order_spec(0,ARG2(arg),&ord);
! 2739: do_weyl = 1;
! 2740: dp_f4_main(f,v,ord,rp);
! 2741: do_weyl = 0;
! 2742: }
! 2743:
! 2744: void Pdp_weyl_f4_mod_main(NODE arg,LIST *rp)
! 2745: {
! 2746: LIST f,v;
! 2747: int m;
! 2748: struct order_spec *ord;
! 2749:
! 2750: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
! 2751: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
! 2752: asir_assert(ARG2(arg),O_N,"dp_f4_main");
! 2753: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
! 2754: f = remove_zero_from_list(f);
! 2755: if ( !BDY(f) ) {
! 2756: *rp = f; return;
! 2757: }
! 2758: if ( !m )
! 2759: error("dp_weyl_f4_mod_main : invalid argument");
! 2760: create_order_spec(0,ARG3(arg),&ord);
! 2761: do_weyl = 1;
! 2762: dp_f4_mod_main(f,v,m,ord,rp);
! 2763: do_weyl = 0;
! 2764: }
! 2765:
! 2766: void Pdp_weyl_gr_mod_main(NODE arg,LIST *rp)
! 2767: {
! 2768: LIST f,v;
! 2769: Num homo;
! 2770: int m;
! 2771: struct order_spec *ord;
! 2772:
! 2773: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
! 2774: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
! 2775: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
! 2776: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
! 2777: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2778: f = remove_zero_from_list(f);
! 2779: if ( !BDY(f) ) {
! 2780: *rp = f; return;
! 2781: }
! 2782: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
! 2783: if ( !m )
! 2784: error("dp_weyl_gr_mod_main : invalid argument");
! 2785: create_order_spec(0,ARG4(arg),&ord);
! 2786: do_weyl = 1;
! 2787: dp_gr_mod_main(f,v,homo,m,ord,rp);
! 2788: do_weyl = 0;
! 2789: }
! 2790:
! 2791: VECT current_dl_weight_vector_obj;
! 2792: int *current_dl_weight_vector;
! 2793: int dp_negative_weight;
! 2794:
! 2795: void Pdp_set_weight(NODE arg,VECT *rp)
! 2796: {
! 2797: VECT v;
! 2798: int i,n;
! 2799: NODE node;
! 2800:
! 2801: if ( !arg )
! 2802: *rp = current_dl_weight_vector_obj;
! 2803: else if ( !ARG0(arg) ) {
! 2804: current_dl_weight_vector_obj = 0;
! 2805: current_dl_weight_vector = 0;
! 2806: dp_negative_weight = 0;
! 2807: *rp = 0;
! 2808: } else {
! 2809: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
! 2810: error("dp_set_weight : invalid argument");
! 2811: if ( OID(ARG0(arg)) == O_VECT )
! 2812: v = (VECT)ARG0(arg);
! 2813: else {
! 2814: node = (NODE)BDY((LIST)ARG0(arg));
! 2815: n = length(node);
! 2816: MKVECT(v,n);
! 2817: for ( i = 0; i < n; i++, node = NEXT(node) )
! 2818: BDY(v)[i] = BDY(node);
! 2819: }
! 2820: current_dl_weight_vector_obj = v;
! 2821: n = v->len;
! 2822: current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
! 2823: for ( i = 0; i < n; i++ )
! 2824: current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
! 2825: for ( i = 0; i < n; i++ )
! 2826: if ( current_dl_weight_vector[i] < 0 ) break;
! 2827: if ( i < n )
! 2828: dp_negative_weight = 1;
! 2829: else
! 2830: dp_negative_weight = 0;
! 2831: *rp = v;
! 2832: }
! 2833: }
! 2834:
! 2835: VECT current_module_weight_vector_obj;
! 2836: int *current_module_weight_vector;
! 2837:
! 2838: void Pdp_set_module_weight(NODE arg,VECT *rp)
! 2839: {
! 2840: VECT v;
! 2841: int i,n;
! 2842: NODE node;
! 2843:
! 2844: if ( !arg )
! 2845: *rp = current_module_weight_vector_obj;
! 2846: else if ( !ARG0(arg) ) {
! 2847: current_module_weight_vector_obj = 0;
! 2848: current_module_weight_vector = 0;
! 2849: *rp = 0;
! 2850: } else {
! 2851: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
! 2852: error("dp_module_set_weight : invalid argument");
! 2853: if ( OID(ARG0(arg)) == O_VECT )
! 2854: v = (VECT)ARG0(arg);
! 2855: else {
! 2856: node = (NODE)BDY((LIST)ARG0(arg));
! 2857: n = length(node);
! 2858: MKVECT(v,n);
! 2859: for ( i = 0; i < n; i++, node = NEXT(node) )
! 2860: BDY(v)[i] = BDY(node);
! 2861: }
! 2862: current_module_weight_vector_obj = v;
! 2863: n = v->len;
! 2864: current_module_weight_vector = (int *)CALLOC(n,sizeof(int));
! 2865: for ( i = 0; i < n; i++ )
! 2866: current_module_weight_vector[i] = QTOS((Q)v->body[i]);
! 2867: *rp = v;
! 2868: }
! 2869: }
! 2870:
! 2871: extern Obj current_top_weight;
! 2872: extern Obj nd_top_weight;
! 2873:
! 2874: void Pdp_set_top_weight(NODE arg,Obj *rp)
! 2875: {
! 2876: VECT v;
! 2877: MAT m;
! 2878: Obj obj;
! 2879: int i,j,n,id,row,col;
! 2880: Q *mi;
! 2881: NODE node;
! 2882:
! 2883: if ( !arg )
! 2884: *rp = current_top_weight;
! 2885: else if ( !ARG0(arg) ) {
! 2886: reset_top_weight();
! 2887: *rp = 0;
! 2888: } else {
! 2889: id = OID(ARG0(arg));
! 2890: if ( id != O_VECT && id != O_MAT && id != O_LIST )
! 2891: error("dp_set_top_weight : invalid argument");
! 2892: if ( id == O_LIST ) {
! 2893: node = (NODE)BDY((LIST)ARG0(arg));
! 2894: n = length(node);
! 2895: MKVECT(v,n);
! 2896: for ( i = 0; i < n; i++, node = NEXT(node) )
! 2897: BDY(v)[i] = BDY(node);
! 2898: obj = (Obj)v;
! 2899: } else
! 2900: obj = ARG0(arg);
! 2901: if ( OID(obj) == O_VECT ) {
! 2902: v = (VECT)obj;
! 2903: for ( i = 0; i < v->len; i++ )
! 2904: if ( !INT((Q)BDY(v)[i]) || sgnz((Z)BDY(v)[i]) < 0 )
! 2905: error("dp_set_top_weight : each element must be a non-negative integer");
! 2906: } else {
! 2907: m = (MAT)obj; row = m->row; col = m->col;
! 2908: for ( i = 0; i < row; i++ )
! 2909: for ( j = 0, mi = (Q *)BDY(m)[i]; j < col; j++ )
! 2910: if ( !INT((Q)mi[j]) || sgnz((Z)mi[j]) < 0 )
! 2911: error("dp_set_top_weight : each element must be a non-negative integer");
! 2912: }
! 2913: current_top_weight = obj;
! 2914: nd_top_weight = obj;
! 2915: *rp = current_top_weight;
! 2916: }
! 2917: }
! 2918:
! 2919: LIST get_denomlist();
! 2920:
! 2921: void Pdp_get_denomlist(LIST *rp)
! 2922: {
! 2923: *rp = get_denomlist();
! 2924: }
! 2925:
! 2926: static VECT current_weyl_weight_vector_obj;
! 2927: int *current_weyl_weight_vector;
! 2928:
! 2929: void Pdp_weyl_set_weight(NODE arg,VECT *rp)
! 2930: {
! 2931: VECT v;
! 2932: NODE node;
! 2933: int i,n;
! 2934:
! 2935: if ( !arg )
! 2936: *rp = current_weyl_weight_vector_obj;
! 2937: else if ( !ARG0(arg) ) {
! 2938: current_weyl_weight_vector_obj = 0;
! 2939: current_weyl_weight_vector = 0;
! 2940: *rp = 0;
! 2941: } else {
! 2942: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
! 2943: error("dp_weyl_set_weight : invalid argument");
! 2944: if ( OID(ARG0(arg)) == O_VECT )
! 2945: v = (VECT)ARG0(arg);
! 2946: else {
! 2947: node = (NODE)BDY((LIST)ARG0(arg));
! 2948: n = length(node);
! 2949: MKVECT(v,n);
! 2950: for ( i = 0; i < n; i++, node = NEXT(node) )
! 2951: BDY(v)[i] = BDY(node);
! 2952: }
! 2953: current_weyl_weight_vector_obj = v;
! 2954: n = v->len;
! 2955: current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
! 2956: for ( i = 0; i < n; i++ )
! 2957: current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
! 2958: *rp = v;
! 2959: }
! 2960: }
! 2961:
! 2962: NODE mono_raddec(NODE ideal);
! 2963:
! 2964: void Pdp_mono_raddec(NODE arg,LIST *rp)
! 2965: {
! 2966: NODE ideal,rd,t,t1,r,r1,u;
! 2967: VL vl0,vl;
! 2968: int nv,i,bpi;
! 2969: int *s;
! 2970: DP dp;
! 2971: P *v;
! 2972: LIST l;
! 2973:
! 2974: ideal = BDY((LIST)ARG0(arg));
! 2975: if ( !ideal ) *rp = (LIST)ARG0(arg);
! 2976: else {
! 2977: t = BDY((LIST)ARG1(arg));
! 2978: nv = length(t);
! 2979: v = (P *)MALLOC(nv*sizeof(P));
! 2980: for ( vl0 = 0, i = 0; t; t = NEXT(t), i++ ) {
! 2981: NEXTVL(vl0,vl); VR(vl) = VR((P)BDY(t));
! 2982: MKV(VR(vl),v[i]);
! 2983: }
! 2984: if ( vl0 ) NEXT(vl) = 0;
! 2985: for ( t = 0, r = ideal; r; r = NEXT(r) ) {
! 2986: ptod(CO,vl0,BDY(r),&dp); MKNODE(t1,dp,t); t = t1;
! 2987: }
! 2988: rd = mono_raddec(t);
! 2989: r = 0;
! 2990: bpi = (sizeof(int)/sizeof(char))*8;
! 2991: for ( u = rd; u; u = NEXT(u) ) {
! 2992: s = (int *)BDY(u);
! 2993: for ( i = nv-1, t = 0; i >= 0; i-- )
! 2994: if ( s[i/bpi]&(1<<(i%bpi)) ) {
! 2995: MKNODE(t1,v[i],t); t = t1;
! 2996: }
! 2997: MKLIST(l,t); MKNODE(r1,l,r); r = r1;
! 2998: }
! 2999: MKLIST(*rp,r);
! 3000: }
! 3001: }
! 3002:
! 3003: void Pdp_mono_reduce(NODE arg,LIST *rp)
! 3004: {
! 3005: NODE t,t0,t1,r0,r;
! 3006: int i,n;
! 3007: DP m;
! 3008: DP *a;
! 3009:
! 3010: t0 = BDY((LIST)ARG0(arg));
! 3011: t1 = BDY((LIST)ARG1(arg));
! 3012: n = length(t0);
! 3013: a = (DP *)MALLOC(n*sizeof(DP));
! 3014: for ( i = 0; i < n; i++, t0 = NEXT(t0) ) a[i] = (DP)BDY(t0);
! 3015: for ( t = t1; t; t = NEXT(t) ) {
! 3016: m = (DP)BDY(t);
! 3017: for ( i = 0; i < n; i++ )
! 3018: if ( a[i] && dp_redble(a[i],m) ) a[i] = 0;
! 3019: }
! 3020: for ( i = n-1, r0 = 0; i >= 0; i-- )
! 3021: if ( a[i] ) { NEXTNODE(r0,r); BDY(r) = a[i]; }
! 3022: if ( r0 ) NEXT(r) = 0;
! 3023: MKLIST(*rp,r0);
! 3024: }
! 3025:
! 3026: #define BLEN (8*sizeof(unsigned long))
! 3027:
! 3028: void showmat2(unsigned long **a,int row,int col)
! 3029: {
! 3030: int i,j;
! 3031:
! 3032: for ( i = 0; i < row; i++, putchar('\n') )
! 3033: for ( j = 0; j < col; j++ )
! 3034: if ( a[i][j/BLEN] & (1L<<(j%BLEN)) ) putchar('1');
! 3035: else putchar('0');
! 3036: }
! 3037:
! 3038: int rref2(unsigned long **a,int row,int col)
! 3039: {
! 3040: int i,j,k,l,s,wcol,wj;
! 3041: unsigned long bj;
! 3042: unsigned long *ai,*ak,*as,*t;
! 3043: int *pivot;
! 3044:
! 3045: wcol = (col+BLEN-1)/BLEN;
! 3046: pivot = (int *)MALLOC_ATOMIC(row*sizeof(int));
! 3047: i = 0;
! 3048: for ( j = 0; j < col; j++ ) {
! 3049: wj = j/BLEN; bj = 1L<<(j%BLEN);
! 3050: for ( k = i; k < row; k++ )
! 3051: if ( a[k][wj] & bj ) break;
! 3052: if ( k == row ) continue;
! 3053: pivot[i] = j;
! 3054: if ( k != i ) {
! 3055: t = a[i]; a[i] = a[k]; a[k] = t;
! 3056: }
! 3057: ai = a[i];
! 3058: for ( k = i+1; k < row; k++ ) {
! 3059: ak = a[k];
! 3060: if ( ak[wj] & bj ) {
! 3061: for ( l = wj; l < wcol; l++ )
! 3062: ak[l] ^= ai[l];
! 3063: }
! 3064: }
! 3065: i++;
! 3066: }
! 3067: for ( k = i-1; k >= 0; k-- ) {
! 3068: j = pivot[k]; wj = j/BLEN; bj = 1L<<(j%BLEN);
! 3069: ak = a[k];
! 3070: for ( s = 0; s < k; s++ ) {
! 3071: as = a[s];
! 3072: if ( as[wj] & bj ) {
! 3073: for ( l = wj; l < wcol; l++ )
! 3074: as[l] ^= ak[l];
! 3075: }
! 3076: }
! 3077: }
! 3078: return i;
! 3079: }
! 3080:
! 3081: void Pdp_rref2(NODE arg,VECT *rp)
! 3082: {
! 3083: VECT f,term,ret;
! 3084: int row,col,wcol,size,nv,i,j,rank,td;
! 3085: unsigned long **mat;
! 3086: unsigned long *v;
! 3087: DL d;
! 3088: DL *t;
! 3089: DP dp;
! 3090: MP m,m0;
! 3091:
! 3092: f = (VECT)ARG0(arg);
! 3093: row = f->len;
! 3094: term = (VECT)ARG1(arg);
! 3095: col = term->len;
! 3096: mat = (unsigned long **)MALLOC(row*sizeof(unsigned long *));
! 3097: size = sizeof(unsigned long)*((col+BLEN-1)/BLEN);
! 3098: nv = ((DP)term->body[0])->nv;
! 3099: t = (DL *)MALLOC(col*sizeof(DL));
! 3100: for ( i = 0; i < col; i++ ) t[i] = BDY((DP)BDY(term)[i])->dl;
! 3101: for ( i = 0; i < row; i++ ) {
! 3102: v = mat[i] = (unsigned long *)MALLOC_ATOMIC_IGNORE_OFF_PAGE(size);
! 3103: bzero(v,size);
! 3104: for ( j = 0, m = BDY((DP)BDY(f)[i]); m; m = NEXT(m) ) {
! 3105: d = m->dl;
! 3106: for ( ; !dl_equal(nv,d,t[j]); j++ );
! 3107: v[j/BLEN] |= 1L <<(j%BLEN);
! 3108: }
! 3109: }
! 3110: rank = rref2(mat,row,col);
! 3111: MKVECT(ret,rank);
! 3112: *rp = ret;
! 3113: for ( i = 0; i < rank; i++ ) {
! 3114: v = mat[i];
! 3115: m0 = 0;
! 3116: td = 0;
! 3117: for ( j = 0; j < col; j++ ) {
! 3118: if ( v[j/BLEN] & (1L<<(j%BLEN)) ) {
! 3119: NEXTMP(m0,m);
! 3120: m->dl = t[j];
! 3121: m->c = (Obj)ONE;
! 3122: td = MAX(td,m->dl->td);
! 3123: }
! 3124: }
! 3125: NEXT(m) = 0;
! 3126: MKDP(nv,m0,dp);
! 3127: dp->sugar = td;
! 3128: BDY(ret)[i] = (pointer)dp;
! 3129: }
! 3130: }
! 3131:
! 3132: #define HDL(f) (BDY(f)->dl)
! 3133:
! 3134: NODE sumi_criB(int nv,NODE d,DP *f,int m)
! 3135: {
! 3136: LIST p;
! 3137: NODE r0,r;
! 3138: int p0,p1;
! 3139: DL p2,lcm;
! 3140:
! 3141: NEWDL(lcm,nv);
! 3142: r0 = 0;
! 3143: for ( ; d; d = NEXT(d) ) {
! 3144: p = (LIST)BDY(d);
! 3145: p0 = QTOS((Q)ARG0(BDY(p)));
! 3146: p1 = QTOS((Q)ARG1(BDY(p)));
! 3147: p2 = HDL((DP)ARG2(BDY(p)));
! 3148: if(!_dl_redble(HDL((DP)f[m]),p2,nv) ||
! 3149: dl_equal(nv,lcm_of_DL(nv,HDL(f[p0]),HDL(f[m]),lcm),p2) ||
! 3150: dl_equal(nv,lcm_of_DL(nv,HDL(f[p1]),HDL(f[m]),lcm),p2) ) {
! 3151: NEXTNODE(r0,r);
! 3152: BDY(r) = p;
! 3153: }
! 3154: }
! 3155: if ( r0 ) NEXT(r) = 0;
! 3156: return r0;
! 3157: }
! 3158:
! 3159: NODE sumi_criFMD(int nv,DP *f,int m)
! 3160: {
! 3161: DL *a;
! 3162: DL l1,dl1,dl2;
! 3163: int i,j,k,k2;
! 3164: NODE r,r1,nd;
! 3165: MP mp;
! 3166: DP u;
! 3167: Z iq,mq;
! 3168: LIST list;
! 3169:
! 3170: /* a[i] = lcm(LT(f[i]),LT(f[m])) */
! 3171: a = (DL *)ALLOCA(m*sizeof(DL));
! 3172: for ( i = 0; i < m; i++ ) {
! 3173: a[i] = lcm_of_DL(nv,HDL(f[i]),HDL(f[m]),0);
! 3174: }
! 3175: r = 0;
! 3176: for( i = 0; i < m; i++) {
! 3177: l1 = a[i];
! 3178: if ( !l1 ) continue;
! 3179: /* Tkm = Tim (k<i) */
! 3180: for( k = 0; k < i; k++)
! 3181: if( dl_equal(nv,l1,a[k]) ) break;
! 3182: if( k == i ){
! 3183: /* Tk|Tim && Tkm != Tim (k<m) */
! 3184: for ( k2 = 0; k2 < m; k2++ )
! 3185: if ( _dl_redble(HDL(f[k2]),l1,nv) &&
! 3186: !dl_equal(nv,l1,a[k2]) ) break;
! 3187: if ( k2 == m ) {
! 3188: dl1 = HDL(f[i]); dl2 = HDL(f[m]);
! 3189: for ( k2 = 0; k2 < nv; k2++ )
! 3190: if ( dl1->d[k2] && dl2->d[k2] ) break;
! 3191: if ( k2 < nv ) {
! 3192: NEWMP(mp); mp->dl = l1; C(mp) = (Obj)ONE;
! 3193: NEXT(mp) = 0; MKDP(nv,mp,u); u->sugar = l1->td;
! 3194: STOQ(i,iq); STOQ(m,mq);
! 3195: nd = mknode(3,iq,mq,u);
! 3196: MKLIST(list,nd);
! 3197: MKNODE(r1,list,r);
! 3198: r = r1;
! 3199: }
! 3200: }
! 3201: }
! 3202: }
! 3203: return r;
! 3204: }
! 3205:
! 3206: LIST sumi_updatepairs(LIST d,DP *f,int m)
! 3207: {
! 3208: NODE old,new,t;
! 3209: LIST l;
! 3210: int nv;
! 3211:
! 3212: nv = f[0]->nv;
! 3213: old = sumi_criB(nv,BDY(d),f,m);
! 3214: new = sumi_criFMD(nv,f,m);
! 3215: if ( !new ) new = old;
! 3216: else {
! 3217: for ( t = new ; NEXT(t); t = NEXT(t) );
! 3218: NEXT(t) = old;
! 3219: }
! 3220: MKLIST(l,new);
! 3221: return l;
! 3222: }
! 3223:
! 3224: VECT ltov(LIST l)
! 3225: {
! 3226: NODE n;
! 3227: int i,len;
! 3228: VECT v;
! 3229:
! 3230: n = BDY(l);
! 3231: len = length(n);
! 3232: MKVECT(v,len);
! 3233: for ( i = 0; i < len; i++, n = NEXT(n) )
! 3234: BDY(v)[i] = BDY(n);
! 3235: return v;
! 3236: }
! 3237:
! 3238: DL subdl(int nv,DL d1,DL d2)
! 3239: {
! 3240: int i;
! 3241: DL d;
! 3242:
! 3243: NEWDL(d,nv);
! 3244: d->td = d1->td-d2->td;
! 3245: for ( i = 0; i < nv; i++ )
! 3246: d->d[i] = d1->d[i]-d2->d[i];
! 3247: return d;
! 3248: }
! 3249:
! 3250: DP dltodp(int nv,DL d)
! 3251: {
! 3252: MP mp;
! 3253: DP dp;
! 3254:
! 3255: NEWMP(mp); mp->dl = d; C(mp) = (Obj)ONE;
! 3256: NEXT(mp) = 0; MKDP(nv,mp,dp); dp->sugar = d->td;
! 3257: return dp;
! 3258: }
! 3259:
! 3260: LIST sumi_simplify(int nv,DL t,DP p,NODE f2,int simp)
! 3261: {
! 3262: DL d,h,hw;
! 3263: DP u,w,dp;
! 3264: int n,i,last;
! 3265: LIST *v;
! 3266: LIST list;
! 3267: NODE s,r;
! 3268:
! 3269: d = t; u = p;
! 3270: /* only the last history is used */
! 3271: if ( f2 && simp && t->td != 0 ) {
! 3272: adddl(nv,t,HDL(p),&h);
! 3273: n = length(f2);
! 3274: last = 1;
! 3275: if ( simp > 1 ) last = n;
! 3276: v = (LIST *)ALLOCA(n*sizeof(LIST));
! 3277: for ( r = f2, i = 0; r; r = NEXT(r), i++ ) v[n-i-1] = BDY(r);
! 3278: for ( i = 0; i < last; i++ ) {
! 3279: for ( s = BDY((LIST)v[i]); s; s = NEXT(s) ) {
! 3280: w = (DP)BDY(s); hw = HDL(w);
! 3281: if ( _dl_redble(hw,h,nv) ) {
! 3282: u = w;
! 3283: d = subdl(nv,h,hw);
! 3284: goto fin;
! 3285: }
! 3286: }
! 3287: }
! 3288: }
! 3289: fin:
! 3290: dp = dltodp(nv,d);
! 3291: r = mknode(2,dp,u);
! 3292: MKLIST(list,r);
! 3293: return list;
! 3294: }
! 3295:
! 3296: LIST sumi_symbolic(NODE l,int q,NODE f2,DP *g,int simp)
! 3297: {
! 3298: int nv;
! 3299: NODE t,r;
! 3300: NODE f0,f,fd0,fd,done0,done,red0,red;
! 3301: DL h,d;
! 3302: DP mul;
! 3303: int m;
! 3304: LIST tp,l0,l1,l2,l3,list;
! 3305: VECT v0,v1,v2,v3;
! 3306:
! 3307: nv = ((DP)BDY(l))->nv;
! 3308: t = 0;
! 3309:
! 3310: f0 = 0; fd0 = 0; done0 = 0; red0 = 0;
! 3311:
! 3312: for ( ; l; l = NEXT(l) ) {
! 3313: t = symb_merge(t,dp_dllist((DP)BDY(l)),nv);
! 3314: NEXTNODE(fd0,fd); BDY(fd) = BDY(l);
! 3315: }
! 3316:
! 3317: while ( t ) {
! 3318: h = (DL)BDY(t);
! 3319: NEXTNODE(done0,done); BDY(done) = dltodp(nv,h);
! 3320: t = NEXT(t);
! 3321: for(m = 0; m < q; m++)
! 3322: if ( _dl_redble(HDL(g[m]),h,nv) ) break;
! 3323: if ( m == q ) {
! 3324: } else {
! 3325: d = subdl(nv,h,HDL(g[m]));
! 3326: tp = sumi_simplify(nv,d,g[m],f2,simp);
! 3327:
! 3328: muldm(CO,ARG1(BDY(tp)),BDY((DP)ARG0(BDY(tp))),&mul);
! 3329: t = symb_merge(t,NEXT(dp_dllist(mul)),nv);
! 3330:
! 3331: NEXTNODE(f0,f); BDY(f) = tp;
! 3332: NEXTNODE(fd0,fd); BDY(fd) = mul;
! 3333: NEXTNODE(red0,red); BDY(red) = mul;
! 3334: }
! 3335: }
! 3336: if ( fd0 ) NEXT(fd) = 0; MKLIST(l0,fd0);
! 3337: v0 = ltov(l0);
! 3338: if ( done0 ) NEXT(done) = 0; MKLIST(l1,done0);
! 3339: v1 = ltov(l1);
! 3340: if ( f0 ) NEXT(f) = 0; MKLIST(l2,f0);
! 3341: v2 = ltov(l2);
! 3342: if ( red0 ) NEXT(red) = 0; MKLIST(l3,red0);
! 3343: v3 = ltov(l3);
! 3344: r = mknode(4,v0,v1,v2,v3);
! 3345: MKLIST(list,r);
! 3346: return list;
! 3347: }
! 3348:
! 3349: void Psumi_symbolic(NODE arg,LIST *rp)
! 3350: {
! 3351: NODE l,f2;
! 3352: DP *g;
! 3353: int q,simp;
! 3354:
! 3355: l = BDY((LIST)ARG0(arg));
! 3356: q = QTOS((Q)ARG1(arg));
! 3357: f2 = BDY((LIST)ARG2(arg));
! 3358: g = (DP *)BDY((VECT)ARG3(arg));
! 3359: simp = QTOS((Q)ARG4(arg));
! 3360: *rp = sumi_symbolic(l,q,f2,g,simp);
! 3361: }
! 3362:
! 3363: void Psumi_updatepairs(NODE arg,LIST *rp)
! 3364: {
! 3365: LIST d,l;
! 3366: DP *f;
! 3367: int m;
! 3368:
! 3369: d = (LIST)ARG0(arg);
! 3370: f = (DP *)BDY((VECT)ARG1(arg));
! 3371: m = QTOS((Q)ARG2(arg));
! 3372: *rp = sumi_updatepairs(d,f,m);
! 3373: }
! 3374:
! 3375: LIST remove_zero_from_list(LIST l)
! 3376: {
! 3377: NODE n,r0,r;
! 3378: LIST rl;
! 3379:
! 3380: asir_assert(l,O_LIST,"remove_zero_from_list");
! 3381: n = BDY(l);
! 3382: for ( r0 = 0; n; n = NEXT(n) )
! 3383: if ( BDY(n) ) {
! 3384: NEXTNODE(r0,r);
! 3385: BDY(r) = BDY(n);
! 3386: }
! 3387: if ( r0 )
! 3388: NEXT(r) = 0;
! 3389: MKLIST(rl,r0);
! 3390: return rl;
! 3391: }
! 3392:
! 3393: int get_field_type(P p)
! 3394: {
! 3395: int type,t;
! 3396: DCP dc;
! 3397:
! 3398: if ( !p )
! 3399: return 0;
! 3400: else if ( NUM(p) )
! 3401: return NID((Num)p);
! 3402: else {
! 3403: type = 0;
! 3404: for ( dc = DC(p); dc; dc = NEXT(dc) ) {
! 3405: t = get_field_type(COEF(dc));
! 3406: if ( !t )
! 3407: continue;
! 3408: if ( t < 0 )
! 3409: return t;
! 3410: if ( !type )
! 3411: type = t;
! 3412: else if ( t != type )
! 3413: return -1;
! 3414: }
! 3415: return type;
! 3416: }
! 3417: }
! 3418:
! 3419: void Pdpv_ord(NODE arg,Obj *rp)
! 3420: {
! 3421: int ac,id;
! 3422: LIST shift;
! 3423:
! 3424: ac = argc(arg);
! 3425: if ( ac ) {
! 3426: id = QTOS((Q)ARG0(arg));
! 3427: if ( ac > 1 && ARG1(arg) && OID((Obj)ARG1(arg))==O_LIST )
! 3428: shift = (LIST)ARG1(arg);
! 3429: else
! 3430: shift = 0;
! 3431: create_modorder_spec(id,shift,&dp_current_modspec);
! 3432: }
! 3433: *rp = dp_current_modspec->obj;
! 3434: }
! 3435:
! 3436: extern int dpm_ispot;
! 3437:
! 3438: void Pdpm_ord(NODE arg,LIST *rp)
! 3439: {
! 3440: Z q;
! 3441: NODE nd;
! 3442: struct order_spec *spec;
! 3443:
! 3444: if ( arg ) {
! 3445: nd = BDY((LIST)ARG0(arg));
! 3446: if ( !create_order_spec(0,(Obj)ARG1(nd),&spec) )
! 3447: error("dpm_ord : invalid order specification");
! 3448: initdpm(spec,QTOS((Q)ARG0(nd)));
! 3449: }
! 3450: STOQ(dpm_ispot,q);
! 3451: nd = mknode(2,q,dp_current_spec->obj);
! 3452: MKLIST(*rp,nd);
! 3453: }
! 3454:
! 3455: void Pdpm_hm(NODE arg,DPM *rp)
! 3456: {
! 3457: DPM p;
! 3458:
! 3459: p = (DPM)ARG0(arg); asir_assert(p,O_DPM,"dpm_hm");
! 3460: dpm_hm(p,rp);
! 3461: }
! 3462:
! 3463: void Pdpm_ht(NODE arg,DPM *rp)
! 3464: {
! 3465: DPM p;
! 3466:
! 3467: p = (DPM)ARG0(arg); asir_assert(p,O_DPM,"dp_ht");
! 3468: dpm_ht(p,rp);
! 3469: }
! 3470:
! 3471: void Pdpm_hc(NODE arg,Obj *rp)
! 3472: {
! 3473: asir_assert(ARG0(arg),O_DPM,"dpm_hc");
! 3474: if ( !ARG0(arg) )
! 3475: *rp = 0;
! 3476: else
! 3477: *rp = BDY((DPM)ARG0(arg))->c;
! 3478: }
! 3479:
! 3480:
! 3481: void Pdpv_ht(NODE arg,LIST *rp)
! 3482: {
! 3483: NODE n;
! 3484: DP ht;
! 3485: int pos;
! 3486: DPV p;
! 3487: Z q;
! 3488:
! 3489: asir_assert(ARG0(arg),O_DPV,"dpv_ht");
! 3490: p = (DPV)ARG0(arg);
! 3491: pos = dpv_hp(p);
! 3492: if ( pos < 0 )
! 3493: ht = 0;
! 3494: else
! 3495: dp_ht(BDY(p)[pos],&ht);
! 3496: STOQ(pos,q);
! 3497: n = mknode(2,q,ht);
! 3498: MKLIST(*rp,n);
! 3499: }
! 3500:
! 3501: void Pdpv_hm(NODE arg,LIST *rp)
! 3502: {
! 3503: NODE n;
! 3504: DP ht;
! 3505: int pos;
! 3506: DPV p;
! 3507: Z q;
! 3508:
! 3509: asir_assert(ARG0(arg),O_DPV,"dpv_hm");
! 3510: p = (DPV)ARG0(arg);
! 3511: pos = dpv_hp(p);
! 3512: if ( pos < 0 )
! 3513: ht = 0;
! 3514: else
! 3515: dp_hm(BDY(p)[pos],&ht);
! 3516: STOQ(pos,q);
! 3517: n = mknode(2,q,ht);
! 3518: MKLIST(*rp,n);
! 3519: }
! 3520:
! 3521: void Pdpv_hc(NODE arg,LIST *rp)
! 3522: {
! 3523: NODE n;
! 3524: P hc;
! 3525: int pos;
! 3526: DPV p;
! 3527: Z q;
! 3528:
! 3529: asir_assert(ARG0(arg),O_DPV,"dpv_hc");
! 3530: p = (DPV)ARG0(arg);
! 3531: pos = dpv_hp(p);
! 3532: if ( pos < 0 )
! 3533: hc = 0;
! 3534: else
! 3535: hc = (P)BDY(BDY(p)[pos])->c;
! 3536: STOQ(pos,q);
! 3537: n = mknode(2,q,hc);
! 3538: MKLIST(*rp,n);
! 3539: }
! 3540:
! 3541: int dpv_hp(DPV p)
! 3542: {
! 3543: int len,i,maxp,maxw,w,slen;
! 3544: int *shift;
! 3545: DP *e;
! 3546:
! 3547: len = p->len;
! 3548: e = p->body;
! 3549: slen = dp_current_modspec->len;
! 3550: shift = dp_current_modspec->degree_shift;
! 3551: switch ( dp_current_modspec->id ) {
! 3552: case ORD_REVGRADLEX:
! 3553: for ( maxp = -1, i = 0; i < len; i++ )
! 3554: if ( !e[i] ) continue;
! 3555: else if ( maxp < 0 ) {
! 3556: maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
! 3557: } else {
! 3558: w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
! 3559: if ( w >= maxw ) {
! 3560: maxw = w; maxp = i;
! 3561: }
! 3562: }
! 3563: return maxp;
! 3564: case ORD_GRADLEX:
! 3565: for ( maxp = -1, i = 0; i < len; i++ )
! 3566: if ( !e[i] ) continue;
! 3567: else if ( maxp < 0 ) {
! 3568: maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
! 3569: } else {
! 3570: w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
! 3571: if ( w > maxw ) {
! 3572: maxw = w; maxp = i;
! 3573: }
! 3574: }
! 3575: return maxp;
! 3576: break;
! 3577: case ORD_LEX:
! 3578: for ( i = 0; i < len; i++ )
! 3579: if ( e[i] ) return i;
! 3580: return -1;
! 3581: break;
! 3582: }
! 3583: }
! 3584:
! 3585: int get_opt(char *key0,Obj *r) {
! 3586: NODE tt,p;
! 3587: char *key;
! 3588:
! 3589: if ( current_option ) {
! 3590: for ( tt = current_option; tt; tt = NEXT(tt) ) {
! 3591: p = BDY((LIST)BDY(tt));
! 3592: key = BDY((STRING)BDY(p));
! 3593: /* value = (Obj)BDY(NEXT(p)); */
! 3594: if ( !strcmp(key,key0) ) {
! 3595: *r = (Obj)BDY(NEXT(p));
! 3596: return 1;
! 3597: }
! 3598: }
! 3599: }
! 3600: return 0;
! 3601: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to dp.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2018 / builtin