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