Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.108
1.5 noro 1: /*
2: * Copyright (c) 1994-2000 FUJITSU LABORATORIES LIMITED
3: * All rights reserved.
4: *
5: * FUJITSU LABORATORIES LIMITED ("FLL") hereby grants you a limited,
6: * non-exclusive and royalty-free license to use, copy, modify and
7: * redistribute, solely for non-commercial and non-profit purposes, the
8: * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and
1.106 noro 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
1.5 noro 11: * third party developer retains all rights, including but not limited to
12: * copyrights, in and to the SOFTWARE.
13: *
14: * (1) FLL does not grant you a license in any way for commercial
15: * purposes. You may use the SOFTWARE only for non-commercial and
16: * non-profit purposes only, such as academic, research and internal
17: * business use.
18: * (2) The SOFTWARE is protected by the Copyright Law of Japan and
19: * international copyright treaties. If you make copies of the SOFTWARE,
20: * with or without modification, as permitted hereunder, you shall affix
21: * to all such copies of the SOFTWARE the above copyright notice.
22: * (3) An explicit reference to this SOFTWARE and its copyright owner
23: * shall be made on your publication or presentation in any form of the
24: * results obtained by use of the SOFTWARE.
25: * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.6 noro 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.5 noro 27: * for such modification or the source code of the modified part of the
28: * SOFTWARE.
29: *
30: * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
31: * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
32: * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
33: * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
34: * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
35: * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
36: * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
37: * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
38: * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
39: * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
40: * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
41: * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
42: * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
43: * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
44: * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
45: * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
46: * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
47: *
1.108 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.107 2017/09/14 01:34:53 noro Exp $
1.5 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "base.h"
52: #include "parse.h"
53:
1.61 noro 54: extern int dp_fcoeffs;
1.8 noro 55: extern int dp_nelim;
56: extern int dp_order_pair_length;
57: extern struct order_pair *dp_order_pair;
1.46 noro 58: extern struct order_spec *dp_current_spec;
1.52 noro 59: extern struct modorder_spec *dp_current_modspec;
1.94 noro 60: extern int nd_rref2;
1.8 noro 61:
1.11 noro 62: int do_weyl;
1.1 noro 63:
1.44 noro 64: void Pdp_sort();
1.32 noro 65: void Pdp_mul_trunc(),Pdp_quo();
1.64 noro 66: void Pdp_ord(), Pdp_ptod(), Pdp_dtop(), Phomogenize();
1.1 noro 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();
1.30 ohara 69: void Pdp_set_sugar();
1.1 noro 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();
1.70 noro 72: void Pdp_nf(),Pdp_true_nf(),Pdp_true_nf_marked(),Pdp_true_nf_marked_mod();
1.98 noro 73:
74: void Pdp_true_nf_and_quotient(),Pdp_true_nf_and_quotient_mod();
1.79 noro 75: void Pdp_true_nf_and_quotient_marked(),Pdp_true_nf_and_quotient_marked_mod();
1.98 noro 76:
1.1 noro 77: void Pdp_nf_mod(),Pdp_true_nf_mod();
78: void Pdp_criB(),Pdp_nelim();
1.9 noro 79: void Pdp_minp(),Pdp_sp_mod();
1.1 noro 80: void Pdp_homo(),Pdp_dehomo();
1.16 noro 81: void Pdp_gr_mod_main(),Pdp_gr_f_main();
1.1 noro 82: void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags();
1.63 noro 83: void Pdp_interreduce();
1.16 noro 84: void Pdp_f4_main(),Pdp_f4_mod_main(),Pdp_f4_f_main();
1.1 noro 85: void Pdp_gr_print();
1.28 noro 86: void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_mdtod(), Pdp_nf_tab_f();
1.8 noro 87: void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
88: void Pdp_cont();
1.22 noro 89: void Pdp_gr_checklist();
1.52 noro 90: void Pdp_ltod(),Pdpv_ord(),Pdpv_ht(),Pdpv_hm(),Pdpv_hc();
1.105 noro 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();
1.1 noro 93:
1.13 noro 94: void Pdp_weyl_red();
95: void Pdp_weyl_sp();
1.98 noro 96:
1.13 noro 97: void Pdp_weyl_nf(),Pdp_weyl_nf_mod();
1.98 noro 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:
1.16 noro 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();
1.96 noro 103: void Pdp_weyl_mul(),Pdp_weyl_mul_mod(),Pdp_weyl_act();
1.15 noro 104: void Pdp_weyl_set_weight();
1.77 noro 105: void Pdp_set_weight(),Pdp_set_top_weight(),Pdp_set_module_weight();
1.16 noro 106: void Pdp_nf_f(),Pdp_weyl_nf_f();
1.105 noro 107: void Pdpm_nf_f(),Pdpm_weyl_nf_f();
1.16 noro 108: void Pdp_lnf_f();
1.62 noro 109: void Pnd_gr(),Pnd_gr_trace(),Pnd_f4(),Pnd_f4_trace();
1.75 noro 110: void Pnd_gr_postproc(), Pnd_weyl_gr_postproc();
1.89 noro 111: void Pnd_gr_recompute_trace(), Pnd_btog();
1.38 noro 112: void Pnd_weyl_gr(),Pnd_weyl_gr_trace();
1.83 noro 113: void Pnd_nf(),Pnd_weyl_nf();
1.49 noro 114: void Pdp_initial_term();
115: void Pdp_order();
1.66 noro 116: void Pdp_inv_or_split();
1.74 noro 117: void Pdp_compute_last_t();
1.68 noro 118: void Pdp_compute_last_w();
1.70 noro 119: void Pdp_compute_essential_df();
1.72 noro 120: void Pdp_get_denomlist();
1.80 noro 121: void Pdp_symb_add();
1.82 noro 122: void Pdp_mono_raddec();
1.84 noro 123: void Pdp_mono_reduce();
1.95 noro 124: void Pdp_rref2(),Psumi_updatepairs(),Psumi_symbolic();
1.49 noro 125:
126: LIST dp_initial_term();
127: LIST dp_order();
128: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
1.108 ! noro 129: int *modular,struct order_spec **ord);
1.88 ohara 130: NODE dp_inv_or_split(NODE gb,DP f,struct order_spec *spec, DP *inv);
1.11 noro 131:
1.25 noro 132: LIST remove_zero_from_list(LIST);
133:
1.1 noro 134: struct ftab dp_tab[] = {
1.108 ! noro 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},
1.8 noro 141:
1.11 noro 142: /* polynomial ring */
1.108 ! noro 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},
1.8 noro 202:
1.11 noro 203: /* weyl algebra */
1.108 ! noro 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},
1.72 noro 242:
1.108 ! noro 243: {"dp_get_denomlist",Pdp_get_denomlist,0},
! 244: {0,0,0},
1.8 noro 245: };
246:
247: struct ftab dp_supp_tab[] = {
1.108 ! noro 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},
1.94 noro 319:
1.108 ! noro 320: {0,0,0}
1.1 noro 321: };
1.44 noro 322:
1.68 noro 323: NODE compute_last_w(NODE g,NODE gh,int n,int **v,int row1,int **m1,int row2,int **m2);
1.74 noro 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: {
1.108 ! noro 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);
1.74 noro 342: }
1.68 noro 343:
344: void Pdp_compute_last_w(NODE arg,LIST *rp)
345: {
1.108 ! noro 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: Q 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: }
1.68 noro 384: }
385:
1.70 noro 386: NODE compute_essential_df(DP *g,DP *gh,int n);
387:
388: void Pdp_compute_essential_df(NODE arg,LIST *rp)
389: {
1.108 ! noro 390: VECT g,gh;
! 391: NODE r;
1.70 noro 392:
1.108 ! noro 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);
1.70 noro 397: }
398:
1.97 noro 399: void Pdp_inv_or_split(NODE arg,Obj *rp)
1.66 noro 400: {
1.108 ! noro 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: }
1.66 noro 421: }
422:
1.97 noro 423: void Pdp_sort(NODE arg,DP *rp)
1.44 noro 424: {
1.108 ! noro 425: dp_sort((DP)ARG0(arg),rp);
1.44 noro 426: }
1.1 noro 427:
1.97 noro 428: void Pdp_mdtod(NODE arg,DP *rp)
1.8 noro 429: {
1.108 ! noro 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: }
1.8 noro 443: }
444:
1.97 noro 445: void Pdp_sep(NODE arg,VECT *rp)
1.8 noro 446: {
1.108 ! noro 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: }
1.8 noro 470: }
471:
1.97 noro 472: void Pdp_idiv(NODE arg,DP *rp)
1.8 noro 473: {
1.108 ! noro 474: dp_idiv((DP)ARG0(arg),(Q)ARG1(arg),rp);
1.8 noro 475: }
476:
1.97 noro 477: void Pdp_cont(NODE arg,Q *rp)
1.8 noro 478: {
1.108 ! noro 479: dp_cont((DP)ARG0(arg),rp);
1.8 noro 480: }
481:
1.97 noro 482: void Pdp_dtov(NODE arg,VECT *rp)
1.8 noro 483: {
1.108 ! noro 484: dp_dtov((DP)ARG0(arg),rp);
1.8 noro 485: }
486:
1.97 noro 487: void Pdp_mbase(NODE arg,LIST *rp)
1.8 noro 488: {
1.108 ! noro 489: NODE mb;
1.8 noro 490:
1.108 ! noro 491: asir_assert(ARG0(arg),O_LIST,"dp_mbase");
! 492: dp_mbase(BDY((LIST)ARG0(arg)),&mb);
! 493: MKLIST(*rp,mb);
1.8 noro 494: }
495:
1.97 noro 496: void Pdp_etov(NODE arg,VECT *rp)
1.8 noro 497: {
1.108 ! noro 498: DP dp;
! 499: int n,i;
! 500: int *d;
! 501: VECT v;
! 502: Q 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;
1.8 noro 512: }
513:
1.97 noro 514: void Pdp_vtoe(NODE arg,DP *rp)
1.8 noro 515: {
1.108 ! noro 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;
1.8 noro 534: }
535:
1.97 noro 536: void Pdp_lnf_mod(NODE arg,LIST *rp)
1.8 noro 537: {
1.108 ! noro 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);
1.8 noro 551: }
552:
1.97 noro 553: void Pdp_lnf_f(NODE arg,LIST *rp)
1.16 noro 554: {
1.108 ! noro 555: DP r1,r2;
! 556: NODE b,g,n;
1.16 noro 557:
1.108 ! noro 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);
1.16 noro 565: }
566:
1.97 noro 567: void Pdp_nf_tab_mod(NODE arg,DP *rp)
1.8 noro 568: {
1.108 ! noro 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);
1.28 noro 574: }
575:
1.97 noro 576: void Pdp_nf_tab_f(NODE arg,DP *rp)
1.28 noro 577: {
1.108 ! noro 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);
1.8 noro 581: }
1.1 noro 582:
1.97 noro 583: void Pdp_ord(NODE arg,Obj *rp)
1.1 noro 584: {
1.108 ! noro 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: }
1.1 noro 601: }
602:
1.97 noro 603: void Pdp_ptod(NODE arg,DP *rp)
1.1 noro 604: {
1.108 ! noro 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);
1.64 noro 640: }
641:
1.105 noro 642: void Phomogenize(NODE arg,Obj *rp)
1.64 noro 643: {
1.108 ! noro 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);
1.1 noro 675: }
676:
1.97 noro 677: void Pdp_ltod(NODE arg,DPV *rp)
1.52 noro 678: {
1.108 ! noro 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);
1.52 noro 722: }
723:
1.105 noro 724: void Pdpm_ltod(NODE arg,DPM *rp)
725: {
1.108 ! noro 726: NODE n;
! 727: VL vl,tvl;
! 728: LIST f,v;
! 729: int i,len;
! 730: NODE nd;
1.105 noro 731: NODE t;
732: DP d;
733: DPM s,u,w;
734:
735: f = (LIST)ARG0(arg);
736: v = (LIST)ARG1(arg);
1.108 ! noro 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);
1.105 noro 752: dtodpm(d,i,&u);
753: adddpm(CO,s,u,&w); s = w;
1.108 ! noro 754: }
1.105 noro 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: }
1.108 ! noro 780: if ( vl )
! 781: NEXT(tvl) = 0;
1.105 noro 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-- ) {
1.108 ! noro 795: MKDP(nv,w[i],u); u->sugar = a->sugar; /* XXX */
! 796: dtop(CO,vl,u,&s);
! 797: MKNODE(nd1,s,nd); nd = nd1;
1.105 noro 798: }
799: MKLIST(*rp,nd);
800: }
801:
802: void Pdp_dtop(NODE arg,Obj *rp)
1.1 noro 803: {
1.108 ! noro 804: NODE n;
! 805: VL vl,tvl;
1.1 noro 806:
1.108 ! noro 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);
1.1 noro 820: }
821:
822: extern LIST Dist;
823:
1.97 noro 824: void Pdp_ptozp(NODE arg,Obj *rp)
1.1 noro 825: {
1.108 ! noro 826: Q t;
1.60 ohara 827: NODE tt,p;
828: NODE n,n0;
829: char *key;
1.108 ! noro 830: DP pp;
! 831: LIST list;
1.60 ohara 832: int get_factor=0;
833:
1.108 ! noro 834: asir_assert(ARG0(arg),O_DP,"dp_ptozp");
1.60 ohara 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:
1.108 ! noro 849: dp_ptozp3((DP)ARG0(arg),&t,&pp);
1.60 ohara 850:
851: /* printexpr(NULL,t); */
1.108 ! noro 852: /* if the option factor is given, then it returns the answer
1.60 ohara 853: in the format [zpoly, num] where num*zpoly is equal to the argument.*/
854: if (get_factor) {
1.108 ! noro 855: n0 = mknode(2,pp,t);
1.60 ohara 856: MKLIST(list,n0);
1.108 ! noro 857: *rp = (Obj)list;
1.60 ohara 858: } else
859: *rp = (Obj)pp;
1.1 noro 860: }
1.108 ! noro 861:
1.97 noro 862: void Pdp_ptozp2(NODE arg,LIST *rp)
1.1 noro 863: {
1.108 ! noro 864: DP p0,p1,h,r;
! 865: NODE n0;
1.1 noro 866:
1.108 ! noro 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);
1.1 noro 875: }
876:
1.97 noro 877: void Pdp_prim(NODE arg,DP *rp)
1.1 noro 878: {
1.108 ! noro 879: DP t;
1.1 noro 880:
1.108 ! noro 881: asir_assert(ARG0(arg),O_DP,"dp_prim");
! 882: dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
1.1 noro 883: }
1.108 ! noro 884:
1.97 noro 885: void Pdp_mod(NODE arg,DP *rp)
1.1 noro 886: {
1.108 ! noro 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);
1.1 noro 897: }
898:
1.97 noro 899: void Pdp_rat(NODE arg,DP *rp)
1.1 noro 900: {
1.108 ! noro 901: asir_assert(ARG0(arg),O_DP,"dp_rat");
! 902: dp_rat((DP)ARG0(arg),rp);
1.1 noro 903: }
904:
1.9 noro 905: extern int DP_Multiple;
906:
1.97 noro 907: void Pdp_nf(NODE arg,DP *rp)
1.1 noro 908: {
1.108 ! noro 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);
1.1 noro 925: }
926:
1.97 noro 927: void Pdp_weyl_nf(NODE arg,DP *rp)
1.11 noro 928: {
1.108 ! noro 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;
1.16 noro 946: }
947:
1.105 noro 948: void Pdpm_nf(NODE arg,DP *rp)
949: {
1.108 ! noro 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);
1.105 noro 966: }
967:
968: void Pdpm_weyl_nf(NODE arg,DPM *rp)
969: {
1.108 ! noro 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;
1.105 noro 987: }
988:
1.16 noro 989: /* nf computation using field operations */
990:
1.97 noro 991: void Pdp_nf_f(NODE arg,DP *rp)
1.16 noro 992: {
1.108 ! noro 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);
1.16 noro 1009: }
1010:
1.97 noro 1011: void Pdp_weyl_nf_f(NODE arg,DP *rp)
1.16 noro 1012: {
1.108 ! noro 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;
1.11 noro 1030: }
1031:
1.105 noro 1032: void Pdpm_nf_f(NODE arg,DPM *rp)
1033: {
1.108 ! noro 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);
1.105 noro 1049: }
1050:
1051: void Pdpm_weyl_nf_f(NODE arg,DPM *rp)
1052: {
1.108 ! noro 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;
1.105 noro 1070: }
1071:
1072:
1.97 noro 1073: void Pdp_nf_mod(NODE arg,DP *rp)
1.13 noro 1074: {
1.108 ! noro 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);
1.13 noro 1100: }
1101:
1.97 noro 1102: void Pdp_true_nf(NODE arg,LIST *rp)
1.1 noro 1103: {
1.108 ! noro 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);
1.1 noro 1126: }
1127:
1.98 noro 1128: DP *dp_true_nf_and_quotient_marked(NODE b,DP g,DP *ps,DP *hps,DP *rp,P *dnp);
1.73 noro 1129:
1.97 noro 1130: void Pdp_true_nf_and_quotient_marked(NODE arg,LIST *rp)
1.73 noro 1131: {
1.108 ! noro 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);
1.73 noro 1156: }
1157:
1.98 noro 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:
1.79 noro 1165: DP *dp_true_nf_and_quotient_marked_mod (NODE b,DP g,DP *ps,DP *hps,int mod,DP *rp,P *dnp);
1166:
1.97 noro 1167: void Pdp_true_nf_and_quotient_marked_mod(NODE arg,LIST *rp)
1.79 noro 1168: {
1.108 ! noro 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);
1.79 noro 1195: }
1196:
1.98 noro 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:
1.97 noro 1203: void Pdp_true_nf_marked(NODE arg,LIST *rp)
1204: {
1.108 ! noro 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);
1.97 noro 1228: }
1229:
1230: void Pdp_true_nf_marked_mod(NODE arg,LIST *rp)
1.70 noro 1231: {
1.108 ! noro 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);
1.70 noro 1256: }
1257:
1.97 noro 1258: void Pdp_weyl_nf_mod(NODE arg,DP *rp)
1.8 noro 1259: {
1.108 ! noro 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;
1.8 noro 1286: }
1287:
1.97 noro 1288: void Pdp_true_nf_mod(NODE arg,LIST *rp)
1.8 noro 1289: {
1.108 ! noro 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);
1.1 noro 1313: }
1314:
1.98 noro 1315: void Pdp_weyl_true_nf_and_quotient_marked(NODE arg,LIST *rp)
1316: {
1.108 ! noro 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);
1.98 noro 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: {
1.108 ! noro 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);
1.98 noro 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:
1.97 noro 1387: void Pdp_tdiv(NODE arg,DP *rp)
1.1 noro 1388: {
1.108 ! noro 1389: MP m,mr,mr0;
! 1390: DP p;
! 1391: Q c;
! 1392: N d,q,r;
! 1393: int sgn;
! 1394:
! 1395: asir_assert(ARG0(arg),O_DP,"dp_tdiv");
! 1396: asir_assert(ARG1(arg),O_N,"dp_tdiv");
! 1397: p = (DP)ARG0(arg); d = NM((Q)ARG1(arg)); sgn = SGN((Q)ARG1(arg));
! 1398: if ( !p )
! 1399: *rp = 0;
! 1400: else {
! 1401: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
! 1402: divn(NM((Q)m->c),d,&q,&r);
! 1403: if ( r ) {
! 1404: *rp = 0; return;
! 1405: } else {
! 1406: NEXTMP(mr0,mr); NTOQ(q,SGN((Q)m->c)*sgn,c);
! 1407: mr->c = (Obj)c; mr->dl = m->dl;
! 1408: }
! 1409: }
! 1410: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
! 1411: }
1.1 noro 1412: }
1413:
1.97 noro 1414: void Pdp_red_coef(NODE arg,DP *rp)
1.1 noro 1415: {
1.108 ! noro 1416: MP m,mr,mr0;
! 1417: P q,r;
! 1418: DP p;
! 1419: P mod;
! 1420:
! 1421: p = (DP)ARG0(arg); mod = (P)ARG1(arg);
! 1422: asir_assert(p,O_DP,"dp_red_coef");
! 1423: asir_assert(mod,O_P,"dp_red_coef");
! 1424: if ( !p )
! 1425: *rp = 0;
! 1426: else {
! 1427: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
! 1428: divsrp(CO,(P)m->c,mod,&q,&r);
! 1429: if ( r ) {
! 1430: NEXTMP(mr0,mr); mr->c = (Obj)r; mr->dl = m->dl;
! 1431: }
! 1432: }
! 1433: if ( mr0 ) {
! 1434: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
! 1435: } else
! 1436: *rp = 0;
! 1437: }
1.1 noro 1438: }
1439:
1.97 noro 1440: void Pdp_redble(NODE arg,Q *rp)
1.1 noro 1441: {
1.108 ! noro 1442: asir_assert(ARG0(arg),O_DP,"dp_redble");
! 1443: asir_assert(ARG1(arg),O_DP,"dp_redble");
! 1444: if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
! 1445: *rp = ONE;
! 1446: else
! 1447: *rp = 0;
1.1 noro 1448: }
1449:
1.97 noro 1450: void Pdp_red_mod(NODE arg,LIST *rp)
1.1 noro 1451: {
1.108 ! noro 1452: DP h,r;
! 1453: P dmy;
! 1454: NODE n;
! 1455:
! 1456: do_weyl = 0;
! 1457: asir_assert(ARG0(arg),O_DP,"dp_red_mod");
! 1458: asir_assert(ARG1(arg),O_DP,"dp_red_mod");
! 1459: asir_assert(ARG2(arg),O_DP,"dp_red_mod");
! 1460: asir_assert(ARG3(arg),O_N,"dp_red_mod");
! 1461: dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),QTOS((Q)ARG3(arg)),
! 1462: &h,&r,&dmy);
! 1463: NEWNODE(n); BDY(n) = (pointer)h;
! 1464: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
! 1465: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.1 noro 1466: }
1.13 noro 1467:
1.97 noro 1468: void Pdp_subd(NODE arg,DP *rp)
1.1 noro 1469: {
1.108 ! noro 1470: DP p1,p2;
1.1 noro 1471:
1.108 ! noro 1472: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1473: asir_assert(p1,O_DP,"dp_subd");
! 1474: asir_assert(p2,O_DP,"dp_subd");
! 1475: dp_subd(p1,p2,rp);
1.1 noro 1476: }
1477:
1.97 noro 1478: void Pdp_symb_add(NODE arg,DP *rp)
1.80 noro 1479: {
1.108 ! noro 1480: DP p1,p2,r;
! 1481: NODE s0;
! 1482: MP mp0,mp;
! 1483: int nv;
! 1484:
! 1485: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1486: asir_assert(p1,O_DP,"dp_symb_add");
! 1487: asir_assert(p2,O_DP,"dp_symb_add");
! 1488: if ( !p1 ) { *rp = p2; return; }
! 1489: else if ( !p2 ) { *rp = p1; return; }
! 1490: if ( p1->nv != p2->nv )
! 1491: error("dp_sumb_add : invalid input");
! 1492: nv = p1->nv;
! 1493: s0 = symb_merge(dp_dllist(p1),dp_dllist(p2),nv);
! 1494: for ( mp0 = 0; s0; s0 = NEXT(s0) ) {
! 1495: NEXTMP(mp0,mp); mp->dl = (DL)BDY(s0); mp->c = (Obj)ONE;
! 1496: }
! 1497: NEXT(mp) = 0;
! 1498: MKDP(nv,mp0,r); r->sugar = MAX(p1->sugar,p2->sugar);
! 1499: *rp = r;
1.80 noro 1500: }
1501:
1.97 noro 1502: void Pdp_mul_trunc(NODE arg,DP *rp)
1.32 noro 1503: {
1.108 ! noro 1504: DP p1,p2,p;
1.32 noro 1505:
1.108 ! noro 1506: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); p = (DP)ARG2(arg);
! 1507: asir_assert(p1,O_DP,"dp_mul_trunc");
! 1508: asir_assert(p2,O_DP,"dp_mul_trunc");
! 1509: asir_assert(p,O_DP,"dp_mul_trunc");
! 1510: comm_muld_trunc(CO,p1,p2,BDY(p)->dl,rp);
1.32 noro 1511: }
1512:
1.97 noro 1513: void Pdp_quo(NODE arg,DP *rp)
1.32 noro 1514: {
1.108 ! noro 1515: DP p1,p2;
1.32 noro 1516:
1.108 ! noro 1517: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1518: asir_assert(p1,O_DP,"dp_quo");
! 1519: asir_assert(p2,O_DP,"dp_quo");
! 1520: comm_quod(CO,p1,p2,rp);
1.32 noro 1521: }
1522:
1.97 noro 1523: void Pdp_weyl_mul(NODE arg,DP *rp)
1.12 noro 1524: {
1.108 ! noro 1525: DP p1,p2;
1.12 noro 1526:
1.108 ! noro 1527: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1528: asir_assert(p1,O_DP,"dp_weyl_mul"); asir_assert(p2,O_DP,"dp_weyl_mul");
! 1529: do_weyl = 1;
! 1530: muld(CO,p1,p2,rp);
! 1531: do_weyl = 0;
1.13 noro 1532: }
1533:
1.97 noro 1534: void Pdp_weyl_act(NODE arg,DP *rp)
1.96 noro 1535: {
1.108 ! noro 1536: DP p1,p2;
1.96 noro 1537:
1.108 ! noro 1538: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1539: asir_assert(p1,O_DP,"dp_weyl_act"); asir_assert(p2,O_DP,"dp_weyl_act");
! 1540: weyl_actd(CO,p1,p2,rp);
1.96 noro 1541: }
1542:
1543:
1.97 noro 1544: void Pdp_weyl_mul_mod(NODE arg,DP *rp)
1.13 noro 1545: {
1.108 ! noro 1546: DP p1,p2;
! 1547: Q m;
1.13 noro 1548:
1.108 ! noro 1549: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); m = (Q)ARG2(arg);
! 1550: asir_assert(p1,O_DP,"dp_weyl_mul_mod");
! 1551: asir_assert(p2,O_DP,"dp_mul_mod");
! 1552: asir_assert(m,O_N,"dp_mul_mod");
! 1553: do_weyl = 1;
! 1554: mulmd(CO,QTOS(m),p1,p2,rp);
! 1555: do_weyl = 0;
1.12 noro 1556: }
1557:
1.97 noro 1558: void Pdp_red(NODE arg,LIST *rp)
1.1 noro 1559: {
1.108 ! noro 1560: NODE n;
! 1561: DP head,rest,dmy1;
! 1562: P dmy;
! 1563:
! 1564: do_weyl = 0;
! 1565: asir_assert(ARG0(arg),O_DP,"dp_red");
! 1566: asir_assert(ARG1(arg),O_DP,"dp_red");
! 1567: asir_assert(ARG2(arg),O_DP,"dp_red");
! 1568: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
! 1569: NEWNODE(n); BDY(n) = (pointer)head;
! 1570: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
! 1571: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.1 noro 1572: }
1573:
1.97 noro 1574: void Pdp_weyl_red(NODE arg,LIST *rp)
1.11 noro 1575: {
1.108 ! noro 1576: NODE n;
! 1577: DP head,rest,dmy1;
! 1578: P dmy;
! 1579:
! 1580: asir_assert(ARG0(arg),O_DP,"dp_weyl_red");
! 1581: asir_assert(ARG1(arg),O_DP,"dp_weyl_red");
! 1582: asir_assert(ARG2(arg),O_DP,"dp_weyl_red");
! 1583: do_weyl = 1;
! 1584: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
! 1585: do_weyl = 0;
! 1586: NEWNODE(n); BDY(n) = (pointer)head;
! 1587: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
! 1588: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.11 noro 1589: }
1590:
1.97 noro 1591: void Pdp_sp(NODE arg,DP *rp)
1.1 noro 1592: {
1.108 ! noro 1593: DP p1,p2;
1.1 noro 1594:
1.108 ! noro 1595: do_weyl = 0;
! 1596: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1597: asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
! 1598: dp_sp(p1,p2,rp);
1.1 noro 1599: }
1600:
1.97 noro 1601: void Pdp_weyl_sp(NODE arg,DP *rp)
1.11 noro 1602: {
1.108 ! noro 1603: DP p1,p2;
1.11 noro 1604:
1.108 ! noro 1605: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1606: asir_assert(p1,O_DP,"dp_weyl_sp"); asir_assert(p2,O_DP,"dp_weyl_sp");
! 1607: do_weyl = 1;
! 1608: dp_sp(p1,p2,rp);
! 1609: do_weyl = 0;
1.11 noro 1610: }
1611:
1.105 noro 1612: void Pdpm_sp(NODE arg,DPM *rp)
1613: {
1.108 ! noro 1614: DPM p1,p2;
1.105 noro 1615:
1.108 ! noro 1616: do_weyl = 0;
! 1617: p1 = (DPM)ARG0(arg); p2 = (DPM)ARG1(arg);
! 1618: asir_assert(p1,O_DPM,"dpm_sp"); asir_assert(p2,O_DPM,"dpm_sp");
! 1619: dpm_sp(p1,p2,rp);
1.105 noro 1620: }
1621:
1622: void Pdpm_weyl_sp(NODE arg,DPM *rp)
1623: {
1.108 ! noro 1624: DPM p1,p2;
1.105 noro 1625:
1.108 ! noro 1626: p1 = (DPM)ARG0(arg); p2 = (DPM)ARG1(arg);
! 1627: asir_assert(p1,O_DPM,"dpm_weyl_sp"); asir_assert(p2,O_DPM,"dpm_weyl_sp");
! 1628: do_weyl = 1;
! 1629: dpm_sp(p1,p2,rp);
! 1630: do_weyl = 0;
1.105 noro 1631: }
1632:
1.97 noro 1633: void Pdp_sp_mod(NODE arg,DP *rp)
1.1 noro 1634: {
1.108 ! noro 1635: DP p1,p2;
! 1636: int mod;
1.1 noro 1637:
1.108 ! noro 1638: do_weyl = 0;
! 1639: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1640: asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
! 1641: asir_assert(ARG2(arg),O_N,"dp_sp_mod");
! 1642: mod = QTOS((Q)ARG2(arg));
! 1643: dp_sp_mod(p1,p2,mod,rp);
1.1 noro 1644: }
1645:
1.97 noro 1646: void Pdp_lcm(NODE arg,DP *rp)
1.1 noro 1647: {
1.108 ! noro 1648: int i,n,td;
! 1649: DL d1,d2,d;
! 1650: MP m;
! 1651: DP p1,p2;
! 1652:
! 1653: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1654: asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
! 1655: n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
! 1656: NEWDL(d,n);
! 1657: for ( i = 0, td = 0; i < n; i++ ) {
! 1658: d->d[i] = MAX(d1->d[i],d2->d[i]); td += MUL_WEIGHT(d->d[i],i);
! 1659: }
! 1660: d->td = td;
! 1661: NEWMP(m); m->dl = d; m->c = (Obj)ONE; NEXT(m) = 0;
! 1662: MKDP(n,m,*rp); (*rp)->sugar = td; /* XXX */
1.1 noro 1663: }
1664:
1.97 noro 1665: void Pdp_hm(NODE arg,DP *rp)
1.1 noro 1666: {
1.108 ! noro 1667: DP p;
1.1 noro 1668:
1.108 ! noro 1669: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
! 1670: dp_hm(p,rp);
1.1 noro 1671: }
1672:
1.97 noro 1673: void Pdp_ht(NODE arg,DP *rp)
1.1 noro 1674: {
1.108 ! noro 1675: DP p;
! 1676: MP m,mr;
1.1 noro 1677:
1.108 ! noro 1678: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
! 1679: dp_ht(p,rp);
1.1 noro 1680: }
1681:
1.105 noro 1682: void Pdp_hc(NODE arg,Obj *rp)
1.1 noro 1683: {
1.108 ! noro 1684: asir_assert(ARG0(arg),O_DP,"dp_hc");
! 1685: if ( !ARG0(arg) )
! 1686: *rp = 0;
! 1687: else
! 1688: *rp = BDY((DP)ARG0(arg))->c;
1.1 noro 1689: }
1690:
1.97 noro 1691: void Pdp_rest(NODE arg,DP *rp)
1.1 noro 1692: {
1.108 ! noro 1693: asir_assert(ARG0(arg),O_DP,"dp_rest");
! 1694: if ( !ARG0(arg) )
! 1695: *rp = 0;
! 1696: else
! 1697: dp_rest((DP)ARG0(arg),rp);
1.1 noro 1698: }
1699:
1.97 noro 1700: void Pdp_td(NODE arg,Q *rp)
1.1 noro 1701: {
1.108 ! noro 1702: DP p;
1.1 noro 1703:
1.108 ! noro 1704: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
! 1705: if ( !p )
! 1706: *rp = 0;
! 1707: else
! 1708: STOQ(BDY(p)->dl->td,*rp);
1.1 noro 1709: }
1710:
1.97 noro 1711: void Pdp_sugar(NODE arg,Q *rp)
1.1 noro 1712: {
1.108 ! noro 1713: DP p;
1.1 noro 1714:
1.108 ! noro 1715: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
! 1716: if ( !p )
! 1717: *rp = 0;
! 1718: else
! 1719: STOQ(p->sugar,*rp);
1.30 ohara 1720: }
1721:
1.97 noro 1722: void Pdp_initial_term(NODE arg,Obj *rp)
1.49 noro 1723: {
1.108 ! noro 1724: struct order_spec *ord;
! 1725: Num homo;
! 1726: int modular,is_list;
! 1727: LIST v,f,l,initiallist;
! 1728: NODE n;
! 1729:
! 1730: f = (LIST)ARG0(arg);
! 1731: if ( f && OID(f) == O_LIST )
! 1732: is_list = 1;
! 1733: else {
! 1734: n = mknode(1,f); MKLIST(l,n); f = l;
! 1735: is_list = 0;
! 1736: }
! 1737: if ( current_option ) {
! 1738: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
! 1739: initd(ord);
! 1740: } else
! 1741: ord = dp_current_spec;
! 1742: initiallist = dp_initial_term(f,ord);
! 1743: if ( !is_list )
! 1744: *rp = (Obj)BDY(BDY(initiallist));
! 1745: else
! 1746: *rp = (Obj)initiallist;
1.49 noro 1747: }
1748:
1.97 noro 1749: void Pdp_order(NODE arg,Obj *rp)
1.49 noro 1750: {
1.108 ! noro 1751: struct order_spec *ord;
! 1752: Num homo;
! 1753: int modular,is_list;
! 1754: LIST v,f,l,ordlist;
! 1755: NODE n;
! 1756:
! 1757: f = (LIST)ARG0(arg);
! 1758: if ( f && OID(f) == O_LIST )
! 1759: is_list = 1;
! 1760: else {
! 1761: n = mknode(1,f); MKLIST(l,n); f = l;
! 1762: is_list = 0;
! 1763: }
! 1764: if ( current_option ) {
! 1765: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
! 1766: initd(ord);
! 1767: } else
! 1768: ord = dp_current_spec;
! 1769: ordlist = dp_order(f,ord);
! 1770: if ( !is_list )
! 1771: *rp = (Obj)BDY(BDY(ordlist));
! 1772: else
! 1773: *rp = (Obj)ordlist;
1.49 noro 1774: }
1775:
1.97 noro 1776: void Pdp_set_sugar(NODE arg,Q *rp)
1.30 ohara 1777: {
1.108 ! noro 1778: DP p;
! 1779: Q q;
! 1780: int i;
! 1781:
! 1782: p = (DP)ARG0(arg);
! 1783: q = (Q)ARG1(arg);
! 1784: if ( p && q) {
! 1785: asir_assert(p,O_DP,"dp_set_sugar");
! 1786: asir_assert(q,O_N, "dp_set_sugar");
! 1787: i = QTOS(q);
! 1788: if (p->sugar < i) {
! 1789: p->sugar = i;
! 1790: }
! 1791: }
! 1792: *rp = 0;
1.1 noro 1793: }
1794:
1.97 noro 1795: void Pdp_cri1(NODE arg,Q *rp)
1.1 noro 1796: {
1.108 ! noro 1797: DP p1,p2;
! 1798: int *d1,*d2;
! 1799: int i,n;
! 1800:
! 1801: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1802: asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
! 1803: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
! 1804: for ( i = 0; i < n; i++ )
! 1805: if ( d1[i] > d2[i] )
! 1806: break;
! 1807: *rp = i == n ? ONE : 0;
1.1 noro 1808: }
1809:
1.97 noro 1810: void Pdp_cri2(NODE arg,Q *rp)
1.1 noro 1811: {
1.108 ! noro 1812: DP p1,p2;
! 1813: int *d1,*d2;
! 1814: int i,n;
! 1815:
! 1816: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
! 1817: asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
! 1818: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
! 1819: for ( i = 0; i < n; i++ )
! 1820: if ( MIN(d1[i],d2[i]) >= 1 )
! 1821: break;
! 1822: *rp = i == n ? ONE : 0;
1.1 noro 1823: }
1824:
1.97 noro 1825: void Pdp_minp(NODE arg,LIST *rp)
1.1 noro 1826: {
1.108 ! noro 1827: NODE tn,tn1,d,dd,dd0,p,tp;
! 1828: LIST l,minp;
! 1829: DP lcm,tlcm;
! 1830: int s,ts;
! 1831:
! 1832: asir_assert(ARG0(arg),O_LIST,"dp_minp");
! 1833: d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
! 1834: p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
! 1835: if ( !ARG1(arg) ) {
! 1836: s = QTOS((Q)BDY(p)); p = NEXT(p);
! 1837: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
! 1838: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
! 1839: tlcm = (DP)BDY(tp); tp = NEXT(tp);
! 1840: ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
! 1841: NEXTNODE(dd0,dd);
! 1842: if ( ts < s ) {
! 1843: BDY(dd) = (pointer)minp;
! 1844: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
! 1845: } else if ( ts == s ) {
! 1846: if ( compd(CO,lcm,tlcm) > 0 ) {
! 1847: BDY(dd) = (pointer)minp;
! 1848: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
! 1849: } else
! 1850: BDY(dd) = BDY(d);
! 1851: } else
! 1852: BDY(dd) = BDY(d);
! 1853: }
! 1854: } else {
! 1855: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
! 1856: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
! 1857: tlcm = (DP)BDY(tp);
! 1858: NEXTNODE(dd0,dd);
! 1859: if ( compd(CO,lcm,tlcm) > 0 ) {
! 1860: BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
! 1861: } else
! 1862: BDY(dd) = BDY(d);
! 1863: }
! 1864: }
! 1865: if ( dd0 )
! 1866: NEXT(dd) = 0;
! 1867: MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
1.1 noro 1868: }
1869:
1.97 noro 1870: void Pdp_criB(NODE arg,LIST *rp)
1.1 noro 1871: {
1.108 ! noro 1872: NODE d,ij,dd,ddd;
! 1873: int i,j,s,n;
! 1874: DP *ps;
! 1875: DL ts,ti,tj,lij,tdl;
! 1876:
! 1877: asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
! 1878: asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
! 1879: asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
! 1880: if ( !d )
! 1881: *rp = (LIST)ARG0(arg);
! 1882: else {
! 1883: ts = BDY(ps[s])->dl;
! 1884: n = ps[s]->nv;
! 1885: NEWDL(tdl,n);
! 1886: for ( dd = 0; d; d = NEXT(d) ) {
! 1887: ij = BDY((LIST)BDY(d));
! 1888: i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
! 1889: j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
! 1890: lij = BDY((DP)BDY(ij))->dl;
! 1891: ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
! 1892: if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
! 1893: || !dl_equal(n,lij,tdl)
! 1894: || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
! 1895: && dl_equal(n,tdl,lij))
! 1896: || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
! 1897: && dl_equal(n,tdl,lij)) ) {
! 1898: MKNODE(ddd,BDY(d),dd);
! 1899: dd = ddd;
! 1900: }
! 1901: }
! 1902: MKLIST(*rp,dd);
! 1903: }
1.1 noro 1904: }
1905:
1.97 noro 1906: void Pdp_nelim(NODE arg,Q *rp)
1.1 noro 1907: {
1.108 ! noro 1908: if ( arg ) {
! 1909: asir_assert(ARG0(arg),O_N,"dp_nelim");
! 1910: dp_nelim = QTOS((Q)ARG0(arg));
! 1911: }
! 1912: STOQ(dp_nelim,*rp);
1.1 noro 1913: }
1914:
1.97 noro 1915: void Pdp_mag(NODE arg,Q *rp)
1.1 noro 1916: {
1.108 ! noro 1917: DP p;
! 1918: int s;
! 1919: MP m;
! 1920:
! 1921: p = (DP)ARG0(arg);
! 1922: asir_assert(p,O_DP,"dp_mag");
! 1923: if ( !p )
! 1924: *rp = 0;
! 1925: else {
! 1926: for ( s = 0, m = BDY(p); m; m = NEXT(m) )
! 1927: s += p_mag((P)m->c);
! 1928: STOQ(s,*rp);
! 1929: }
1.1 noro 1930: }
1931:
1932: extern int kara_mag;
1933:
1.97 noro 1934: void Pdp_set_kara(NODE arg,Q *rp)
1.1 noro 1935: {
1.108 ! noro 1936: if ( arg ) {
! 1937: asir_assert(ARG0(arg),O_N,"dp_set_kara");
! 1938: kara_mag = QTOS((Q)ARG0(arg));
! 1939: }
! 1940: STOQ(kara_mag,*rp);
1.1 noro 1941: }
1942:
1.97 noro 1943: void Pdp_homo(NODE arg,DP *rp)
1.1 noro 1944: {
1.108 ! noro 1945: asir_assert(ARG0(arg),O_DP,"dp_homo");
! 1946: dp_homo((DP)ARG0(arg),rp);
1.1 noro 1947: }
1948:
1.97 noro 1949: void Pdp_dehomo(NODE arg,DP *rp)
1.1 noro 1950: {
1.108 ! noro 1951: asir_assert(ARG0(arg),O_DP,"dp_dehomo");
! 1952: dp_dehomo((DP)ARG0(arg),rp);
1.8 noro 1953: }
1954:
1.97 noro 1955: void Pdp_gr_flags(NODE arg,LIST *rp)
1.8 noro 1956: {
1.108 ! noro 1957: Obj name,value;
! 1958: NODE n;
1.1 noro 1959:
1.108 ! noro 1960: if ( arg ) {
! 1961: asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
! 1962: n = BDY((LIST)ARG0(arg));
! 1963: while ( n ) {
! 1964: name = (Obj)BDY(n); n = NEXT(n);
! 1965: if ( !n )
! 1966: break;
! 1967: else {
! 1968: value = (Obj)BDY(n); n = NEXT(n);
! 1969: }
! 1970: dp_set_flag(name,value);
! 1971: }
! 1972: }
! 1973: dp_make_flaglist(rp);
1.8 noro 1974: }
1975:
1.29 noro 1976: extern int DP_Print, DP_PrintShort;
1.8 noro 1977:
1.97 noro 1978: void Pdp_gr_print(NODE arg,Q *rp)
1.8 noro 1979: {
1.108 ! noro 1980: Q q;
! 1981: int s;
1.8 noro 1982:
1.108 ! noro 1983: if ( arg ) {
! 1984: asir_assert(ARG0(arg),O_N,"dp_gr_print");
! 1985: q = (Q)ARG0(arg);
! 1986: s = QTOS(q);
! 1987: switch ( s ) {
! 1988: case 0:
! 1989: DP_Print = 0; DP_PrintShort = 0;
! 1990: break;
! 1991: case 1:
! 1992: DP_Print = 1;
! 1993: break;
! 1994: case 2:
! 1995: DP_Print = 0; DP_PrintShort = 1;
! 1996: break;
! 1997: default:
! 1998: DP_Print = s; DP_PrintShort = 0;
! 1999: break;
! 2000: }
! 2001: } else {
! 2002: if ( DP_Print ) {
! 2003: STOQ(1,q);
! 2004: } else if ( DP_PrintShort ) {
! 2005: STOQ(2,q);
! 2006: } else
! 2007: q = 0;
! 2008: }
! 2009: *rp = q;
1.1 noro 2010: }
2011:
1.46 noro 2012: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
1.108 ! noro 2013: int *modular,struct order_spec **ord)
1.46 noro 2014: {
1.108 ! noro 2015: NODE t,p;
! 2016: Q m;
! 2017: char *key;
! 2018: Obj value,dmy;
! 2019: int ord_is_set = 0;
! 2020: int modular_is_set = 0;
! 2021: int homo_is_set = 0;
! 2022: VL vl,vl0;
! 2023: LIST vars;
! 2024: char xiname[BUFSIZ];
! 2025: NODE x0,x;
! 2026: DP d;
! 2027: P xi;
! 2028: int nv,i;
! 2029:
! 2030: /* extract vars */
! 2031: vars = 0;
! 2032: for ( t = opt; t; t = NEXT(t) ) {
! 2033: p = BDY((LIST)BDY(t));
! 2034: key = BDY((STRING)BDY(p));
! 2035: value = (Obj)BDY(NEXT(p));
! 2036: if ( !strcmp(key,"v") ) {
! 2037: /* variable list */
! 2038: vars = (LIST)value;
! 2039: break;
! 2040: }
! 2041: }
! 2042: if ( vars ) {
! 2043: *v = vars; pltovl(vars,&vl);
! 2044: } else {
! 2045: for ( t = BDY(f); t; t = NEXT(t) )
! 2046: if ( BDY(t) && OID((Obj)BDY(t))==O_DP )
! 2047: break;
! 2048: if ( t ) {
! 2049: /* f is DP list */
! 2050: /* create dummy var list */
! 2051: d = (DP)BDY(t);
! 2052: nv = NV(d);
! 2053: for ( i = 0, vl0 = 0, x0 = 0; i < nv; i++ ) {
! 2054: NEXTVL(vl0,vl);
! 2055: NEXTNODE(x0,x);
! 2056: sprintf(xiname,"x%d",i);
! 2057: makevar(xiname,&xi);
! 2058: x->body = (pointer)xi;
! 2059: vl->v = VR((P)xi);
! 2060: }
! 2061: if ( vl0 ) {
! 2062: NEXT(vl) = 0;
! 2063: NEXT(x) = 0;
! 2064: }
! 2065: MKLIST(vars,x0);
! 2066: *v = vars;
! 2067: vl = vl0;
! 2068: } else {
! 2069: get_vars((Obj)f,&vl); vltopl(vl,v);
! 2070: }
! 2071: }
! 2072:
! 2073: for ( t = opt; t; t = NEXT(t) ) {
! 2074: p = BDY((LIST)BDY(t));
! 2075: key = BDY((STRING)BDY(p));
! 2076: value = (Obj)BDY(NEXT(p));
! 2077: if ( !strcmp(key,"v") ) {
! 2078: /* variable list; ignore */
! 2079: } else if ( !strcmp(key,"order") ) {
! 2080: /* order spec */
! 2081: if ( !vl )
! 2082: error("parse_gr_option : variables must be specified");
! 2083: create_order_spec(vl,value,ord);
! 2084: ord_is_set = 1;
! 2085: } else if ( !strcmp(key,"block") ) {
! 2086: create_order_spec(0,value,ord);
! 2087: ord_is_set = 1;
! 2088: } else if ( !strcmp(key,"matrix") ) {
! 2089: create_order_spec(0,value,ord);
! 2090: ord_is_set = 1;
! 2091: } else if ( !strcmp(key,"sugarweight") ) {
! 2092: /* weight */
! 2093: Pdp_set_weight(NEXT(p),&dmy);
! 2094: } else if ( !strcmp(key,"homo") ) {
! 2095: *homo = (Num)value;
! 2096: homo_is_set = 1;
! 2097: } else if ( !strcmp(key,"trace") ) {
! 2098: m = (Q)value;
! 2099: if ( !m )
! 2100: *modular = 0;
! 2101: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1
! 2102: && BD(NM(m))[0] >= 0x80000000) )
! 2103: error("parse_gr_option : too large modulus");
! 2104: else
! 2105: *modular = QTOS(m);
! 2106: modular_is_set = 1;
! 2107: } else if ( !strcmp(key,"dp") ) {
1.104 noro 2108: /* XXX : ignore */
1.108 ! noro 2109: } else
! 2110: error("parse_gr_option : not implemented");
! 2111: }
! 2112: if ( !ord_is_set ) create_order_spec(0,0,ord);
! 2113: if ( !modular_is_set ) *modular = 0;
! 2114: if ( !homo_is_set ) *homo = 0;
1.46 noro 2115: }
2116:
1.97 noro 2117: void Pdp_gr_main(NODE arg,LIST *rp)
1.1 noro 2118: {
1.108 ! noro 2119: LIST f,v;
! 2120: VL vl;
! 2121: Num homo;
! 2122: Q m;
! 2123: int modular,ac;
! 2124: struct order_spec *ord;
! 2125:
! 2126: do_weyl = 0;
! 2127: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
! 2128: f = (LIST)ARG0(arg);
! 2129: f = remove_zero_from_list(f);
! 2130: if ( !BDY(f) ) {
! 2131: *rp = f; return;
! 2132: }
! 2133: if ( (ac = argc(arg)) == 5 ) {
! 2134: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
! 2135: asir_assert(ARG2(arg),O_N,"dp_gr_main");
! 2136: asir_assert(ARG3(arg),O_N,"dp_gr_main");
! 2137: v = (LIST)ARG1(arg);
! 2138: homo = (Num)ARG2(arg);
! 2139: m = (Q)ARG3(arg);
! 2140: if ( !m )
! 2141: modular = 0;
! 2142: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
! 2143: error("dp_gr_main : too large modulus");
! 2144: else
! 2145: modular = QTOS(m);
! 2146: create_order_spec(0,ARG4(arg),&ord);
! 2147: } else if ( current_option )
! 2148: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
! 2149: else if ( ac == 1 )
! 2150: parse_gr_option(f,0,&v,&homo,&modular,&ord);
! 2151: else
! 2152: error("dp_gr_main : invalid argument");
! 2153: dp_gr_main(f,v,homo,modular,0,ord,rp);
1.63 noro 2154: }
2155:
1.97 noro 2156: void Pdp_interreduce(NODE arg,LIST *rp)
1.63 noro 2157: {
1.108 ! noro 2158: LIST f,v;
! 2159: VL vl;
! 2160: int ac;
! 2161: struct order_spec *ord;
! 2162:
! 2163: do_weyl = 0;
! 2164: asir_assert(ARG0(arg),O_LIST,"dp_interreduce");
! 2165: f = (LIST)ARG0(arg);
! 2166: f = remove_zero_from_list(f);
! 2167: if ( !BDY(f) ) {
! 2168: *rp = f; return;
! 2169: }
! 2170: if ( (ac = argc(arg)) == 3 ) {
! 2171: asir_assert(ARG1(arg),O_LIST,"dp_interreduce");
! 2172: v = (LIST)ARG1(arg);
! 2173: create_order_spec(0,ARG2(arg),&ord);
! 2174: }
! 2175: dp_interreduce(f,v,0,ord,rp);
1.16 noro 2176: }
2177:
1.97 noro 2178: void Pdp_gr_f_main(NODE arg,LIST *rp)
1.16 noro 2179: {
1.108 ! noro 2180: LIST f,v;
! 2181: Num homo;
! 2182: int m,field,t;
! 2183: struct order_spec *ord;
! 2184: NODE n;
! 2185:
! 2186: do_weyl = 0;
! 2187: asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
! 2188: asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
! 2189: asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
! 2190: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2191: f = remove_zero_from_list(f);
! 2192: if ( !BDY(f) ) {
! 2193: *rp = f; return;
! 2194: }
! 2195: homo = (Num)ARG2(arg);
1.27 noro 2196: #if 0
1.108 ! noro 2197: asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
! 2198: m = QTOS((Q)ARG3(arg));
! 2199: if ( m )
! 2200: error("dp_gr_f_main : trace lifting is not implemented yet");
! 2201: create_order_spec(0,ARG4(arg),&ord);
1.27 noro 2202: #else
1.108 ! noro 2203: m = 0;
! 2204: create_order_spec(0,ARG3(arg),&ord);
1.27 noro 2205: #endif
1.108 ! noro 2206: field = 0;
! 2207: for ( n = BDY(f); n; n = NEXT(n) ) {
! 2208: t = get_field_type(BDY(n));
! 2209: if ( !t )
! 2210: continue;
! 2211: if ( t < 0 )
! 2212: error("dp_gr_f_main : incosistent coefficients");
! 2213: if ( !field )
! 2214: field = t;
! 2215: else if ( t != field )
! 2216: error("dp_gr_f_main : incosistent coefficients");
! 2217: }
! 2218: dp_gr_main(f,v,homo,m?1:0,field,ord,rp);
1.1 noro 2219: }
2220:
1.97 noro 2221: void Pdp_f4_main(NODE arg,LIST *rp)
1.1 noro 2222: {
1.108 ! noro 2223: LIST f,v;
! 2224: struct order_spec *ord;
1.1 noro 2225:
1.108 ! noro 2226: do_weyl = 0;
! 2227: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
! 2228: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
! 2229: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2230: f = remove_zero_from_list(f);
! 2231: if ( !BDY(f) ) {
! 2232: *rp = f; return;
! 2233: }
! 2234: create_order_spec(0,ARG2(arg),&ord);
! 2235: dp_f4_main(f,v,ord,rp);
1.22 noro 2236: }
2237:
2238: /* dp_gr_checklist(list of dp) */
2239:
1.97 noro 2240: void Pdp_gr_checklist(NODE arg,LIST *rp)
1.22 noro 2241: {
1.108 ! noro 2242: VECT g;
! 2243: LIST dp;
! 2244: NODE r;
! 2245: int n;
! 2246:
! 2247: do_weyl = 0;
! 2248: asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
! 2249: asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
! 2250: n = QTOS((Q)ARG1(arg));
! 2251: gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
! 2252: r = mknode(2,g,dp);
! 2253: MKLIST(*rp,r);
1.1 noro 2254: }
2255:
1.97 noro 2256: void Pdp_f4_mod_main(NODE arg,LIST *rp)
1.1 noro 2257: {
1.108 ! noro 2258: LIST f,v;
! 2259: int m;
! 2260: struct order_spec *ord;
! 2261:
! 2262: do_weyl = 0;
! 2263: asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
! 2264: asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
! 2265: asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
! 2266: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
! 2267: f = remove_zero_from_list(f);
! 2268: if ( !BDY(f) ) {
! 2269: *rp = f; return;
! 2270: }
! 2271: if ( !m )
! 2272: error("dp_f4_mod_main : invalid argument");
! 2273: create_order_spec(0,ARG3(arg),&ord);
! 2274: dp_f4_mod_main(f,v,m,ord,rp);
1.8 noro 2275: }
1.1 noro 2276:
1.97 noro 2277: void Pdp_gr_mod_main(NODE arg,LIST *rp)
1.8 noro 2278: {
1.108 ! noro 2279: LIST f,v;
! 2280: Num homo;
! 2281: int m;
! 2282: struct order_spec *ord;
! 2283:
! 2284: do_weyl = 0;
! 2285: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
! 2286: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
! 2287: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
! 2288: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
! 2289: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2290: f = remove_zero_from_list(f);
! 2291: if ( !BDY(f) ) {
! 2292: *rp = f; return;
! 2293: }
! 2294: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
! 2295: if ( !m )
! 2296: error("dp_gr_mod_main : invalid argument");
! 2297: create_order_spec(0,ARG4(arg),&ord);
! 2298: dp_gr_mod_main(f,v,homo,m,ord,rp);
1.33 noro 2299: }
2300:
1.97 noro 2301: void Pnd_f4(NODE arg,LIST *rp)
1.40 noro 2302: {
1.108 ! noro 2303: LIST f,v;
! 2304: int m,homo,retdp,ac;
! 2305: Obj val;
1.103 noro 2306: Q mq;
2307: Num nhomo;
2308: NODE node;
1.108 ! noro 2309: struct order_spec *ord;
1.40 noro 2310:
1.108 ! noro 2311: do_weyl = 0;
! 2312: nd_rref2 = 0;
1.103 noro 2313: retdp = 0;
2314: if ( (ac = argc(arg)) == 4 ) {
1.108 ! noro 2315: asir_assert(ARG0(arg),O_LIST,"nd_f4");
! 2316: asir_assert(ARG1(arg),O_LIST,"nd_f4");
! 2317: asir_assert(ARG2(arg),O_N,"nd_f4");
! 2318: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2319: f = remove_zero_from_list(f);
! 2320: if ( !BDY(f) ) {
! 2321: *rp = f; return;
! 2322: }
1.103 noro 2323: mq = (Q)ARG2(arg);
1.107 noro 2324: if ( mq && (PL(NM(mq)) > 1 || BD(NM(mq))[0] >= (1<<31)) ) {
1.103 noro 2325: node = mknode(1,mq);
2326: Psetmod_ff(node,&val);
2327: m = -2;
1.101 noro 2328: } else
2329: m = QTOS(mq);
1.108 ! noro 2330: create_order_spec(0,ARG3(arg),&ord);
! 2331: homo = 0;
! 2332: if ( get_opt("homo",&val) && val ) homo = 1;
! 2333: if ( get_opt("dp",&val) && val ) retdp = 1;
! 2334: if ( get_opt("rref2",&val) && val ) nd_rref2 = 1;
1.103 noro 2335: } else if ( ac == 1 ) {
1.108 ! noro 2336: f = (LIST)ARG0(arg);
! 2337: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
1.103 noro 2338: homo = QTOS((Q)nhomo);
1.108 ! noro 2339: if ( get_opt("dp",&val) && val ) retdp = 1;
! 2340: if ( get_opt("rref2",&val) && val ) nd_rref2 = 1;
1.103 noro 2341: } else
2342: error("nd_f4 : invalid argument");
1.108 ! noro 2343: nd_gr(f,v,m,homo,retdp,1,ord,rp);
1.40 noro 2344: }
2345:
1.97 noro 2346: void Pnd_gr(NODE arg,LIST *rp)
1.33 noro 2347: {
1.108 ! noro 2348: LIST f,v;
! 2349: int m,homo,retdp,ac;
! 2350: Obj val;
1.103 noro 2351: Q mq;
2352: Num nhomo;
2353: NODE node;
1.108 ! noro 2354: struct order_spec *ord;
1.33 noro 2355:
1.108 ! noro 2356: do_weyl = 0;
1.103 noro 2357: retdp = 0;
2358: if ( (ac=argc(arg)) == 4 ) {
1.108 ! noro 2359: asir_assert(ARG0(arg),O_LIST,"nd_gr");
! 2360: asir_assert(ARG1(arg),O_LIST,"nd_gr");
! 2361: asir_assert(ARG2(arg),O_N,"nd_gr");
! 2362: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2363: f = remove_zero_from_list(f);
! 2364: if ( !BDY(f) ) {
! 2365: *rp = f; return;
! 2366: }
1.103 noro 2367: mq = (Q)ARG2(arg);
2368: if ( mq && (PL(NM(mq)) > 1 || BD(NM(mq))[0] >= (1<<30)) ) {
2369: node = mknode(1,mq);
2370: Psetmod_ff(node,&val);
2371: m = -2;
2372: } else
2373: m = QTOS(mq);
1.108 ! noro 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);
1.103 noro 2381: homo = QTOS((Q)nhomo);
1.108 ! noro 2382: if ( get_opt("dp",&val) && val ) retdp = 1;
1.103 noro 2383: } else
2384: error("nd_gr : invalid argument");
1.108 ! noro 2385: nd_gr(f,v,m,homo,retdp,0,ord,rp);
1.58 noro 2386: }
2387:
1.97 noro 2388: void Pnd_gr_postproc(NODE arg,LIST *rp)
1.58 noro 2389: {
1.108 ! noro 2390: LIST f,v;
! 2391: int m,do_check;
1.102 noro 2392: Q mq;
2393: Obj val;
2394: NODE node;
1.108 ! noro 2395: struct order_spec *ord;
1.58 noro 2396:
1.108 ! noro 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: }
1.102 noro 2406: mq = (Q)ARG2(arg);
2407: if ( mq && (PL(NM(mq)) > 1 || BD(NM(mq))[0] >= (1<<30)) ) {
2408: node = mknode(1,mq);
2409: Psetmod_ff(node,&val);
2410: m = -2;
2411: } else
2412: m = QTOS(mq);
1.108 ! noro 2413: create_order_spec(0,ARG3(arg),&ord);
! 2414: do_check = ARG4(arg) ? 1 : 0;
! 2415: nd_gr_postproc(f,v,m,ord,do_check,rp);
1.36 noro 2416: }
2417:
1.97 noro 2418: void Pnd_gr_recompute_trace(NODE arg,LIST *rp)
1.86 noro 2419: {
1.108 ! noro 2420: LIST f,v,tlist;
! 2421: int m;
! 2422: struct order_spec *ord;
! 2423:
! 2424: do_weyl = 0;
! 2425: asir_assert(ARG0(arg),O_LIST,"nd_gr_recompute_trace");
! 2426: asir_assert(ARG1(arg),O_LIST,"nd_gr_recompute_trace");
! 2427: asir_assert(ARG2(arg),O_N,"nd_gr_recompute_trace");
! 2428: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2429: m = QTOS((Q)ARG2(arg));
! 2430: create_order_spec(0,ARG3(arg),&ord);
! 2431: tlist = (LIST)ARG4(arg);
! 2432: nd_gr_recompute_trace(f,v,m,ord,tlist,rp);
1.86 noro 2433: }
1.89 noro 2434:
1.90 noro 2435: Obj nd_btog_one(LIST f,LIST v,int m,struct order_spec *ord,LIST tlist,int pos);
2436: Obj nd_btog(LIST f,LIST v,int m,struct order_spec *ord,LIST tlist);
2437:
1.97 noro 2438: void Pnd_btog(NODE arg,Obj *rp)
1.89 noro 2439: {
1.108 ! noro 2440: LIST f,v,tlist;
! 2441: int m,ac,pos;
! 2442: struct order_spec *ord;
! 2443:
! 2444: do_weyl = 0;
! 2445: asir_assert(ARG0(arg),O_LIST,"nd_btog");
! 2446: asir_assert(ARG1(arg),O_LIST,"nd_btog");
! 2447: asir_assert(ARG2(arg),O_N,"nd_btog");
! 2448: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2449: m = QTOS((Q)ARG2(arg));
! 2450: create_order_spec(0,ARG3(arg),&ord);
! 2451: tlist = (LIST)ARG4(arg);
! 2452: if ( (ac = argc(arg)) == 6 ) {
! 2453: asir_assert(ARG5(arg),O_N,"nd_btog");
! 2454: pos = QTOS((Q)ARG5(arg));
! 2455: *rp = nd_btog_one(f,v,m,ord,tlist,pos);
! 2456: } else if ( ac == 5 )
! 2457: *rp = nd_btog(f,v,m,ord,tlist);
! 2458: else
! 2459: error("nd_btog : argument mismatch");
1.89 noro 2460: }
1.86 noro 2461:
1.97 noro 2462: void Pnd_weyl_gr_postproc(NODE arg,LIST *rp)
1.75 noro 2463: {
1.108 ! noro 2464: LIST f,v;
! 2465: int m,do_check;
! 2466: struct order_spec *ord;
! 2467:
! 2468: do_weyl = 1;
! 2469: asir_assert(ARG0(arg),O_LIST,"nd_gr");
! 2470: asir_assert(ARG1(arg),O_LIST,"nd_gr");
! 2471: asir_assert(ARG2(arg),O_N,"nd_gr");
! 2472: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2473: f = remove_zero_from_list(f);
! 2474: if ( !BDY(f) ) {
! 2475: *rp = f; do_weyl = 0; return;
! 2476: }
! 2477: m = QTOS((Q)ARG2(arg));
! 2478: create_order_spec(0,ARG3(arg),&ord);
! 2479: do_check = ARG4(arg) ? 1 : 0;
! 2480: nd_gr_postproc(f,v,m,ord,do_check,rp);
! 2481: do_weyl = 0;
1.75 noro 2482: }
2483:
1.97 noro 2484: void Pnd_gr_trace(NODE arg,LIST *rp)
1.36 noro 2485: {
1.108 ! noro 2486: LIST f,v;
! 2487: int m,homo,ac;
1.103 noro 2488: Num nhomo;
1.108 ! noro 2489: struct order_spec *ord;
1.36 noro 2490:
1.108 ! noro 2491: do_weyl = 0;
1.103 noro 2492: if ( (ac = argc(arg)) == 5 ) {
1.108 ! noro 2493: asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
! 2494: asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
! 2495: asir_assert(ARG2(arg),O_N,"nd_gr_trace");
! 2496: asir_assert(ARG3(arg),O_N,"nd_gr_trace");
! 2497: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2498: f = remove_zero_from_list(f);
! 2499: if ( !BDY(f) ) {
! 2500: *rp = f; return;
! 2501: }
! 2502: homo = QTOS((Q)ARG2(arg));
! 2503: m = QTOS((Q)ARG3(arg));
! 2504: create_order_spec(0,ARG4(arg),&ord);
1.103 noro 2505: } else if ( ac == 1 ) {
1.108 ! noro 2506: f = (LIST)ARG0(arg);
! 2507: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
1.103 noro 2508: homo = QTOS((Q)nhomo);
2509: } else
2510: error("nd_gr_trace : invalid argument");
1.108 ! noro 2511: nd_gr_trace(f,v,m,homo,0,ord,rp);
1.62 noro 2512: }
2513:
1.97 noro 2514: void Pnd_f4_trace(NODE arg,LIST *rp)
1.62 noro 2515: {
1.108 ! noro 2516: LIST f,v;
! 2517: int m,homo,ac;
1.103 noro 2518: Num nhomo;
1.108 ! noro 2519: struct order_spec *ord;
1.62 noro 2520:
1.108 ! noro 2521: do_weyl = 0;
1.103 noro 2522: if ( (ac = argc(arg))==5 ) {
1.108 ! noro 2523: asir_assert(ARG0(arg),O_LIST,"nd_f4_trace");
! 2524: asir_assert(ARG1(arg),O_LIST,"nd_f4_trace");
! 2525: asir_assert(ARG2(arg),O_N,"nd_f4_trace");
! 2526: asir_assert(ARG3(arg),O_N,"nd_f4_trace");
! 2527: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2528: f = remove_zero_from_list(f);
! 2529: if ( !BDY(f) ) {
! 2530: *rp = f; return;
! 2531: }
! 2532: homo = QTOS((Q)ARG2(arg));
! 2533: m = QTOS((Q)ARG3(arg));
! 2534: create_order_spec(0,ARG4(arg),&ord);
1.103 noro 2535: } else if ( ac == 1 ) {
1.108 ! noro 2536: f = (LIST)ARG0(arg);
! 2537: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
1.103 noro 2538: homo = QTOS((Q)nhomo);
2539: } else
2540: error("nd_gr_trace : invalid argument");
1.108 ! noro 2541: nd_gr_trace(f,v,m,homo,1,ord,rp);
1.11 noro 2542: }
2543:
1.97 noro 2544: void Pnd_weyl_gr(NODE arg,LIST *rp)
1.38 noro 2545: {
1.108 ! noro 2546: LIST f,v;
! 2547: int m,homo,retdp,ac;
! 2548: Obj val;
1.103 noro 2549: Num nhomo;
1.108 ! noro 2550: struct order_spec *ord;
1.38 noro 2551:
1.108 ! noro 2552: do_weyl = 1;
1.103 noro 2553: retdp = 0;
2554: if ( (ac = argc(arg)) == 4 ) {
1.108 ! noro 2555: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr");
! 2556: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr");
! 2557: asir_assert(ARG2(arg),O_N,"nd_weyl_gr");
! 2558: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2559: f = remove_zero_from_list(f);
! 2560: if ( !BDY(f) ) {
! 2561: *rp = f; do_weyl = 0; return;
! 2562: }
! 2563: m = QTOS((Q)ARG2(arg));
! 2564: create_order_spec(0,ARG3(arg),&ord);
! 2565: homo = 0;
! 2566: if ( get_opt("homo",&val) && val ) homo = 1;
! 2567: if ( get_opt("dp",&val) && val ) retdp = 1;
1.103 noro 2568: } else if ( ac == 1 ) {
1.108 ! noro 2569: f = (LIST)ARG0(arg);
! 2570: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
1.103 noro 2571: homo = QTOS((Q)nhomo);
1.108 ! noro 2572: if ( get_opt("dp",&val) && val ) retdp = 1;
1.103 noro 2573: } else
2574: error("nd_weyl_gr : invalid argument");
1.108 ! noro 2575: nd_gr(f,v,m,homo,retdp,0,ord,rp);
! 2576: do_weyl = 0;
1.38 noro 2577: }
2578:
1.97 noro 2579: void Pnd_weyl_gr_trace(NODE arg,LIST *rp)
1.38 noro 2580: {
1.108 ! noro 2581: LIST f,v;
! 2582: int m,homo,ac;
1.103 noro 2583: Num nhomo;
1.108 ! noro 2584: struct order_spec *ord;
1.38 noro 2585:
1.108 ! noro 2586: do_weyl = 1;
1.103 noro 2587: if ( (ac = argc(arg)) == 5 ) {
1.108 ! noro 2588: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr_trace");
! 2589: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr_trace");
! 2590: asir_assert(ARG2(arg),O_N,"nd_weyl_gr_trace");
! 2591: asir_assert(ARG3(arg),O_N,"nd_weyl_gr_trace");
! 2592: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2593: f = remove_zero_from_list(f);
! 2594: if ( !BDY(f) ) {
! 2595: *rp = f; do_weyl = 0; return;
! 2596: }
! 2597: homo = QTOS((Q)ARG2(arg));
! 2598: m = QTOS((Q)ARG3(arg));
! 2599: create_order_spec(0,ARG4(arg),&ord);
1.103 noro 2600: } else if ( ac == 1 ) {
1.108 ! noro 2601: f = (LIST)ARG0(arg);
! 2602: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
1.103 noro 2603: homo = QTOS((Q)nhomo);
2604: } else
2605: error("nd_weyl_gr_trace : invalid argument");
1.108 ! noro 2606: nd_gr_trace(f,v,m,homo,0,ord,rp);
! 2607: do_weyl = 0;
1.38 noro 2608: }
1.39 noro 2609:
1.83 noro 2610: void Pnd_nf(NODE arg,Obj *rp)
1.39 noro 2611: {
1.108 ! noro 2612: Obj f;
! 2613: LIST g,v;
! 2614: struct order_spec *ord;
! 2615:
! 2616: do_weyl = 0;
! 2617: asir_assert(ARG1(arg),O_LIST,"nd_nf");
! 2618: asir_assert(ARG2(arg),O_LIST,"nd_nf");
! 2619: asir_assert(ARG4(arg),O_N,"nd_nf");
! 2620: f = (Obj)ARG0(arg);
! 2621: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
! 2622: if ( !BDY(g) ) {
! 2623: *rp = f; return;
! 2624: }
! 2625: v = (LIST)ARG2(arg);
! 2626: create_order_spec(0,ARG3(arg),&ord);
! 2627: nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),ord,rp);
1.83 noro 2628: }
2629:
2630: void Pnd_weyl_nf(NODE arg,Obj *rp)
2631: {
1.108 ! noro 2632: Obj f;
! 2633: LIST g,v;
! 2634: struct order_spec *ord;
! 2635:
! 2636: do_weyl = 1;
! 2637: asir_assert(ARG1(arg),O_LIST,"nd_weyl_nf");
! 2638: asir_assert(ARG2(arg),O_LIST,"nd_weyl_nf");
! 2639: asir_assert(ARG4(arg),O_N,"nd_weyl_nf");
! 2640: f = (Obj)ARG0(arg);
! 2641: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
! 2642: if ( !BDY(g) ) {
! 2643: *rp = f; return;
! 2644: }
! 2645: v = (LIST)ARG2(arg);
! 2646: create_order_spec(0,ARG3(arg),&ord);
! 2647: nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),ord,rp);
1.39 noro 2648: }
2649:
1.11 noro 2650: /* for Weyl algebra */
2651:
1.97 noro 2652: void Pdp_weyl_gr_main(NODE arg,LIST *rp)
1.11 noro 2653: {
1.108 ! noro 2654: LIST f,v;
! 2655: Num homo;
! 2656: Q m;
! 2657: int modular,ac;
! 2658: struct order_spec *ord;
! 2659:
! 2660:
! 2661: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
! 2662: f = (LIST)ARG0(arg);
! 2663: f = remove_zero_from_list(f);
! 2664: if ( !BDY(f) ) {
! 2665: *rp = f; return;
! 2666: }
! 2667: if ( (ac = argc(arg)) == 5 ) {
! 2668: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
! 2669: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
! 2670: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
! 2671: v = (LIST)ARG1(arg);
! 2672: homo = (Num)ARG2(arg);
! 2673: m = (Q)ARG3(arg);
! 2674: if ( !m )
! 2675: modular = 0;
! 2676: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
! 2677: error("dp_weyl_gr_main : too large modulus");
! 2678: else
! 2679: modular = QTOS(m);
! 2680: create_order_spec(0,ARG4(arg),&ord);
! 2681: } else if ( current_option )
! 2682: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
! 2683: else if ( ac == 1 )
! 2684: parse_gr_option(f,0,&v,&homo,&modular,&ord);
! 2685: else
! 2686: error("dp_weyl_gr_main : invalid argument");
! 2687: do_weyl = 1;
! 2688: dp_gr_main(f,v,homo,modular,0,ord,rp);
! 2689: do_weyl = 0;
1.16 noro 2690: }
2691:
1.97 noro 2692: void Pdp_weyl_gr_f_main(NODE arg,LIST *rp)
1.16 noro 2693: {
1.108 ! noro 2694: LIST f,v;
! 2695: Num homo;
! 2696: struct order_spec *ord;
! 2697:
! 2698: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
! 2699: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
! 2700: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
! 2701: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
! 2702: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2703: f = remove_zero_from_list(f);
! 2704: if ( !BDY(f) ) {
! 2705: *rp = f; return;
! 2706: }
! 2707: homo = (Num)ARG2(arg);
! 2708: create_order_spec(0,ARG3(arg),&ord);
! 2709: do_weyl = 1;
! 2710: dp_gr_main(f,v,homo,0,1,ord,rp);
! 2711: do_weyl = 0;
1.11 noro 2712: }
2713:
1.97 noro 2714: void Pdp_weyl_f4_main(NODE arg,LIST *rp)
1.11 noro 2715: {
1.108 ! noro 2716: LIST f,v;
! 2717: struct order_spec *ord;
1.11 noro 2718:
1.108 ! noro 2719: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
! 2720: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
! 2721: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2722: f = remove_zero_from_list(f);
! 2723: if ( !BDY(f) ) {
! 2724: *rp = f; return;
! 2725: }
! 2726: create_order_spec(0,ARG2(arg),&ord);
! 2727: do_weyl = 1;
! 2728: dp_f4_main(f,v,ord,rp);
! 2729: do_weyl = 0;
1.11 noro 2730: }
2731:
1.97 noro 2732: void Pdp_weyl_f4_mod_main(NODE arg,LIST *rp)
1.11 noro 2733: {
1.108 ! noro 2734: LIST f,v;
! 2735: int m;
! 2736: struct order_spec *ord;
! 2737:
! 2738: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
! 2739: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
! 2740: asir_assert(ARG2(arg),O_N,"dp_f4_main");
! 2741: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
! 2742: f = remove_zero_from_list(f);
! 2743: if ( !BDY(f) ) {
! 2744: *rp = f; return;
! 2745: }
! 2746: if ( !m )
! 2747: error("dp_weyl_f4_mod_main : invalid argument");
! 2748: create_order_spec(0,ARG3(arg),&ord);
! 2749: do_weyl = 1;
! 2750: dp_f4_mod_main(f,v,m,ord,rp);
! 2751: do_weyl = 0;
1.11 noro 2752: }
2753:
1.97 noro 2754: void Pdp_weyl_gr_mod_main(NODE arg,LIST *rp)
1.11 noro 2755: {
1.108 ! noro 2756: LIST f,v;
! 2757: Num homo;
! 2758: int m;
! 2759: struct order_spec *ord;
! 2760:
! 2761: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
! 2762: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
! 2763: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
! 2764: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
! 2765: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2766: f = remove_zero_from_list(f);
! 2767: if ( !BDY(f) ) {
! 2768: *rp = f; return;
! 2769: }
! 2770: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
! 2771: if ( !m )
! 2772: error("dp_weyl_gr_mod_main : invalid argument");
! 2773: create_order_spec(0,ARG4(arg),&ord);
! 2774: do_weyl = 1;
! 2775: dp_gr_mod_main(f,v,homo,m,ord,rp);
! 2776: do_weyl = 0;
1.1 noro 2777: }
1.8 noro 2778:
1.57 noro 2779: VECT current_dl_weight_vector_obj;
1.24 noro 2780: int *current_dl_weight_vector;
1.99 noro 2781: int dp_negative_weight;
1.24 noro 2782:
1.97 noro 2783: void Pdp_set_weight(NODE arg,VECT *rp)
1.24 noro 2784: {
1.108 ! noro 2785: VECT v;
! 2786: int i,n;
! 2787: NODE node;
! 2788:
! 2789: if ( !arg )
! 2790: *rp = current_dl_weight_vector_obj;
! 2791: else if ( !ARG0(arg) ) {
! 2792: current_dl_weight_vector_obj = 0;
! 2793: current_dl_weight_vector = 0;
1.99 noro 2794: dp_negative_weight = 0;
1.108 ! noro 2795: *rp = 0;
! 2796: } else {
! 2797: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
! 2798: error("dp_set_weight : invalid argument");
! 2799: if ( OID(ARG0(arg)) == O_VECT )
! 2800: v = (VECT)ARG0(arg);
! 2801: else {
! 2802: node = (NODE)BDY((LIST)ARG0(arg));
! 2803: n = length(node);
! 2804: MKVECT(v,n);
! 2805: for ( i = 0; i < n; i++, node = NEXT(node) )
! 2806: BDY(v)[i] = BDY(node);
! 2807: }
! 2808: current_dl_weight_vector_obj = v;
! 2809: n = v->len;
! 2810: current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
! 2811: for ( i = 0; i < n; i++ )
! 2812: current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
1.99 noro 2813: for ( i = 0; i < n; i++ )
2814: if ( current_dl_weight_vector[i] < 0 ) break;
2815: if ( i < n )
2816: dp_negative_weight = 1;
2817: else
2818: dp_negative_weight = 0;
1.108 ! noro 2819: *rp = v;
! 2820: }
1.24 noro 2821: }
2822:
1.77 noro 2823: VECT current_module_weight_vector_obj;
2824: int *current_module_weight_vector;
2825:
1.97 noro 2826: void Pdp_set_module_weight(NODE arg,VECT *rp)
1.77 noro 2827: {
1.108 ! noro 2828: VECT v;
! 2829: int i,n;
! 2830: NODE node;
! 2831:
! 2832: if ( !arg )
! 2833: *rp = current_module_weight_vector_obj;
! 2834: else if ( !ARG0(arg) ) {
! 2835: current_module_weight_vector_obj = 0;
! 2836: current_module_weight_vector = 0;
! 2837: *rp = 0;
! 2838: } else {
! 2839: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
! 2840: error("dp_module_set_weight : invalid argument");
! 2841: if ( OID(ARG0(arg)) == O_VECT )
! 2842: v = (VECT)ARG0(arg);
! 2843: else {
! 2844: node = (NODE)BDY((LIST)ARG0(arg));
! 2845: n = length(node);
! 2846: MKVECT(v,n);
! 2847: for ( i = 0; i < n; i++, node = NEXT(node) )
! 2848: BDY(v)[i] = BDY(node);
! 2849: }
! 2850: current_module_weight_vector_obj = v;
! 2851: n = v->len;
! 2852: current_module_weight_vector = (int *)CALLOC(n,sizeof(int));
! 2853: for ( i = 0; i < n; i++ )
! 2854: current_module_weight_vector[i] = QTOS((Q)v->body[i]);
! 2855: *rp = v;
! 2856: }
1.77 noro 2857: }
2858:
1.93 noro 2859: extern Obj current_top_weight;
1.92 noro 2860: extern Obj nd_top_weight;
1.71 noro 2861:
1.92 noro 2862: void Pdp_set_top_weight(NODE arg,Obj *rp)
1.71 noro 2863: {
1.108 ! noro 2864: VECT v;
! 2865: MAT m;
! 2866: Obj obj;
! 2867: int i,j,n,id,row,col;
! 2868: Q *mi;
! 2869: NODE node;
! 2870:
! 2871: if ( !arg )
! 2872: *rp = current_top_weight;
! 2873: else if ( !ARG0(arg) ) {
! 2874: reset_top_weight();
! 2875: *rp = 0;
! 2876: } else {
! 2877: id = OID(ARG0(arg));
! 2878: if ( id != O_VECT && id != O_MAT && id != O_LIST )
! 2879: error("dp_set_top_weight : invalid argument");
! 2880: if ( id == O_LIST ) {
! 2881: node = (NODE)BDY((LIST)ARG0(arg));
! 2882: n = length(node);
! 2883: MKVECT(v,n);
! 2884: for ( i = 0; i < n; i++, node = NEXT(node) )
! 2885: BDY(v)[i] = BDY(node);
! 2886: obj = (Obj)v;
! 2887: } else
! 2888: obj = ARG0(arg);
! 2889: if ( OID(obj) == O_VECT ) {
! 2890: v = (VECT)obj;
! 2891: for ( i = 0; i < v->len; i++ )
! 2892: if ( !INT(BDY(v)[i]) || (BDY(v)[i] && SGN((Q)BDY(v)[i]) < 0) )
! 2893: error("dp_set_top_weight : each element must be a non-negative integer");
! 2894: } else {
! 2895: m = (MAT)obj; row = m->row; col = m->col;
! 2896: for ( i = 0; i < row; i++ )
! 2897: for ( j = 0, mi = (Q *)BDY(m)[i]; j < col; j++ )
! 2898: if ( !INT(mi[j]) || (mi[j] && SGN((Q)mi[j]) < 0) )
! 2899: error("dp_set_top_weight : each element must be a non-negative integer");
! 2900: }
1.92 noro 2901: current_top_weight = obj;
1.108 ! noro 2902: nd_top_weight = obj;
! 2903: *rp = current_top_weight;
! 2904: }
1.71 noro 2905: }
2906:
1.72 noro 2907: LIST get_denomlist();
2908:
2909: void Pdp_get_denomlist(LIST *rp)
2910: {
1.108 ! noro 2911: *rp = get_denomlist();
1.72 noro 2912: }
2913:
1.24 noro 2914: static VECT current_weyl_weight_vector_obj;
2915: int *current_weyl_weight_vector;
1.15 noro 2916:
1.97 noro 2917: void Pdp_weyl_set_weight(NODE arg,VECT *rp)
1.15 noro 2918: {
1.108 ! noro 2919: VECT v;
! 2920: NODE node;
! 2921: int i,n;
! 2922:
! 2923: if ( !arg )
! 2924: *rp = current_weyl_weight_vector_obj;
! 2925: else if ( !ARG0(arg) ) {
! 2926: current_weyl_weight_vector_obj = 0;
! 2927: current_weyl_weight_vector = 0;
! 2928: *rp = 0;
! 2929: } else {
! 2930: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
! 2931: error("dp_weyl_set_weight : invalid argument");
! 2932: if ( OID(ARG0(arg)) == O_VECT )
! 2933: v = (VECT)ARG0(arg);
! 2934: else {
! 2935: node = (NODE)BDY((LIST)ARG0(arg));
! 2936: n = length(node);
! 2937: MKVECT(v,n);
! 2938: for ( i = 0; i < n; i++, node = NEXT(node) )
! 2939: BDY(v)[i] = BDY(node);
! 2940: }
! 2941: current_weyl_weight_vector_obj = v;
! 2942: n = v->len;
! 2943: current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
! 2944: for ( i = 0; i < n; i++ )
! 2945: current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
! 2946: *rp = v;
! 2947: }
1.25 noro 2948: }
2949:
1.82 noro 2950: NODE mono_raddec(NODE ideal);
2951:
2952: void Pdp_mono_raddec(NODE arg,LIST *rp)
2953: {
1.108 ! noro 2954: NODE ideal,rd,t,t1,r,r1,u;
! 2955: VL vl0,vl;
! 2956: int nv,i,bpi;
! 2957: int *s;
! 2958: DP dp;
! 2959: P *v;
! 2960: LIST l;
! 2961:
! 2962: ideal = BDY((LIST)ARG0(arg));
! 2963: if ( !ideal ) *rp = (LIST)ARG0(arg);
! 2964: else {
! 2965: t = BDY((LIST)ARG1(arg));
! 2966: nv = length(t);
! 2967: v = (P *)MALLOC(nv*sizeof(P));
! 2968: for ( vl0 = 0, i = 0; t; t = NEXT(t), i++ ) {
! 2969: NEXTVL(vl0,vl); VR(vl) = VR((P)BDY(t));
! 2970: MKV(VR(vl),v[i]);
! 2971: }
! 2972: if ( vl0 ) NEXT(vl) = 0;
! 2973: for ( t = 0, r = ideal; r; r = NEXT(r) ) {
! 2974: ptod(CO,vl0,BDY(r),&dp); MKNODE(t1,dp,t); t = t1;
! 2975: }
! 2976: rd = mono_raddec(t);
! 2977: r = 0;
! 2978: bpi = (sizeof(int)/sizeof(char))*8;
! 2979: for ( u = rd; u; u = NEXT(u) ) {
! 2980: s = (int *)BDY(u);
! 2981: for ( i = nv-1, t = 0; i >= 0; i-- )
! 2982: if ( s[i/bpi]&(1<<(i%bpi)) ) {
! 2983: MKNODE(t1,v[i],t); t = t1;
! 2984: }
! 2985: MKLIST(l,t); MKNODE(r1,l,r); r = r1;
! 2986: }
! 2987: MKLIST(*rp,r);
! 2988: }
1.82 noro 2989: }
2990:
1.84 noro 2991: void Pdp_mono_reduce(NODE arg,LIST *rp)
2992: {
1.108 ! noro 2993: NODE t,t0,t1,r0,r;
! 2994: int i,n;
! 2995: DP m;
! 2996: DP *a;
! 2997:
! 2998: t0 = BDY((LIST)ARG0(arg));
! 2999: t1 = BDY((LIST)ARG1(arg));
! 3000: n = length(t0);
! 3001: a = (DP *)MALLOC(n*sizeof(DP));
! 3002: for ( i = 0; i < n; i++, t0 = NEXT(t0) ) a[i] = (DP)BDY(t0);
! 3003: for ( t = t1; t; t = NEXT(t) ) {
! 3004: m = (DP)BDY(t);
! 3005: for ( i = 0; i < n; i++ )
! 3006: if ( a[i] && dp_redble(a[i],m) ) a[i] = 0;
! 3007: }
! 3008: for ( i = n-1, r0 = 0; i >= 0; i-- )
! 3009: if ( a[i] ) { NEXTNODE(r0,r); BDY(r) = a[i]; }
! 3010: if ( r0 ) NEXT(r) = 0;
! 3011: MKLIST(*rp,r0);
1.84 noro 3012: }
3013:
1.94 noro 3014: #define BLEN (8*sizeof(unsigned long))
3015:
3016: void showmat2(unsigned long **a,int row,int col)
3017: {
3018: int i,j;
3019:
3020: for ( i = 0; i < row; i++, putchar('\n') )
3021: for ( j = 0; j < col; j++ )
1.108 ! noro 3022: if ( a[i][j/BLEN] & (1L<<(j%BLEN)) ) putchar('1');
1.94 noro 3023: else putchar('0');
3024: }
3025:
3026: int rref2(unsigned long **a,int row,int col)
3027: {
3028: int i,j,k,l,s,wcol,wj;
3029: unsigned long bj;
3030: unsigned long *ai,*ak,*as,*t;
3031: int *pivot;
3032:
3033: wcol = (col+BLEN-1)/BLEN;
3034: pivot = (int *)MALLOC_ATOMIC(row*sizeof(int));
3035: i = 0;
3036: for ( j = 0; j < col; j++ ) {
1.108 ! noro 3037: wj = j/BLEN; bj = 1L<<(j%BLEN);
1.94 noro 3038: for ( k = i; k < row; k++ )
1.108 ! noro 3039: if ( a[k][wj] & bj ) break;
1.94 noro 3040: if ( k == row ) continue;
3041: pivot[i] = j;
3042: if ( k != i ) {
3043: t = a[i]; a[i] = a[k]; a[k] = t;
1.108 ! noro 3044: }
! 3045: ai = a[i];
1.94 noro 3046: for ( k = i+1; k < row; k++ ) {
1.108 ! noro 3047: ak = a[k];
! 3048: if ( ak[wj] & bj ) {
! 3049: for ( l = wj; l < wcol; l++ )
! 3050: ak[l] ^= ai[l];
! 3051: }
! 3052: }
! 3053: i++;
1.94 noro 3054: }
3055: for ( k = i-1; k >= 0; k-- ) {
3056: j = pivot[k]; wj = j/BLEN; bj = 1L<<(j%BLEN);
1.108 ! noro 3057: ak = a[k];
1.94 noro 3058: for ( s = 0; s < k; s++ ) {
1.108 ! noro 3059: as = a[s];
1.94 noro 3060: if ( as[wj] & bj ) {
3061: for ( l = wj; l < wcol; l++ )
1.108 ! noro 3062: as[l] ^= ak[l];
! 3063: }
! 3064: }
1.94 noro 3065: }
3066: return i;
3067: }
3068:
3069: void Pdp_rref2(NODE arg,VECT *rp)
3070: {
3071: VECT f,term,ret;
3072: int row,col,wcol,size,nv,i,j,rank,td;
3073: unsigned long **mat;
3074: unsigned long *v;
3075: DL d;
3076: DL *t;
3077: DP dp;
3078: MP m,m0;
3079:
3080: f = (VECT)ARG0(arg);
3081: row = f->len;
3082: term = (VECT)ARG1(arg);
3083: col = term->len;
3084: mat = (unsigned long **)MALLOC(row*sizeof(unsigned long *));
3085: size = sizeof(unsigned long)*((col+BLEN-1)/BLEN);
3086: nv = ((DP)term->body[0])->nv;
3087: t = (DL *)MALLOC(col*sizeof(DL));
3088: for ( i = 0; i < col; i++ ) t[i] = BDY((DP)BDY(term)[i])->dl;
3089: for ( i = 0; i < row; i++ ) {
3090: v = mat[i] = (unsigned long *)MALLOC_ATOMIC_IGNORE_OFF_PAGE(size);
1.108 ! noro 3091: bzero(v,size);
! 3092: for ( j = 0, m = BDY((DP)BDY(f)[i]); m; m = NEXT(m) ) {
! 3093: d = m->dl;
! 3094: for ( ; !dl_equal(nv,d,t[j]); j++ );
! 3095: v[j/BLEN] |= 1L <<(j%BLEN);
! 3096: }
1.94 noro 3097: }
3098: rank = rref2(mat,row,col);
3099: MKVECT(ret,rank);
3100: *rp = ret;
3101: for ( i = 0; i < rank; i++ ) {
3102: v = mat[i];
1.108 ! noro 3103: m0 = 0;
! 3104: td = 0;
1.94 noro 3105: for ( j = 0; j < col; j++ ) {
1.108 ! noro 3106: if ( v[j/BLEN] & (1L<<(j%BLEN)) ) {
! 3107: NEXTMP(m0,m);
! 3108: m->dl = t[j];
! 3109: m->c = (Obj)ONE;
! 3110: td = MAX(td,m->dl->td);
! 3111: }
! 3112: }
! 3113: NEXT(m) = 0;
! 3114: MKDP(nv,m0,dp);
! 3115: dp->sugar = td;
1.94 noro 3116: BDY(ret)[i] = (pointer)dp;
3117: }
3118: }
3119:
1.95 noro 3120: #define HDL(f) (BDY(f)->dl)
3121:
3122: NODE sumi_criB(int nv,NODE d,DP *f,int m)
3123: {
3124: LIST p;
3125: NODE r0,r;
3126: int p0,p1;
3127: DL p2,lcm;
3128:
3129: NEWDL(lcm,nv);
3130: r0 = 0;
3131: for ( ; d; d = NEXT(d) ) {
1.108 ! noro 3132: p = (LIST)BDY(d);
! 3133: p0 = QTOS((Q)ARG0(BDY(p)));
! 3134: p1 = QTOS((Q)ARG1(BDY(p)));
! 3135: p2 = HDL((DP)ARG2(BDY(p)));
1.95 noro 3136: if(!_dl_redble(HDL((DP)f[m]),p2,nv) ||
3137: dl_equal(nv,lcm_of_DL(nv,HDL(f[p0]),HDL(f[m]),lcm),p2) ||
3138: dl_equal(nv,lcm_of_DL(nv,HDL(f[p1]),HDL(f[m]),lcm),p2) ) {
1.108 ! noro 3139: NEXTNODE(r0,r);
! 3140: BDY(r) = p;
! 3141: }
1.95 noro 3142: }
3143: if ( r0 ) NEXT(r) = 0;
3144: return r0;
3145: }
3146:
3147: NODE sumi_criFMD(int nv,DP *f,int m)
3148: {
3149: DL *a;
3150: DL l1,dl1,dl2;
3151: int i,j,k,k2;
3152: NODE r,r1,nd;
3153: MP mp;
3154: DP u;
3155: Q iq,mq;
3156: LIST list;
3157:
3158: /* a[i] = lcm(LT(f[i]),LT(f[m])) */
3159: a = (DL *)ALLOCA(m*sizeof(DL));
3160: for ( i = 0; i < m; i++ ) {
3161: a[i] = lcm_of_DL(nv,HDL(f[i]),HDL(f[m]),0);
3162: }
3163: r = 0;
3164: for( i = 0; i < m; i++) {
3165: l1 = a[i];
3166: if ( !l1 ) continue;
3167: /* Tkm = Tim (k<i) */
3168: for( k = 0; k < i; k++)
3169: if( dl_equal(nv,l1,a[k]) ) break;
3170: if( k == i ){
3171: /* Tk|Tim && Tkm != Tim (k<m) */
1.108 ! noro 3172: for ( k2 = 0; k2 < m; k2++ )
! 3173: if ( _dl_redble(HDL(f[k2]),l1,nv) &&
! 3174: !dl_equal(nv,l1,a[k2]) ) break;
! 3175: if ( k2 == m ) {
1.95 noro 3176: dl1 = HDL(f[i]); dl2 = HDL(f[m]);
3177: for ( k2 = 0; k2 < nv; k2++ )
3178: if ( dl1->d[k2] && dl2->d[k2] ) break;
3179: if ( k2 < nv ) {
1.105 noro 3180: NEWMP(mp); mp->dl = l1; C(mp) = (Obj)ONE;
1.95 noro 3181: NEXT(mp) = 0; MKDP(nv,mp,u); u->sugar = l1->td;
1.108 ! noro 3182: STOQ(i,iq); STOQ(m,mq);
! 3183: nd = mknode(3,iq,mq,u);
! 3184: MKLIST(list,nd);
! 3185: MKNODE(r1,list,r);
! 3186: r = r1;
! 3187: }
! 3188: }
1.95 noro 3189: }
3190: }
3191: return r;
3192: }
3193:
3194: LIST sumi_updatepairs(LIST d,DP *f,int m)
3195: {
3196: NODE old,new,t;
3197: LIST l;
3198: int nv;
3199:
3200: nv = f[0]->nv;
3201: old = sumi_criB(nv,BDY(d),f,m);
3202: new = sumi_criFMD(nv,f,m);
3203: if ( !new ) new = old;
3204: else {
3205: for ( t = new ; NEXT(t); t = NEXT(t) );
1.108 ! noro 3206: NEXT(t) = old;
1.95 noro 3207: }
3208: MKLIST(l,new);
3209: return l;
3210: }
3211:
3212: VECT ltov(LIST l)
3213: {
3214: NODE n;
3215: int i,len;
3216: VECT v;
3217:
3218: n = BDY(l);
3219: len = length(n);
3220: MKVECT(v,len);
3221: for ( i = 0; i < len; i++, n = NEXT(n) )
3222: BDY(v)[i] = BDY(n);
3223: return v;
3224: }
3225:
3226: DL subdl(int nv,DL d1,DL d2)
3227: {
3228: int i;
3229: DL d;
3230:
3231: NEWDL(d,nv);
3232: d->td = d1->td-d2->td;
3233: for ( i = 0; i < nv; i++ )
3234: d->d[i] = d1->d[i]-d2->d[i];
3235: return d;
3236: }
3237:
3238: DP dltodp(int nv,DL d)
3239: {
3240: MP mp;
3241: DP dp;
3242:
1.105 noro 3243: NEWMP(mp); mp->dl = d; C(mp) = (Obj)ONE;
1.95 noro 3244: NEXT(mp) = 0; MKDP(nv,mp,dp); dp->sugar = d->td;
3245: return dp;
3246: }
3247:
3248: LIST sumi_simplify(int nv,DL t,DP p,NODE f2,int simp)
3249: {
3250: DL d,h,hw;
3251: DP u,w,dp;
3252: int n,i,last;
3253: LIST *v;
3254: LIST list;
3255: NODE s,r;
3256:
3257: d = t; u = p;
3258: /* only the last history is used */
3259: if ( f2 && simp && t->td != 0 ) {
3260: adddl(nv,t,HDL(p),&h);
3261: n = length(f2);
3262: last = 1;
3263: if ( simp > 1 ) last = n;
3264: v = (LIST *)ALLOCA(n*sizeof(LIST));
3265: for ( r = f2, i = 0; r; r = NEXT(r), i++ ) v[n-i-1] = BDY(r);
3266: for ( i = 0; i < last; i++ ) {
3267: for ( s = BDY((LIST)v[i]); s; s = NEXT(s) ) {
1.108 ! noro 3268: w = (DP)BDY(s); hw = HDL(w);
1.95 noro 3269: if ( _dl_redble(hw,h,nv) ) {
1.108 ! noro 3270: u = w;
! 3271: d = subdl(nv,h,hw);
! 3272: goto fin;
! 3273: }
1.95 noro 3274: }
3275: }
3276: }
3277: fin:
3278: dp = dltodp(nv,d);
3279: r = mknode(2,dp,u);
3280: MKLIST(list,r);
3281: return list;
3282: }
3283:
3284: LIST sumi_symbolic(NODE l,int q,NODE f2,DP *g,int simp)
3285: {
3286: int nv;
3287: NODE t,r;
3288: NODE f0,f,fd0,fd,done0,done,red0,red;
3289: DL h,d;
3290: DP mul;
3291: int m;
3292: LIST tp,l0,l1,l2,l3,list;
3293: VECT v0,v1,v2,v3;
3294:
3295: nv = ((DP)BDY(l))->nv;
3296: t = 0;
3297:
3298: f0 = 0; fd0 = 0; done0 = 0; red0 = 0;
3299:
3300: for ( ; l; l = NEXT(l) ) {
3301: t = symb_merge(t,dp_dllist((DP)BDY(l)),nv);
3302: NEXTNODE(fd0,fd); BDY(fd) = BDY(l);
3303: }
3304:
3305: while ( t ) {
1.108 ! noro 3306: h = (DL)BDY(t);
! 3307: NEXTNODE(done0,done); BDY(done) = dltodp(nv,h);
! 3308: t = NEXT(t);
1.95 noro 3309: for(m = 0; m < q; m++)
1.108 ! noro 3310: if ( _dl_redble(HDL(g[m]),h,nv) ) break;
1.95 noro 3311: if ( m == q ) {
3312: } else {
1.108 ! noro 3313: d = subdl(nv,h,HDL(g[m]));
1.95 noro 3314: tp = sumi_simplify(nv,d,g[m],f2,simp);
3315:
1.108 ! noro 3316: muldm(CO,ARG1(BDY(tp)),BDY((DP)ARG0(BDY(tp))),&mul);
1.95 noro 3317: t = symb_merge(t,NEXT(dp_dllist(mul)),nv);
3318:
1.108 ! noro 3319: NEXTNODE(f0,f); BDY(f) = tp;
! 3320: NEXTNODE(fd0,fd); BDY(fd) = mul;
! 3321: NEXTNODE(red0,red); BDY(red) = mul;
1.95 noro 3322: }
3323: }
3324: if ( fd0 ) NEXT(fd) = 0; MKLIST(l0,fd0);
3325: v0 = ltov(l0);
3326: if ( done0 ) NEXT(done) = 0; MKLIST(l1,done0);
3327: v1 = ltov(l1);
3328: if ( f0 ) NEXT(f) = 0; MKLIST(l2,f0);
3329: v2 = ltov(l2);
3330: if ( red0 ) NEXT(red) = 0; MKLIST(l3,red0);
3331: v3 = ltov(l3);
3332: r = mknode(4,v0,v1,v2,v3);
3333: MKLIST(list,r);
3334: return list;
3335: }
3336:
3337: void Psumi_symbolic(NODE arg,LIST *rp)
3338: {
3339: NODE l,f2;
3340: DP *g;
3341: int q,simp;
3342:
3343: l = BDY((LIST)ARG0(arg));
3344: q = QTOS((Q)ARG1(arg));
3345: f2 = BDY((LIST)ARG2(arg));
3346: g = (DP *)BDY((VECT)ARG3(arg));
3347: simp = QTOS((Q)ARG4(arg));
3348: *rp = sumi_symbolic(l,q,f2,g,simp);
3349: }
3350:
3351: void Psumi_updatepairs(NODE arg,LIST *rp)
3352: {
3353: LIST d,l;
3354: DP *f;
3355: int m;
3356:
3357: d = (LIST)ARG0(arg);
3358: f = (DP *)BDY((VECT)ARG1(arg));
3359: m = QTOS((Q)ARG2(arg));
3360: *rp = sumi_updatepairs(d,f,m);
3361: }
3362:
1.25 noro 3363: LIST remove_zero_from_list(LIST l)
3364: {
1.108 ! noro 3365: NODE n,r0,r;
! 3366: LIST rl;
1.25 noro 3367:
1.108 ! noro 3368: asir_assert(l,O_LIST,"remove_zero_from_list");
! 3369: n = BDY(l);
! 3370: for ( r0 = 0; n; n = NEXT(n) )
! 3371: if ( BDY(n) ) {
! 3372: NEXTNODE(r0,r);
! 3373: BDY(r) = BDY(n);
! 3374: }
! 3375: if ( r0 )
! 3376: NEXT(r) = 0;
! 3377: MKLIST(rl,r0);
! 3378: return rl;
1.26 noro 3379: }
3380:
3381: int get_field_type(P p)
3382: {
1.108 ! noro 3383: int type,t;
! 3384: DCP dc;
1.26 noro 3385:
1.108 ! noro 3386: if ( !p )
! 3387: return 0;
! 3388: else if ( NUM(p) )
! 3389: return NID((Num)p);
! 3390: else {
! 3391: type = 0;
! 3392: for ( dc = DC(p); dc; dc = NEXT(dc) ) {
! 3393: t = get_field_type(COEF(dc));
! 3394: if ( !t )
! 3395: continue;
! 3396: if ( t < 0 )
! 3397: return t;
! 3398: if ( !type )
! 3399: type = t;
! 3400: else if ( t != type )
! 3401: return -1;
! 3402: }
! 3403: return type;
! 3404: }
1.52 noro 3405: }
3406:
3407: void Pdpv_ord(NODE arg,Obj *rp)
3408: {
1.108 ! noro 3409: int ac,id;
! 3410: LIST shift;
1.52 noro 3411:
1.108 ! noro 3412: ac = argc(arg);
! 3413: if ( ac ) {
! 3414: id = QTOS((Q)ARG0(arg));
! 3415: if ( ac > 1 && ARG1(arg) && OID((Obj)ARG1(arg))==O_LIST )
! 3416: shift = (LIST)ARG1(arg);
! 3417: else
! 3418: shift = 0;
! 3419: create_modorder_spec(id,shift,&dp_current_modspec);
! 3420: }
! 3421: *rp = dp_current_modspec->obj;
1.52 noro 3422: }
3423:
1.105 noro 3424: extern int dpm_ispot;
3425:
3426: void Pdpm_ord(NODE arg,LIST *rp)
3427: {
3428: Q q;
3429: NODE nd;
1.108 ! noro 3430: struct order_spec *spec;
! 3431:
! 3432: if ( arg ) {
1.105 noro 3433: nd = BDY((LIST)ARG0(arg));
1.108 ! noro 3434: if ( !create_order_spec(0,(Obj)ARG1(nd),&spec) )
! 3435: error("dpm_ord : invalid order specification");
! 3436: initdpm(spec,QTOS((Q)ARG0(nd)));
! 3437: }
1.105 noro 3438: STOQ(dpm_ispot,q);
3439: nd = mknode(2,q,dp_current_spec->obj);
3440: MKLIST(*rp,nd);
3441: }
3442:
3443: void Pdpm_hm(NODE arg,DPM *rp)
3444: {
1.108 ! noro 3445: DPM p;
1.105 noro 3446:
1.108 ! noro 3447: p = (DPM)ARG0(arg); asir_assert(p,O_DPM,"dpm_hm");
! 3448: dpm_hm(p,rp);
1.105 noro 3449: }
3450:
3451: void Pdpm_ht(NODE arg,DPM *rp)
3452: {
1.108 ! noro 3453: DPM p;
1.105 noro 3454:
1.108 ! noro 3455: p = (DPM)ARG0(arg); asir_assert(p,O_DPM,"dp_ht");
! 3456: dpm_ht(p,rp);
1.105 noro 3457: }
3458:
3459: void Pdpm_hc(NODE arg,Obj *rp)
3460: {
1.108 ! noro 3461: asir_assert(ARG0(arg),O_DPM,"dpm_hc");
! 3462: if ( !ARG0(arg) )
! 3463: *rp = 0;
! 3464: else
! 3465: *rp = BDY((DPM)ARG0(arg))->c;
1.105 noro 3466: }
3467:
3468:
1.52 noro 3469: void Pdpv_ht(NODE arg,LIST *rp)
3470: {
1.108 ! noro 3471: NODE n;
! 3472: DP ht;
! 3473: int pos;
! 3474: DPV p;
! 3475: Q q;
! 3476:
! 3477: asir_assert(ARG0(arg),O_DPV,"dpv_ht");
! 3478: p = (DPV)ARG0(arg);
! 3479: pos = dpv_hp(p);
! 3480: if ( pos < 0 )
! 3481: ht = 0;
! 3482: else
! 3483: dp_ht(BDY(p)[pos],&ht);
! 3484: STOQ(pos,q);
! 3485: n = mknode(2,q,ht);
! 3486: MKLIST(*rp,n);
1.52 noro 3487: }
3488:
3489: void Pdpv_hm(NODE arg,LIST *rp)
3490: {
1.108 ! noro 3491: NODE n;
! 3492: DP ht;
! 3493: int pos;
! 3494: DPV p;
! 3495: Q q;
! 3496:
! 3497: asir_assert(ARG0(arg),O_DPV,"dpv_hm");
! 3498: p = (DPV)ARG0(arg);
! 3499: pos = dpv_hp(p);
! 3500: if ( pos < 0 )
! 3501: ht = 0;
! 3502: else
! 3503: dp_hm(BDY(p)[pos],&ht);
! 3504: STOQ(pos,q);
! 3505: n = mknode(2,q,ht);
! 3506: MKLIST(*rp,n);
1.52 noro 3507: }
3508:
3509: void Pdpv_hc(NODE arg,LIST *rp)
3510: {
1.108 ! noro 3511: NODE n;
! 3512: P hc;
! 3513: int pos;
! 3514: DPV p;
! 3515: Q q;
! 3516:
! 3517: asir_assert(ARG0(arg),O_DPV,"dpv_hc");
! 3518: p = (DPV)ARG0(arg);
! 3519: pos = dpv_hp(p);
! 3520: if ( pos < 0 )
! 3521: hc = 0;
! 3522: else
! 3523: hc = (P)BDY(BDY(p)[pos])->c;
! 3524: STOQ(pos,q);
! 3525: n = mknode(2,q,hc);
! 3526: MKLIST(*rp,n);
1.52 noro 3527: }
3528:
3529: int dpv_hp(DPV p)
3530: {
1.108 ! noro 3531: int len,i,maxp,maxw,w,slen;
! 3532: int *shift;
! 3533: DP *e;
! 3534:
! 3535: len = p->len;
! 3536: e = p->body;
! 3537: slen = dp_current_modspec->len;
! 3538: shift = dp_current_modspec->degree_shift;
! 3539: switch ( dp_current_modspec->id ) {
! 3540: case ORD_REVGRADLEX:
! 3541: for ( maxp = -1, i = 0; i < len; i++ )
! 3542: if ( !e[i] ) continue;
! 3543: else if ( maxp < 0 ) {
! 3544: maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
! 3545: } else {
! 3546: w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
! 3547: if ( w >= maxw ) {
! 3548: maxw = w; maxp = i;
! 3549: }
! 3550: }
! 3551: return maxp;
! 3552: case ORD_GRADLEX:
! 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: break;
! 3565: case ORD_LEX:
! 3566: for ( i = 0; i < len; i++ )
! 3567: if ( e[i] ) return i;
! 3568: return -1;
! 3569: break;
! 3570: }
1.15 noro 3571: }
1.81 noro 3572:
3573: int get_opt(char *key0,Obj *r) {
3574: NODE tt,p;
3575: char *key;
3576:
3577: if ( current_option ) {
3578: for ( tt = current_option; tt; tt = NEXT(tt) ) {
3579: p = BDY((LIST)BDY(tt));
3580: key = BDY((STRING)BDY(p));
3581: /* value = (Obj)BDY(NEXT(p)); */
3582: if ( !strcmp(key,key0) ) {
1.108 ! noro 3583: *r = (Obj)BDY(NEXT(p));
! 3584: return 1;
! 3585: }
1.81 noro 3586: }
3587: }
3588: return 0;
3589: }
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 / asir2000 / builtin