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