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