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