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