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