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