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