Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.28
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
9: * conditions of this Agreement. For the avoidance of doubt, you acquire
10: * only a limited right to use the SOFTWARE hereunder, and FLL or any
11: * third party developer retains all rights, including but not limited to
12: * copyrights, in and to the SOFTWARE.
13: *
14: * (1) FLL does not grant you a license in any way for commercial
15: * purposes. You may use the SOFTWARE only for non-commercial and
16: * non-profit purposes only, such as academic, research and internal
17: * business use.
18: * (2) The SOFTWARE is protected by the Copyright Law of Japan and
19: * international copyright treaties. If you make copies of the SOFTWARE,
20: * with or without modification, as permitted hereunder, you shall affix
21: * to all such copies of the SOFTWARE the above copyright notice.
22: * (3) An explicit reference to this SOFTWARE and its copyright owner
23: * shall be made on your publication or presentation in any form of the
24: * results obtained by use of the SOFTWARE.
25: * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.6 noro 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.5 noro 27: * for such modification or the source code of the modified part of the
28: * SOFTWARE.
29: *
30: * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
31: * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
32: * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
33: * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
34: * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
35: * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
36: * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
37: * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
38: * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
39: * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
40: * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
41: * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
42: * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
43: * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
44: * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
45: * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
46: * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
47: *
1.28 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.27 2003/01/06 01:16:37 noro Exp $
1.5 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "base.h"
52: #include "parse.h"
53:
1.8 noro 54: extern int dp_nelim;
55: extern int dp_order_pair_length;
56: extern struct order_pair *dp_order_pair;
57: extern struct order_spec dp_current_spec;
58:
1.11 noro 59: int do_weyl;
1.1 noro 60:
61: void Pdp_ord(), Pdp_ptod(), Pdp_dtop();
62: void Pdp_ptozp(), Pdp_ptozp2(), Pdp_red(), Pdp_red2(), Pdp_lcm(), Pdp_redble();
63: void Pdp_sp(), Pdp_hm(), Pdp_ht(), Pdp_hc(), Pdp_rest(), Pdp_td(), Pdp_sugar();
64: void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv();
65: void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat();
1.9 noro 66: void Pdp_nf(),Pdp_true_nf();
1.1 noro 67: void Pdp_nf_mod(),Pdp_true_nf_mod();
68: void Pdp_criB(),Pdp_nelim();
1.9 noro 69: void Pdp_minp(),Pdp_sp_mod();
1.1 noro 70: void Pdp_homo(),Pdp_dehomo();
1.16 noro 71: void Pdp_gr_mod_main(),Pdp_gr_f_main();
1.1 noro 72: void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags();
1.16 noro 73: void Pdp_f4_main(),Pdp_f4_mod_main(),Pdp_f4_f_main();
1.1 noro 74: void Pdp_gr_print();
1.28 ! noro 75: void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_mdtod(), Pdp_nf_tab_f();
1.8 noro 76: void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
77: void Pdp_cont();
1.22 noro 78: void Pdp_gr_checklist();
1.1 noro 79:
1.13 noro 80: void Pdp_weyl_red();
81: void Pdp_weyl_sp();
82: void Pdp_weyl_nf(),Pdp_weyl_nf_mod();
1.16 noro 83: void Pdp_weyl_gr_main(),Pdp_weyl_gr_mod_main(),Pdp_weyl_gr_f_main();
84: void Pdp_weyl_f4_main(),Pdp_weyl_f4_mod_main(),Pdp_weyl_f4_f_main();
1.13 noro 85: void Pdp_weyl_mul(),Pdp_weyl_mul_mod();
1.15 noro 86: void Pdp_weyl_set_weight();
1.24 noro 87: void Pdp_set_weight();
1.16 noro 88: void Pdp_nf_f(),Pdp_weyl_nf_f();
89: void Pdp_lnf_f();
1.11 noro 90:
1.25 noro 91: LIST remove_zero_from_list(LIST);
92:
1.1 noro 93: struct ftab dp_tab[] = {
1.8 noro 94: /* content reduction */
1.1 noro 95: {"dp_ptozp",Pdp_ptozp,1},
96: {"dp_ptozp2",Pdp_ptozp2,2},
97: {"dp_prim",Pdp_prim,1},
1.8 noro 98: {"dp_red_coef",Pdp_red_coef,2},
99: {"dp_cont",Pdp_cont,1},
100:
1.11 noro 101: /* polynomial ring */
1.8 noro 102: /* s-poly */
103: {"dp_sp",Pdp_sp,2},
104: {"dp_sp_mod",Pdp_sp_mod,3},
105:
106: /* m-reduction */
1.1 noro 107: {"dp_red",Pdp_red,3},
108: {"dp_red_mod",Pdp_red_mod,4},
1.8 noro 109:
110: /* normal form */
1.1 noro 111: {"dp_nf",Pdp_nf,4},
1.16 noro 112: {"dp_nf_f",Pdp_nf_f,4},
1.1 noro 113: {"dp_true_nf",Pdp_true_nf,4},
114: {"dp_nf_mod",Pdp_nf_mod,5},
115: {"dp_true_nf_mod",Pdp_true_nf_mod,5},
1.8 noro 116: {"dp_lnf_mod",Pdp_lnf_mod,3},
1.28 ! noro 117: {"dp_nf_tab_f",Pdp_nf_tab_f,2},
1.8 noro 118: {"dp_nf_tab_mod",Pdp_nf_tab_mod,3},
1.16 noro 119: {"dp_lnf_f",Pdp_lnf_f,2},
1.8 noro 120:
121: /* Buchberger algorithm */
1.1 noro 122: {"dp_gr_main",Pdp_gr_main,5},
123: {"dp_gr_mod_main",Pdp_gr_mod_main,5},
1.27 noro 124: {"dp_gr_f_main",Pdp_gr_f_main,4},
1.23 noro 125: {"dp_gr_checklist",Pdp_gr_checklist,2},
1.8 noro 126:
127: /* F4 algorithm */
1.1 noro 128: {"dp_f4_main",Pdp_f4_main,3},
129: {"dp_f4_mod_main",Pdp_f4_mod_main,4},
1.8 noro 130:
1.11 noro 131: /* weyl algebra */
1.12 noro 132: /* multiplication */
133: {"dp_weyl_mul",Pdp_weyl_mul,2},
1.13 noro 134: {"dp_weyl_mul_mod",Pdp_weyl_mul_mod,3},
1.12 noro 135:
1.11 noro 136: /* s-poly */
137: {"dp_weyl_sp",Pdp_weyl_sp,2},
138:
139: /* m-reduction */
140: {"dp_weyl_red",Pdp_weyl_red,3},
141:
142: /* normal form */
143: {"dp_weyl_nf",Pdp_weyl_nf,4},
1.13 noro 144: {"dp_weyl_nf_mod",Pdp_weyl_nf_mod,5},
1.16 noro 145: {"dp_weyl_nf_f",Pdp_weyl_nf_f,4},
1.11 noro 146:
147: /* Buchberger algorithm */
148: {"dp_weyl_gr_main",Pdp_weyl_gr_main,5},
149: {"dp_weyl_gr_mod_main",Pdp_weyl_gr_mod_main,5},
1.16 noro 150: {"dp_weyl_gr_f_main",Pdp_weyl_gr_f_main,4},
1.11 noro 151:
152: /* F4 algorithm */
153: {"dp_weyl_f4_main",Pdp_weyl_f4_main,3},
1.19 noro 154: {"dp_weyl_f4_mod_main",Pdp_weyl_f4_mod_main,4},
1.11 noro 155:
1.15 noro 156: /* misc */
1.24 noro 157: {"dp_set_weight",Pdp_set_weight,-1},
1.15 noro 158: {"dp_weyl_set_weight",Pdp_weyl_set_weight,-1},
1.8 noro 159: {0,0,0},
160: };
161:
162: struct ftab dp_supp_tab[] = {
163: /* setting flags */
164: {"dp_ord",Pdp_ord,-1},
165: {"dp_set_kara",Pdp_set_kara,-1},
166: {"dp_nelim",Pdp_nelim,-1},
1.1 noro 167: {"dp_gr_flags",Pdp_gr_flags,-1},
168: {"dp_gr_print",Pdp_gr_print,-1},
1.8 noro 169:
170: /* converters */
171: {"dp_ptod",Pdp_ptod,2},
172: {"dp_dtop",Pdp_dtop,2},
173: {"dp_homo",Pdp_homo,1},
174: {"dp_dehomo",Pdp_dehomo,1},
175: {"dp_etov",Pdp_etov,1},
176: {"dp_vtoe",Pdp_vtoe,1},
177: {"dp_dtov",Pdp_dtov,1},
178: {"dp_mdtod",Pdp_mdtod,1},
179: {"dp_mod",Pdp_mod,3},
180: {"dp_rat",Pdp_rat,1},
181:
182: /* criteria */
183: {"dp_cri1",Pdp_cri1,2},
184: {"dp_cri2",Pdp_cri2,2},
185: {"dp_criB",Pdp_criB,3},
186:
187: /* simple operation */
188: {"dp_subd",Pdp_subd,2},
189: {"dp_lcm",Pdp_lcm,2},
190: {"dp_hm",Pdp_hm,1},
191: {"dp_ht",Pdp_ht,1},
192: {"dp_hc",Pdp_hc,1},
193: {"dp_rest",Pdp_rest,1},
194:
195: /* degree and size */
196: {"dp_td",Pdp_td,1},
197: {"dp_mag",Pdp_mag,1},
198: {"dp_sugar",Pdp_sugar,1},
199:
200: /* misc */
201: {"dp_mbase",Pdp_mbase,1},
202: {"dp_redble",Pdp_redble,2},
203: {"dp_sep",Pdp_sep,2},
204: {"dp_idiv",Pdp_idiv,2},
205: {"dp_tdiv",Pdp_tdiv,2},
206: {"dp_minp",Pdp_minp,2},
207:
208: {0,0,0}
1.1 noro 209: };
210:
1.8 noro 211: void Pdp_mdtod(arg,rp)
212: NODE arg;
213: DP *rp;
214: {
215: MP m,mr,mr0;
216: DP p;
217: P t;
218:
219: p = (DP)ARG0(arg);
220: if ( !p )
221: *rp = 0;
222: else {
223: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
224: mptop(m->c,&t); NEXTMP(mr0,mr); mr->c = t; mr->dl = m->dl;
225: }
226: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
227: }
228: }
229:
230: void Pdp_sep(arg,rp)
231: NODE arg;
232: VECT *rp;
233: {
234: DP p,r;
235: MP m,t;
236: MP *w0,*w;
237: int i,n,d,nv,sugar;
238: VECT v;
239: pointer *pv;
240:
241: p = (DP)ARG0(arg); m = BDY(p);
242: d = QTOS((Q)ARG1(arg));
243: for ( t = m, n = 0; t; t = NEXT(t), n++ );
244: if ( d > n )
245: d = n;
246: MKVECT(v,d); *rp = v;
247: pv = BDY(v); nv = p->nv; sugar = p->sugar;
248: w0 = (MP *)MALLOC(d*sizeof(MP)); bzero(w0,d*sizeof(MP));
249: w = (MP *)MALLOC(d*sizeof(MP)); bzero(w,d*sizeof(MP));
250: for ( t = BDY(p), i = 0; t; t = NEXT(t), i++, i %= d ) {
251: NEXTMP(w0[i],w[i]); w[i]->c = t->c; w[i]->dl = t->dl;
252: }
253: for ( i = 0; i < d; i++ ) {
254: NEXT(w[i]) = 0; MKDP(nv,w0[i],r); r->sugar = sugar;
255: pv[i] = (pointer)r;
256: }
257: }
258:
259: void Pdp_idiv(arg,rp)
260: NODE arg;
261: DP *rp;
262: {
263: dp_idiv((DP)ARG0(arg),(Q)ARG1(arg),rp);
264: }
265:
266: void Pdp_cont(arg,rp)
267: NODE arg;
268: Q *rp;
269: {
270: dp_cont((DP)ARG0(arg),rp);
271: }
272:
273: void Pdp_dtov(arg,rp)
274: NODE arg;
275: VECT *rp;
276: {
277: dp_dtov((DP)ARG0(arg),rp);
278: }
279:
280: void Pdp_mbase(arg,rp)
281: NODE arg;
282: LIST *rp;
283: {
284: NODE mb;
285:
286: asir_assert(ARG0(arg),O_LIST,"dp_mbase");
287: dp_mbase(BDY((LIST)ARG0(arg)),&mb);
288: MKLIST(*rp,mb);
289: }
290:
291: void Pdp_etov(arg,rp)
292: NODE arg;
293: VECT *rp;
294: {
295: DP dp;
296: int n,i;
297: int *d;
298: VECT v;
299: Q t;
300:
301: dp = (DP)ARG0(arg);
302: asir_assert(dp,O_DP,"dp_etov");
303: n = dp->nv; d = BDY(dp)->dl->d;
304: MKVECT(v,n);
305: for ( i = 0; i < n; i++ ) {
306: STOQ(d[i],t); v->body[i] = (pointer)t;
307: }
308: *rp = v;
309: }
310:
311: void Pdp_vtoe(arg,rp)
312: NODE arg;
313: DP *rp;
314: {
315: DP dp;
316: DL dl;
317: MP m;
318: int n,i,td;
319: int *d;
320: VECT v;
321:
322: v = (VECT)ARG0(arg);
323: asir_assert(v,O_VECT,"dp_vtoe");
324: n = v->len;
325: NEWDL(dl,n); d = dl->d;
326: for ( i = 0, td = 0; i < n; i++ ) {
1.24 noro 327: d[i] = QTOS((Q)(v->body[i])); td += MUL_WEIGHT(d[i],i);
1.8 noro 328: }
329: dl->td = td;
330: NEWMP(m); m->dl = dl; m->c = (P)ONE; NEXT(m) = 0;
331: MKDP(n,m,dp); dp->sugar = td;
332: *rp = dp;
333: }
334:
335: void Pdp_lnf_mod(arg,rp)
336: NODE arg;
337: LIST *rp;
338: {
339: DP r1,r2;
340: NODE b,g,n;
341: int mod;
342:
343: asir_assert(ARG0(arg),O_LIST,"dp_lnf_mod");
344: asir_assert(ARG1(arg),O_LIST,"dp_lnf_mod");
345: asir_assert(ARG2(arg),O_N,"dp_lnf_mod");
346: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
347: mod = QTOS((Q)ARG2(arg));
348: dp_lnf_mod((DP)BDY(b),(DP)BDY(NEXT(b)),g,mod,&r1,&r2);
349: NEWNODE(n); BDY(n) = (pointer)r1;
350: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
351: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
352: }
353:
1.16 noro 354: void Pdp_lnf_f(arg,rp)
355: NODE arg;
356: LIST *rp;
357: {
358: DP r1,r2;
359: NODE b,g,n;
360:
361: asir_assert(ARG0(arg),O_LIST,"dp_lnf_f");
362: asir_assert(ARG1(arg),O_LIST,"dp_lnf_f");
363: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
364: dp_lnf_f((DP)BDY(b),(DP)BDY(NEXT(b)),g,&r1,&r2);
365: NEWNODE(n); BDY(n) = (pointer)r1;
366: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
367: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
368: }
369:
1.8 noro 370: void Pdp_nf_tab_mod(arg,rp)
371: NODE arg;
372: DP *rp;
373: {
374: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_mod");
375: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_mod");
376: asir_assert(ARG2(arg),O_N,"dp_nf_tab_mod");
377: dp_nf_tab_mod((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),
378: QTOS((Q)ARG2(arg)),rp);
1.28 ! noro 379: }
! 380:
! 381: void Pdp_nf_tab_f(arg,rp)
! 382: NODE arg;
! 383: DP *rp;
! 384: {
! 385: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_f");
! 386: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_f");
! 387: dp_nf_tab_f((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),rp);
1.8 noro 388: }
1.1 noro 389:
390: void Pdp_ord(arg,rp)
391: NODE arg;
392: Obj *rp;
393: {
394: struct order_spec spec;
395:
396: if ( !arg )
397: *rp = dp_current_spec.obj;
398: else if ( !create_order_spec((Obj)ARG0(arg),&spec) )
399: error("dp_ord : invalid order specification");
400: else {
401: initd(&spec); *rp = spec.obj;
402: }
403: }
404:
405: void Pdp_ptod(arg,rp)
406: NODE arg;
407: DP *rp;
408: {
409: NODE n;
410: VL vl,tvl;
411:
412: asir_assert(ARG0(arg),O_P,"dp_ptod");
413: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
414: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
415: if ( !vl ) {
416: NEWVL(vl); tvl = vl;
417: } else {
418: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
419: }
420: VR(tvl) = VR((P)BDY(n));
421: }
422: if ( vl )
423: NEXT(tvl) = 0;
424: ptod(CO,vl,(P)ARG0(arg),rp);
425: }
426:
427: void Pdp_dtop(arg,rp)
428: NODE arg;
429: P *rp;
430: {
431: NODE n;
432: VL vl,tvl;
433:
434: asir_assert(ARG0(arg),O_DP,"dp_dtop");
435: asir_assert(ARG1(arg),O_LIST,"dp_dtop");
436: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
437: if ( !vl ) {
438: NEWVL(vl); tvl = vl;
439: } else {
440: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
441: }
442: VR(tvl) = VR((P)BDY(n));
443: }
444: if ( vl )
445: NEXT(tvl) = 0;
446: dtop(CO,vl,(DP)ARG0(arg),rp);
447: }
448:
449: extern LIST Dist;
450:
451: void Pdp_ptozp(arg,rp)
452: NODE arg;
453: DP *rp;
454: {
455: asir_assert(ARG0(arg),O_DP,"dp_ptozp");
1.10 noro 456: dp_ptozp((DP)ARG0(arg),rp);
1.1 noro 457: }
458:
459: void Pdp_ptozp2(arg,rp)
460: NODE arg;
461: LIST *rp;
462: {
463: DP p0,p1,h,r;
464: NODE n0;
465:
466: p0 = (DP)ARG0(arg); p1 = (DP)ARG1(arg);
467: asir_assert(p0,O_DP,"dp_ptozp2");
468: asir_assert(p1,O_DP,"dp_ptozp2");
1.10 noro 469: dp_ptozp2(p0,p1,&h,&r);
1.1 noro 470: NEWNODE(n0); BDY(n0) = (pointer)h;
471: NEWNODE(NEXT(n0)); BDY(NEXT(n0)) = (pointer)r;
472: NEXT(NEXT(n0)) = 0;
473: MKLIST(*rp,n0);
474: }
475:
476: void Pdp_prim(arg,rp)
477: NODE arg;
478: DP *rp;
479: {
480: DP t;
481:
482: asir_assert(ARG0(arg),O_DP,"dp_prim");
483: dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
484: }
485:
486: void Pdp_mod(arg,rp)
487: NODE arg;
488: DP *rp;
489: {
490: DP p;
491: int mod;
492: NODE subst;
493:
494: asir_assert(ARG0(arg),O_DP,"dp_mod");
495: asir_assert(ARG1(arg),O_N,"dp_mod");
496: asir_assert(ARG2(arg),O_LIST,"dp_mod");
497: p = (DP)ARG0(arg); mod = QTOS((Q)ARG1(arg));
498: subst = BDY((LIST)ARG2(arg));
499: dp_mod(p,mod,subst,rp);
500: }
501:
502: void Pdp_rat(arg,rp)
503: NODE arg;
504: DP *rp;
505: {
506: asir_assert(ARG0(arg),O_DP,"dp_rat");
507: dp_rat((DP)ARG0(arg),rp);
508: }
509:
1.9 noro 510: extern int DP_Multiple;
511:
1.1 noro 512: void Pdp_nf(arg,rp)
513: NODE arg;
514: DP *rp;
515: {
516: NODE b;
517: DP *ps;
518: DP g;
519: int full;
520:
1.11 noro 521: do_weyl = 0;
1.1 noro 522: asir_assert(ARG0(arg),O_LIST,"dp_nf");
523: asir_assert(ARG1(arg),O_DP,"dp_nf");
524: asir_assert(ARG2(arg),O_VECT,"dp_nf");
525: asir_assert(ARG3(arg),O_N,"dp_nf");
526: if ( !(g = (DP)ARG1(arg)) ) {
527: *rp = 0; return;
528: }
529: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
530: full = (Q)ARG3(arg) ? 1 : 0;
1.16 noro 531: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
1.1 noro 532: }
533:
1.11 noro 534: void Pdp_weyl_nf(arg,rp)
535: NODE arg;
536: DP *rp;
537: {
538: NODE b;
539: DP *ps;
540: DP g;
541: int full;
542:
543: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf");
544: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf");
545: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf");
546: asir_assert(ARG3(arg),O_N,"dp_weyl_nf");
547: if ( !(g = (DP)ARG1(arg)) ) {
548: *rp = 0; return;
549: }
550: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
551: full = (Q)ARG3(arg) ? 1 : 0;
1.12 noro 552: do_weyl = 1;
1.16 noro 553: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
554: do_weyl = 0;
555: }
556:
557: /* nf computation using field operations */
558:
559: void Pdp_nf_f(arg,rp)
560: NODE arg;
561: DP *rp;
562: {
563: NODE b;
564: DP *ps;
565: DP g;
566: int full;
567:
568: do_weyl = 0;
569: asir_assert(ARG0(arg),O_LIST,"dp_nf_f");
570: asir_assert(ARG1(arg),O_DP,"dp_nf_f");
571: asir_assert(ARG2(arg),O_VECT,"dp_nf_f");
572: asir_assert(ARG3(arg),O_N,"dp_nf_f");
573: if ( !(g = (DP)ARG1(arg)) ) {
574: *rp = 0; return;
575: }
576: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
577: full = (Q)ARG3(arg) ? 1 : 0;
578: dp_nf_f(b,g,ps,full,rp);
579: }
580:
581: void Pdp_weyl_nf_f(arg,rp)
582: NODE arg;
583: DP *rp;
584: {
585: NODE b;
586: DP *ps;
587: DP g;
588: int full;
589:
590: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_f");
591: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_f");
592: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_f");
593: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_f");
594: if ( !(g = (DP)ARG1(arg)) ) {
595: *rp = 0; return;
596: }
597: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
598: full = (Q)ARG3(arg) ? 1 : 0;
599: do_weyl = 1;
600: dp_nf_f(b,g,ps,full,rp);
1.12 noro 601: do_weyl = 0;
1.11 noro 602: }
603:
1.13 noro 604: void Pdp_nf_mod(arg,rp)
605: NODE arg;
606: DP *rp;
607: {
608: NODE b;
609: DP g;
610: DP *ps;
611: int mod,full,ac;
612: NODE n,n0;
613:
1.14 noro 614: do_weyl = 0;
1.13 noro 615: ac = argc(arg);
1.14 noro 616: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
617: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
618: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
619: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
620: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
1.13 noro 621: if ( !(g = (DP)ARG1(arg)) ) {
622: *rp = 0; return;
623: }
624: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
625: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
626: for ( n0 = n = 0; b; b = NEXT(b) ) {
627: NEXTNODE(n0,n);
628: BDY(n) = (pointer)QTOS((Q)BDY(b));
629: }
630: if ( n0 )
631: NEXT(n) = 0;
632: dp_nf_mod(n0,g,ps,mod,full,rp);
633: }
634:
1.1 noro 635: void Pdp_true_nf(arg,rp)
636: NODE arg;
637: LIST *rp;
638: {
639: NODE b,n;
640: DP *ps;
641: DP g;
642: DP nm;
643: P dn;
644: int full;
645:
1.11 noro 646: do_weyl = 0;
1.1 noro 647: asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
648: asir_assert(ARG1(arg),O_DP,"dp_true_nf");
649: asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
650: asir_assert(ARG3(arg),O_N,"dp_nf");
651: if ( !(g = (DP)ARG1(arg)) ) {
652: nm = 0; dn = (P)ONE;
653: } else {
654: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
655: full = (Q)ARG3(arg) ? 1 : 0;
656: dp_true_nf(b,g,ps,full,&nm,&dn);
657: }
658: NEWNODE(n); BDY(n) = (pointer)nm;
659: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
660: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
661: }
662:
1.13 noro 663: void Pdp_weyl_nf_mod(arg,rp)
1.8 noro 664: NODE arg;
665: DP *rp;
666: {
667: NODE b;
668: DP g;
669: DP *ps;
670: int mod,full,ac;
1.9 noro 671: NODE n,n0;
1.8 noro 672:
673: ac = argc(arg);
1.14 noro 674: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_mod");
675: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_mod");
676: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_mod");
677: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_mod");
678: asir_assert(ARG4(arg),O_N,"dp_weyl_nf_mod");
1.8 noro 679: if ( !(g = (DP)ARG1(arg)) ) {
680: *rp = 0; return;
681: }
682: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
683: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
1.9 noro 684: for ( n0 = n = 0; b; b = NEXT(b) ) {
685: NEXTNODE(n0,n);
686: BDY(n) = (pointer)QTOS((Q)BDY(b));
687: }
688: if ( n0 )
689: NEXT(n) = 0;
1.13 noro 690: do_weyl = 1;
691: dp_nf_mod(n0,g,ps,mod,full,rp);
692: do_weyl = 0;
1.8 noro 693: }
694:
695: void Pdp_true_nf_mod(arg,rp)
696: NODE arg;
697: LIST *rp;
698: {
699: NODE b;
700: DP g,nm;
701: P dn;
702: DP *ps;
703: int mod,full;
704: NODE n;
705:
1.11 noro 706: do_weyl = 0;
1.8 noro 707: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
708: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
709: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
710: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
711: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
712: if ( !(g = (DP)ARG1(arg)) ) {
713: nm = 0; dn = (P)ONEM;
714: } else {
715: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
716: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
717: dp_true_nf_mod(b,g,ps,mod,full,&nm,&dn);
718: }
719: NEWNODE(n); BDY(n) = (pointer)nm;
720: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
721: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.1 noro 722: }
723:
724: void Pdp_tdiv(arg,rp)
725: NODE arg;
726: DP *rp;
727: {
728: MP m,mr,mr0;
729: DP p;
730: Q c;
731: N d,q,r;
732: int sgn;
733:
734: asir_assert(ARG0(arg),O_DP,"dp_tdiv");
735: asir_assert(ARG1(arg),O_N,"dp_tdiv");
736: p = (DP)ARG0(arg); d = NM((Q)ARG1(arg)); sgn = SGN((Q)ARG1(arg));
737: if ( !p )
738: *rp = 0;
739: else {
740: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
741: divn(NM((Q)m->c),d,&q,&r);
742: if ( r ) {
743: *rp = 0; return;
744: } else {
745: NEXTMP(mr0,mr); NTOQ(q,SGN((Q)m->c)*sgn,c);
746: mr->c = (P)c; mr->dl = m->dl;
747: }
748: }
749: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
750: }
751: }
752:
753: void Pdp_red_coef(arg,rp)
754: NODE arg;
755: DP *rp;
756: {
757: MP m,mr,mr0;
758: P q,r;
759: DP p;
760: P mod;
761:
762: p = (DP)ARG0(arg); mod = (P)ARG1(arg);
763: asir_assert(p,O_DP,"dp_red_coef");
764: asir_assert(mod,O_P,"dp_red_coef");
765: if ( !p )
766: *rp = 0;
767: else {
768: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
769: divsrp(CO,m->c,mod,&q,&r);
770: if ( r ) {
771: NEXTMP(mr0,mr); mr->c = r; mr->dl = m->dl;
772: }
773: }
774: if ( mr0 ) {
775: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
776: } else
777: *rp = 0;
778: }
779: }
780:
781: void Pdp_redble(arg,rp)
782: NODE arg;
783: Q *rp;
784: {
785: asir_assert(ARG0(arg),O_DP,"dp_redble");
786: asir_assert(ARG1(arg),O_DP,"dp_redble");
787: if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
788: *rp = ONE;
789: else
790: *rp = 0;
791: }
792:
793: void Pdp_red_mod(arg,rp)
794: NODE arg;
795: LIST *rp;
796: {
797: DP h,r;
798: P dmy;
799: NODE n;
800:
1.11 noro 801: do_weyl = 0;
1.1 noro 802: asir_assert(ARG0(arg),O_DP,"dp_red_mod");
803: asir_assert(ARG1(arg),O_DP,"dp_red_mod");
804: asir_assert(ARG2(arg),O_DP,"dp_red_mod");
805: asir_assert(ARG3(arg),O_N,"dp_red_mod");
806: dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),QTOS((Q)ARG3(arg)),
807: &h,&r,&dmy);
808: NEWNODE(n); BDY(n) = (pointer)h;
809: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
810: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
811: }
1.13 noro 812:
1.1 noro 813: void Pdp_subd(arg,rp)
814: NODE arg;
815: DP *rp;
816: {
817: DP p1,p2;
818:
819: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
820: asir_assert(p1,O_DP,"dp_subd");
821: asir_assert(p2,O_DP,"dp_subd");
822: dp_subd(p1,p2,rp);
823: }
824:
1.12 noro 825: void Pdp_weyl_mul(arg,rp)
826: NODE arg;
827: DP *rp;
828: {
829: DP p1,p2;
830:
831: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
832: asir_assert(p1,O_DP,"dp_weyl_mul"); asir_assert(p2,O_DP,"dp_mul");
833: do_weyl = 1;
834: muld(CO,p1,p2,rp);
1.13 noro 835: do_weyl = 0;
836: }
837:
838: void Pdp_weyl_mul_mod(arg,rp)
839: NODE arg;
840: DP *rp;
841: {
842: DP p1,p2;
843: Q m;
844:
845: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); m = (Q)ARG2(arg);
846: asir_assert(p1,O_DP,"dp_weyl_mul_mod");
847: asir_assert(p2,O_DP,"dp_mul_mod");
848: asir_assert(m,O_N,"dp_mul_mod");
849: do_weyl = 1;
850: mulmd(CO,QTOS(m),p1,p2,rp);
1.12 noro 851: do_weyl = 0;
852: }
853:
1.1 noro 854: void Pdp_red(arg,rp)
855: NODE arg;
856: LIST *rp;
857: {
858: NODE n;
1.4 noro 859: DP head,rest,dmy1;
1.1 noro 860: P dmy;
861:
1.11 noro 862: do_weyl = 0;
1.1 noro 863: asir_assert(ARG0(arg),O_DP,"dp_red");
864: asir_assert(ARG1(arg),O_DP,"dp_red");
865: asir_assert(ARG2(arg),O_DP,"dp_red");
1.4 noro 866: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.1 noro 867: NEWNODE(n); BDY(n) = (pointer)head;
868: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
869: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
870: }
871:
1.11 noro 872: void Pdp_weyl_red(arg,rp)
873: NODE arg;
874: LIST *rp;
875: {
876: NODE n;
877: DP head,rest,dmy1;
878: P dmy;
879:
880: asir_assert(ARG0(arg),O_DP,"dp_weyl_red");
881: asir_assert(ARG1(arg),O_DP,"dp_weyl_red");
882: asir_assert(ARG2(arg),O_DP,"dp_weyl_red");
1.12 noro 883: do_weyl = 1;
1.11 noro 884: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.12 noro 885: do_weyl = 0;
1.11 noro 886: NEWNODE(n); BDY(n) = (pointer)head;
887: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
888: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
889: }
890:
1.1 noro 891: void Pdp_sp(arg,rp)
892: NODE arg;
893: DP *rp;
894: {
895: DP p1,p2;
896:
1.11 noro 897: do_weyl = 0;
1.1 noro 898: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
899: asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
900: dp_sp(p1,p2,rp);
901: }
902:
1.11 noro 903: void Pdp_weyl_sp(arg,rp)
904: NODE arg;
905: DP *rp;
906: {
907: DP p1,p2;
908:
909: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
910: asir_assert(p1,O_DP,"dp_weyl_sp"); asir_assert(p2,O_DP,"dp_sp");
1.12 noro 911: do_weyl = 1;
1.11 noro 912: dp_sp(p1,p2,rp);
1.12 noro 913: do_weyl = 0;
1.11 noro 914: }
915:
1.1 noro 916: void Pdp_sp_mod(arg,rp)
917: NODE arg;
918: DP *rp;
919: {
920: DP p1,p2;
921: int mod;
922:
1.11 noro 923: do_weyl = 0;
1.1 noro 924: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
925: asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
926: asir_assert(ARG2(arg),O_N,"dp_sp_mod");
927: mod = QTOS((Q)ARG2(arg));
928: dp_sp_mod(p1,p2,mod,rp);
929: }
930:
931: void Pdp_lcm(arg,rp)
932: NODE arg;
933: DP *rp;
934: {
935: int i,n,td;
936: DL d1,d2,d;
937: MP m;
938: DP p1,p2;
939:
940: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
941: asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
942: n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
943: NEWDL(d,n);
944: for ( i = 0, td = 0; i < n; i++ ) {
1.24 noro 945: d->d[i] = MAX(d1->d[i],d2->d[i]); td += MUL_WEIGHT(d->d[i],i);
1.1 noro 946: }
947: d->td = td;
948: NEWMP(m); m->dl = d; m->c = (P)ONE; NEXT(m) = 0;
949: MKDP(n,m,*rp); (*rp)->sugar = td; /* XXX */
950: }
951:
952: void Pdp_hm(arg,rp)
953: NODE arg;
954: DP *rp;
955: {
956: DP p;
957:
958: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
959: dp_hm(p,rp);
960: }
961:
962: void Pdp_ht(arg,rp)
963: NODE arg;
964: DP *rp;
965: {
966: DP p;
967: MP m,mr;
968:
969: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
970: if ( !p )
971: *rp = 0;
972: else {
973: m = BDY(p);
974: NEWMP(mr); mr->dl = m->dl; mr->c = (P)ONE; NEXT(mr) = 0;
975: MKDP(p->nv,mr,*rp); (*rp)->sugar = mr->dl->td; /* XXX */
976: }
977: }
978:
979: void Pdp_hc(arg,rp)
980: NODE arg;
981: P *rp;
982: {
983: asir_assert(ARG0(arg),O_DP,"dp_hc");
984: if ( !ARG0(arg) )
985: *rp = 0;
986: else
987: *rp = BDY((DP)ARG0(arg))->c;
988: }
989:
990: void Pdp_rest(arg,rp)
991: NODE arg;
992: DP *rp;
993: {
994: asir_assert(ARG0(arg),O_DP,"dp_rest");
995: if ( !ARG0(arg) )
996: *rp = 0;
997: else
998: dp_rest((DP)ARG0(arg),rp);
999: }
1000:
1001: void Pdp_td(arg,rp)
1002: NODE arg;
1003: Q *rp;
1004: {
1005: DP p;
1006:
1007: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
1008: if ( !p )
1009: *rp = 0;
1010: else
1011: STOQ(BDY(p)->dl->td,*rp);
1012: }
1013:
1014: void Pdp_sugar(arg,rp)
1015: NODE arg;
1016: Q *rp;
1017: {
1018: DP p;
1019:
1020: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
1021: if ( !p )
1022: *rp = 0;
1023: else
1024: STOQ(p->sugar,*rp);
1025: }
1026:
1027: void Pdp_cri1(arg,rp)
1028: NODE arg;
1029: Q *rp;
1030: {
1031: DP p1,p2;
1032: int *d1,*d2;
1033: int i,n;
1034:
1035: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1036: asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
1037: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
1038: for ( i = 0; i < n; i++ )
1039: if ( d1[i] > d2[i] )
1040: break;
1041: *rp = i == n ? ONE : 0;
1042: }
1043:
1044: void Pdp_cri2(arg,rp)
1045: NODE arg;
1046: Q *rp;
1047: {
1048: DP p1,p2;
1049: int *d1,*d2;
1050: int i,n;
1051:
1052: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1053: asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
1054: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
1055: for ( i = 0; i < n; i++ )
1056: if ( MIN(d1[i],d2[i]) >= 1 )
1057: break;
1058: *rp = i == n ? ONE : 0;
1059: }
1060:
1061: void Pdp_minp(arg,rp)
1062: NODE arg;
1063: LIST *rp;
1064: {
1065: NODE tn,tn1,d,dd,dd0,p,tp;
1066: LIST l,minp;
1067: DP lcm,tlcm;
1068: int s,ts;
1069:
1070: asir_assert(ARG0(arg),O_LIST,"dp_minp");
1071: d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
1072: p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
1073: if ( !ARG1(arg) ) {
1074: s = QTOS((Q)BDY(p)); p = NEXT(p);
1075: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1076: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1077: tlcm = (DP)BDY(tp); tp = NEXT(tp);
1078: ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
1079: NEXTNODE(dd0,dd);
1080: if ( ts < s ) {
1081: BDY(dd) = (pointer)minp;
1082: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1083: } else if ( ts == s ) {
1084: if ( compd(CO,lcm,tlcm) > 0 ) {
1085: BDY(dd) = (pointer)minp;
1086: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1087: } else
1088: BDY(dd) = BDY(d);
1089: } else
1090: BDY(dd) = BDY(d);
1091: }
1092: } else {
1093: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1094: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1095: tlcm = (DP)BDY(tp);
1096: NEXTNODE(dd0,dd);
1097: if ( compd(CO,lcm,tlcm) > 0 ) {
1098: BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
1099: } else
1100: BDY(dd) = BDY(d);
1101: }
1102: }
1103: if ( dd0 )
1104: NEXT(dd) = 0;
1105: MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
1106: }
1107:
1108: void Pdp_criB(arg,rp)
1109: NODE arg;
1110: LIST *rp;
1111: {
1112: NODE d,ij,dd,ddd;
1113: int i,j,s,n;
1114: DP *ps;
1115: DL ts,ti,tj,lij,tdl;
1116:
1117: asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
1118: asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
1119: asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
1120: if ( !d )
1121: *rp = (LIST)ARG0(arg);
1122: else {
1123: ts = BDY(ps[s])->dl;
1124: n = ps[s]->nv;
1125: NEWDL(tdl,n);
1126: for ( dd = 0; d; d = NEXT(d) ) {
1127: ij = BDY((LIST)BDY(d));
1128: i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1129: j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1130: lij = BDY((DP)BDY(ij))->dl;
1131: ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
1132: if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
1133: || !dl_equal(n,lij,tdl)
1134: || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
1135: && dl_equal(n,tdl,lij))
1136: || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
1137: && dl_equal(n,tdl,lij)) ) {
1138: MKNODE(ddd,BDY(d),dd);
1139: dd = ddd;
1140: }
1141: }
1142: MKLIST(*rp,dd);
1143: }
1144: }
1145:
1146: void Pdp_nelim(arg,rp)
1147: NODE arg;
1148: Q *rp;
1149: {
1150: if ( arg ) {
1151: asir_assert(ARG0(arg),O_N,"dp_nelim");
1152: dp_nelim = QTOS((Q)ARG0(arg));
1153: }
1154: STOQ(dp_nelim,*rp);
1155: }
1156:
1157: void Pdp_mag(arg,rp)
1158: NODE arg;
1159: Q *rp;
1160: {
1161: DP p;
1162: int s;
1163: MP m;
1164:
1165: p = (DP)ARG0(arg);
1166: asir_assert(p,O_DP,"dp_mag");
1167: if ( !p )
1168: *rp = 0;
1169: else {
1170: for ( s = 0, m = BDY(p); m; m = NEXT(m) )
1171: s += p_mag(m->c);
1172: STOQ(s,*rp);
1173: }
1174: }
1175:
1176: extern int kara_mag;
1177:
1178: void Pdp_set_kara(arg,rp)
1179: NODE arg;
1180: Q *rp;
1181: {
1182: if ( arg ) {
1183: asir_assert(ARG0(arg),O_N,"dp_set_kara");
1184: kara_mag = QTOS((Q)ARG0(arg));
1185: }
1186: STOQ(kara_mag,*rp);
1187: }
1188:
1189: void Pdp_homo(arg,rp)
1190: NODE arg;
1191: DP *rp;
1192: {
1193: asir_assert(ARG0(arg),O_DP,"dp_homo");
1194: dp_homo((DP)ARG0(arg),rp);
1195: }
1196:
1.8 noro 1197: void Pdp_dehomo(arg,rp)
1198: NODE arg;
1.1 noro 1199: DP *rp;
1200: {
1.8 noro 1201: asir_assert(ARG0(arg),O_DP,"dp_dehomo");
1202: dp_dehomo((DP)ARG0(arg),rp);
1203: }
1204:
1205: void Pdp_gr_flags(arg,rp)
1206: NODE arg;
1207: LIST *rp;
1208: {
1209: Obj name,value;
1210: NODE n;
1.1 noro 1211:
1.8 noro 1212: if ( arg ) {
1213: asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
1214: n = BDY((LIST)ARG0(arg));
1215: while ( n ) {
1216: name = (Obj)BDY(n); n = NEXT(n);
1217: if ( !n )
1218: break;
1219: else {
1220: value = (Obj)BDY(n); n = NEXT(n);
1221: }
1222: dp_set_flag(name,value);
1.1 noro 1223: }
1224: }
1.8 noro 1225: dp_make_flaglist(rp);
1226: }
1227:
1228: extern int DP_Print;
1229:
1230: void Pdp_gr_print(arg,rp)
1231: NODE arg;
1232: Q *rp;
1233: {
1234: Q q;
1235:
1236: if ( arg ) {
1237: asir_assert(ARG0(arg),O_N,"dp_gr_print");
1238: q = (Q)ARG0(arg); DP_Print = QTOS(q);
1239: } else
1240: STOQ(DP_Print,q);
1241: *rp = q;
1.1 noro 1242: }
1243:
1.8 noro 1244: void Pdp_gr_main(arg,rp)
1.1 noro 1245: NODE arg;
1.8 noro 1246: LIST *rp;
1.1 noro 1247: {
1.8 noro 1248: LIST f,v;
1249: Num homo;
1250: Q m;
1251: int modular;
1252: struct order_spec ord;
1253:
1.11 noro 1254: do_weyl = 0;
1.8 noro 1255: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1256: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
1257: asir_assert(ARG2(arg),O_N,"dp_gr_main");
1258: asir_assert(ARG3(arg),O_N,"dp_gr_main");
1259: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1260: f = remove_zero_from_list(f);
1261: if ( !BDY(f) ) {
1262: *rp = f; return;
1263: }
1.8 noro 1264: homo = (Num)ARG2(arg);
1265: m = (Q)ARG3(arg);
1266: if ( !m )
1267: modular = 0;
1268: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1269: error("dp_gr_main : too large modulus");
1270: else
1271: modular = QTOS(m);
1272: create_order_spec(ARG4(arg),&ord);
1.16 noro 1273: dp_gr_main(f,v,homo,modular,0,&ord,rp);
1274: }
1275:
1276: void Pdp_gr_f_main(arg,rp)
1277: NODE arg;
1278: LIST *rp;
1279: {
1280: LIST f,v;
1281: Num homo;
1.26 noro 1282: int m,field,t;
1.16 noro 1283: struct order_spec ord;
1.26 noro 1284: NODE n;
1.16 noro 1285:
1286: do_weyl = 0;
1287: asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
1288: asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
1289: asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
1290: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1291: f = remove_zero_from_list(f);
1292: if ( !BDY(f) ) {
1293: *rp = f; return;
1294: }
1.16 noro 1295: homo = (Num)ARG2(arg);
1.27 noro 1296: #if 0
1297: asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
1.26 noro 1298: m = QTOS((Q)ARG3(arg));
1299: if ( m )
1300: error("dp_gr_f_main : trace lifting is not implemented yet");
1301: create_order_spec(ARG4(arg),&ord);
1.27 noro 1302: #else
1303: m = 0;
1304: create_order_spec(ARG3(arg),&ord);
1305: #endif
1.26 noro 1306: field = 0;
1307: for ( n = BDY(f); n; n = NEXT(n) ) {
1308: t = get_field_type(BDY(n));
1309: if ( !t )
1310: continue;
1311: if ( t < 0 )
1312: error("dp_gr_f_main : incosistent coefficients");
1313: if ( !field )
1314: field = t;
1315: else if ( t != field )
1316: error("dp_gr_f_main : incosistent coefficients");
1317: }
1318: dp_gr_main(f,v,homo,m?1:0,field,&ord,rp);
1.1 noro 1319: }
1320:
1.8 noro 1321: void Pdp_f4_main(arg,rp)
1322: NODE arg;
1323: LIST *rp;
1.1 noro 1324: {
1.8 noro 1325: LIST f,v;
1326: struct order_spec ord;
1.1 noro 1327:
1.11 noro 1328: do_weyl = 0;
1.8 noro 1329: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1330: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1331: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1332: f = remove_zero_from_list(f);
1333: if ( !BDY(f) ) {
1334: *rp = f; return;
1335: }
1.8 noro 1336: create_order_spec(ARG2(arg),&ord);
1.17 noro 1337: dp_f4_main(f,v,&ord,rp);
1.22 noro 1338: }
1339:
1340: /* dp_gr_checklist(list of dp) */
1341:
1342: void Pdp_gr_checklist(arg,rp)
1343: NODE arg;
1344: LIST *rp;
1345: {
1346: VECT g;
1347: LIST dp;
1348: NODE r;
1.23 noro 1349: int n;
1.22 noro 1350:
1351: do_weyl = 0;
1352: asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
1.23 noro 1353: asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
1354: n = QTOS((Q)ARG1(arg));
1355: gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
1.22 noro 1356: r = mknode(2,g,dp);
1357: MKLIST(*rp,r);
1.1 noro 1358: }
1359:
1.8 noro 1360: void Pdp_f4_mod_main(arg,rp)
1361: NODE arg;
1362: LIST *rp;
1.1 noro 1363: {
1.8 noro 1364: LIST f,v;
1365: int m;
1366: struct order_spec ord;
1367:
1.11 noro 1368: do_weyl = 0;
1.17 noro 1369: asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
1370: asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
1371: asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
1.8 noro 1372: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 1373: f = remove_zero_from_list(f);
1374: if ( !BDY(f) ) {
1375: *rp = f; return;
1376: }
1.20 noro 1377: if ( !m )
1378: error("dp_f4_mod_main : invalid argument");
1.8 noro 1379: create_order_spec(ARG3(arg),&ord);
1380: dp_f4_mod_main(f,v,m,&ord,rp);
1381: }
1.1 noro 1382:
1.8 noro 1383: void Pdp_gr_mod_main(arg,rp)
1384: NODE arg;
1385: LIST *rp;
1386: {
1387: LIST f,v;
1388: Num homo;
1389: int m;
1390: struct order_spec ord;
1391:
1.11 noro 1392: do_weyl = 0;
1.8 noro 1393: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
1394: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
1395: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
1396: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1.11 noro 1397: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1398: f = remove_zero_from_list(f);
1399: if ( !BDY(f) ) {
1400: *rp = f; return;
1401: }
1.11 noro 1402: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1403: if ( !m )
1404: error("dp_gr_mod_main : invalid argument");
1.11 noro 1405: create_order_spec(ARG4(arg),&ord);
1406: dp_gr_mod_main(f,v,homo,m,&ord,rp);
1407: }
1408:
1409: /* for Weyl algebra */
1410:
1411: void Pdp_weyl_gr_main(arg,rp)
1412: NODE arg;
1413: LIST *rp;
1414: {
1415: LIST f,v;
1416: Num homo;
1417: Q m;
1418: int modular;
1419: struct order_spec ord;
1420:
1421: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1422: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1423: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1424: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1425: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1426: f = remove_zero_from_list(f);
1427: if ( !BDY(f) ) {
1428: *rp = f; return;
1429: }
1.11 noro 1430: homo = (Num)ARG2(arg);
1431: m = (Q)ARG3(arg);
1432: if ( !m )
1433: modular = 0;
1434: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1435: error("dp_gr_main : too large modulus");
1436: else
1437: modular = QTOS(m);
1438: create_order_spec(ARG4(arg),&ord);
1.12 noro 1439: do_weyl = 1;
1.16 noro 1440: dp_gr_main(f,v,homo,modular,0,&ord,rp);
1441: do_weyl = 0;
1442: }
1443:
1444: void Pdp_weyl_gr_f_main(arg,rp)
1445: NODE arg;
1446: LIST *rp;
1447: {
1448: LIST f,v;
1449: Num homo;
1450: struct order_spec ord;
1451:
1452: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1453: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1454: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1455: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1456: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1457: f = remove_zero_from_list(f);
1458: if ( !BDY(f) ) {
1459: *rp = f; return;
1460: }
1.16 noro 1461: homo = (Num)ARG2(arg);
1462: create_order_spec(ARG3(arg),&ord);
1463: do_weyl = 1;
1464: dp_gr_main(f,v,homo,0,1,&ord,rp);
1.12 noro 1465: do_weyl = 0;
1.11 noro 1466: }
1467:
1468: void Pdp_weyl_f4_main(arg,rp)
1469: NODE arg;
1470: LIST *rp;
1471: {
1472: LIST f,v;
1473: struct order_spec ord;
1474:
1475: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1476: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1477: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1478: f = remove_zero_from_list(f);
1479: if ( !BDY(f) ) {
1480: *rp = f; return;
1481: }
1.11 noro 1482: create_order_spec(ARG2(arg),&ord);
1.12 noro 1483: do_weyl = 1;
1.17 noro 1484: dp_f4_main(f,v,&ord,rp);
1.12 noro 1485: do_weyl = 0;
1.11 noro 1486: }
1487:
1488: void Pdp_weyl_f4_mod_main(arg,rp)
1489: NODE arg;
1490: LIST *rp;
1491: {
1492: LIST f,v;
1493: int m;
1494: struct order_spec ord;
1495:
1496: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1497: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1498: asir_assert(ARG2(arg),O_N,"dp_f4_main");
1499: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 1500: f = remove_zero_from_list(f);
1501: if ( !BDY(f) ) {
1502: *rp = f; return;
1503: }
1.20 noro 1504: if ( !m )
1505: error("dp_weyl_f4_mod_main : invalid argument");
1.11 noro 1506: create_order_spec(ARG3(arg),&ord);
1.12 noro 1507: do_weyl = 1;
1.11 noro 1508: dp_f4_mod_main(f,v,m,&ord,rp);
1.12 noro 1509: do_weyl = 0;
1.11 noro 1510: }
1511:
1512: void Pdp_weyl_gr_mod_main(arg,rp)
1513: NODE arg;
1514: LIST *rp;
1515: {
1516: LIST f,v;
1517: Num homo;
1518: int m;
1519: struct order_spec ord;
1520:
1521: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
1522: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
1523: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
1524: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
1.8 noro 1525: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1526: f = remove_zero_from_list(f);
1527: if ( !BDY(f) ) {
1528: *rp = f; return;
1529: }
1.8 noro 1530: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1531: if ( !m )
1532: error("dp_weyl_gr_mod_main : invalid argument");
1.8 noro 1533: create_order_spec(ARG4(arg),&ord);
1.12 noro 1534: do_weyl = 1;
1.8 noro 1535: dp_gr_mod_main(f,v,homo,m,&ord,rp);
1.12 noro 1536: do_weyl = 0;
1.1 noro 1537: }
1.8 noro 1538:
1.24 noro 1539: static VECT current_dl_weight_vector_obj;
1540: int *current_dl_weight_vector;
1541:
1542: void Pdp_set_weight(arg,rp)
1543: NODE arg;
1544: VECT *rp;
1545: {
1546: VECT v;
1547: int i,n;
1548:
1549: if ( !arg )
1550: *rp = current_dl_weight_vector_obj;
1551: else if ( !ARG0(arg) ) {
1552: current_dl_weight_vector_obj = 0;
1553: current_dl_weight_vector = 0;
1554: *rp = 0;
1555: } else {
1556: asir_assert(ARG0(arg),O_VECT,"dp_set_weight");
1557: v = (VECT)ARG0(arg);
1558: current_dl_weight_vector_obj = v;
1559: n = v->len;
1560: current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
1561: for ( i = 0; i < n; i++ )
1562: current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
1563: *rp = v;
1564: }
1565: }
1566:
1567: static VECT current_weyl_weight_vector_obj;
1568: int *current_weyl_weight_vector;
1.15 noro 1569:
1570: void Pdp_weyl_set_weight(arg,rp)
1571: NODE arg;
1572: VECT *rp;
1573: {
1574: VECT v;
1575: int i,n;
1576:
1577: if ( !arg )
1.24 noro 1578: *rp = current_weyl_weight_vector_obj;
1.15 noro 1579: else {
1580: asir_assert(ARG0(arg),O_VECT,"dp_weyl_set_weight");
1581: v = (VECT)ARG0(arg);
1.24 noro 1582: current_weyl_weight_vector_obj = v;
1.15 noro 1583: n = v->len;
1.24 noro 1584: current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
1.15 noro 1585: for ( i = 0; i < n; i++ )
1.24 noro 1586: current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
1.15 noro 1587: *rp = v;
1588: }
1.25 noro 1589: }
1590:
1591: LIST remove_zero_from_list(LIST l)
1592: {
1593: NODE n,r0,r;
1594: LIST rl;
1595:
1596: asir_assert(l,O_LIST,"remove_zero_from_list");
1597: n = BDY(l);
1598: for ( r0 = 0; n; n = NEXT(n) )
1599: if ( BDY(n) ) {
1600: NEXTNODE(r0,r);
1601: BDY(r) = BDY(n);
1602: }
1603: if ( r0 )
1604: NEXT(r) = 0;
1605: MKLIST(rl,r0);
1606: return rl;
1.26 noro 1607: }
1608:
1609: int get_field_type(P p)
1610: {
1611: int type,t;
1612: DCP dc;
1613:
1614: if ( !p )
1615: return 0;
1616: else if ( NUM(p) )
1617: return NID((Num)p);
1618: else {
1619: type = 0;
1620: for ( dc = DC(p); dc; dc = NEXT(dc) ) {
1621: t = get_field_type(COEF(dc));
1622: if ( !t )
1623: continue;
1624: if ( t < 0 )
1625: return t;
1626: if ( !type )
1627: type = t;
1628: else if ( t != type )
1629: return -1;
1630: }
1631: return type;
1632: }
1.15 noro 1633: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>