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