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