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