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