Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.29
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.29 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.28 2003/01/15 04:53:03 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:
1.29 ! noro 1228: extern int DP_Print, DP_PrintShort;
1.8 noro 1229:
1230: void Pdp_gr_print(arg,rp)
1231: NODE arg;
1232: Q *rp;
1233: {
1234: Q q;
1.29 ! noro 1235: int s;
1.8 noro 1236:
1237: if ( arg ) {
1238: asir_assert(ARG0(arg),O_N,"dp_gr_print");
1.29 ! noro 1239: q = (Q)ARG0(arg);
! 1240: s = QTOS(q);
! 1241: switch ( s ) {
! 1242: case 0:
! 1243: DP_Print = 0; DP_PrintShort = 0;
! 1244: break;
! 1245: case 1:
! 1246: DP_Print = 1;
! 1247: break;
! 1248: case 2: default:
! 1249: DP_Print = 0; DP_PrintShort = 1;
! 1250: break;
! 1251: }
! 1252: } else {
! 1253: if ( DP_Print ) {
! 1254: STOQ(1,q);
! 1255: } else if ( DP_PrintShort ) {
! 1256: STOQ(2,q);
! 1257: } else
! 1258: q = 0;
! 1259: }
1.8 noro 1260: *rp = q;
1.1 noro 1261: }
1262:
1.8 noro 1263: void Pdp_gr_main(arg,rp)
1.1 noro 1264: NODE arg;
1.8 noro 1265: LIST *rp;
1.1 noro 1266: {
1.8 noro 1267: LIST f,v;
1268: Num homo;
1269: Q m;
1270: int modular;
1271: struct order_spec ord;
1272:
1.11 noro 1273: do_weyl = 0;
1.8 noro 1274: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1275: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
1276: asir_assert(ARG2(arg),O_N,"dp_gr_main");
1277: asir_assert(ARG3(arg),O_N,"dp_gr_main");
1278: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1279: f = remove_zero_from_list(f);
1280: if ( !BDY(f) ) {
1281: *rp = f; return;
1282: }
1.8 noro 1283: homo = (Num)ARG2(arg);
1284: m = (Q)ARG3(arg);
1285: if ( !m )
1286: modular = 0;
1287: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1288: error("dp_gr_main : too large modulus");
1289: else
1290: modular = QTOS(m);
1291: create_order_spec(ARG4(arg),&ord);
1.16 noro 1292: dp_gr_main(f,v,homo,modular,0,&ord,rp);
1293: }
1294:
1295: void Pdp_gr_f_main(arg,rp)
1296: NODE arg;
1297: LIST *rp;
1298: {
1299: LIST f,v;
1300: Num homo;
1.26 noro 1301: int m,field,t;
1.16 noro 1302: struct order_spec ord;
1.26 noro 1303: NODE n;
1.16 noro 1304:
1305: do_weyl = 0;
1306: asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
1307: asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
1308: asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
1309: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1310: f = remove_zero_from_list(f);
1311: if ( !BDY(f) ) {
1312: *rp = f; return;
1313: }
1.16 noro 1314: homo = (Num)ARG2(arg);
1.27 noro 1315: #if 0
1316: asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
1.26 noro 1317: m = QTOS((Q)ARG3(arg));
1318: if ( m )
1319: error("dp_gr_f_main : trace lifting is not implemented yet");
1320: create_order_spec(ARG4(arg),&ord);
1.27 noro 1321: #else
1322: m = 0;
1323: create_order_spec(ARG3(arg),&ord);
1324: #endif
1.26 noro 1325: field = 0;
1326: for ( n = BDY(f); n; n = NEXT(n) ) {
1327: t = get_field_type(BDY(n));
1328: if ( !t )
1329: continue;
1330: if ( t < 0 )
1331: error("dp_gr_f_main : incosistent coefficients");
1332: if ( !field )
1333: field = t;
1334: else if ( t != field )
1335: error("dp_gr_f_main : incosistent coefficients");
1336: }
1337: dp_gr_main(f,v,homo,m?1:0,field,&ord,rp);
1.1 noro 1338: }
1339:
1.8 noro 1340: void Pdp_f4_main(arg,rp)
1341: NODE arg;
1342: LIST *rp;
1.1 noro 1343: {
1.8 noro 1344: LIST f,v;
1345: struct order_spec ord;
1.1 noro 1346:
1.11 noro 1347: do_weyl = 0;
1.8 noro 1348: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1349: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1350: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1351: f = remove_zero_from_list(f);
1352: if ( !BDY(f) ) {
1353: *rp = f; return;
1354: }
1.8 noro 1355: create_order_spec(ARG2(arg),&ord);
1.17 noro 1356: dp_f4_main(f,v,&ord,rp);
1.22 noro 1357: }
1358:
1359: /* dp_gr_checklist(list of dp) */
1360:
1361: void Pdp_gr_checklist(arg,rp)
1362: NODE arg;
1363: LIST *rp;
1364: {
1365: VECT g;
1366: LIST dp;
1367: NODE r;
1.23 noro 1368: int n;
1.22 noro 1369:
1370: do_weyl = 0;
1371: asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
1.23 noro 1372: asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
1373: n = QTOS((Q)ARG1(arg));
1374: gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
1.22 noro 1375: r = mknode(2,g,dp);
1376: MKLIST(*rp,r);
1.1 noro 1377: }
1378:
1.8 noro 1379: void Pdp_f4_mod_main(arg,rp)
1380: NODE arg;
1381: LIST *rp;
1.1 noro 1382: {
1.8 noro 1383: LIST f,v;
1384: int m;
1385: struct order_spec ord;
1386:
1.11 noro 1387: do_weyl = 0;
1.17 noro 1388: asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
1389: asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
1390: asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
1.8 noro 1391: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 1392: f = remove_zero_from_list(f);
1393: if ( !BDY(f) ) {
1394: *rp = f; return;
1395: }
1.20 noro 1396: if ( !m )
1397: error("dp_f4_mod_main : invalid argument");
1.8 noro 1398: create_order_spec(ARG3(arg),&ord);
1399: dp_f4_mod_main(f,v,m,&ord,rp);
1400: }
1.1 noro 1401:
1.8 noro 1402: void Pdp_gr_mod_main(arg,rp)
1403: NODE arg;
1404: LIST *rp;
1405: {
1406: LIST f,v;
1407: Num homo;
1408: int m;
1409: struct order_spec ord;
1410:
1.11 noro 1411: do_weyl = 0;
1.8 noro 1412: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
1413: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
1414: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
1415: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1.11 noro 1416: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1417: f = remove_zero_from_list(f);
1418: if ( !BDY(f) ) {
1419: *rp = f; return;
1420: }
1.11 noro 1421: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1422: if ( !m )
1423: error("dp_gr_mod_main : invalid argument");
1.11 noro 1424: create_order_spec(ARG4(arg),&ord);
1425: dp_gr_mod_main(f,v,homo,m,&ord,rp);
1426: }
1427:
1428: /* for Weyl algebra */
1429:
1430: void Pdp_weyl_gr_main(arg,rp)
1431: NODE arg;
1432: LIST *rp;
1433: {
1434: LIST f,v;
1435: Num homo;
1436: Q m;
1437: int modular;
1438: struct order_spec ord;
1439:
1440: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1441: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1442: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1443: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1444: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1445: f = remove_zero_from_list(f);
1446: if ( !BDY(f) ) {
1447: *rp = f; return;
1448: }
1.11 noro 1449: homo = (Num)ARG2(arg);
1450: m = (Q)ARG3(arg);
1451: if ( !m )
1452: modular = 0;
1453: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1454: error("dp_gr_main : too large modulus");
1455: else
1456: modular = QTOS(m);
1457: create_order_spec(ARG4(arg),&ord);
1.12 noro 1458: do_weyl = 1;
1.16 noro 1459: dp_gr_main(f,v,homo,modular,0,&ord,rp);
1460: do_weyl = 0;
1461: }
1462:
1463: void Pdp_weyl_gr_f_main(arg,rp)
1464: NODE arg;
1465: LIST *rp;
1466: {
1467: LIST f,v;
1468: Num homo;
1469: struct order_spec ord;
1470:
1471: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1472: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1473: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1474: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1475: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1476: f = remove_zero_from_list(f);
1477: if ( !BDY(f) ) {
1478: *rp = f; return;
1479: }
1.16 noro 1480: homo = (Num)ARG2(arg);
1481: create_order_spec(ARG3(arg),&ord);
1482: do_weyl = 1;
1483: dp_gr_main(f,v,homo,0,1,&ord,rp);
1.12 noro 1484: do_weyl = 0;
1.11 noro 1485: }
1486:
1487: void Pdp_weyl_f4_main(arg,rp)
1488: NODE arg;
1489: LIST *rp;
1490: {
1491: LIST f,v;
1492: struct order_spec ord;
1493:
1494: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1495: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1496: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1497: f = remove_zero_from_list(f);
1498: if ( !BDY(f) ) {
1499: *rp = f; return;
1500: }
1.11 noro 1501: create_order_spec(ARG2(arg),&ord);
1.12 noro 1502: do_weyl = 1;
1.17 noro 1503: dp_f4_main(f,v,&ord,rp);
1.12 noro 1504: do_weyl = 0;
1.11 noro 1505: }
1506:
1507: void Pdp_weyl_f4_mod_main(arg,rp)
1508: NODE arg;
1509: LIST *rp;
1510: {
1511: LIST f,v;
1512: int m;
1513: struct order_spec ord;
1514:
1515: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1516: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1517: asir_assert(ARG2(arg),O_N,"dp_f4_main");
1518: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 1519: f = remove_zero_from_list(f);
1520: if ( !BDY(f) ) {
1521: *rp = f; return;
1522: }
1.20 noro 1523: if ( !m )
1524: error("dp_weyl_f4_mod_main : invalid argument");
1.11 noro 1525: create_order_spec(ARG3(arg),&ord);
1.12 noro 1526: do_weyl = 1;
1.11 noro 1527: dp_f4_mod_main(f,v,m,&ord,rp);
1.12 noro 1528: do_weyl = 0;
1.11 noro 1529: }
1530:
1531: void Pdp_weyl_gr_mod_main(arg,rp)
1532: NODE arg;
1533: LIST *rp;
1534: {
1535: LIST f,v;
1536: Num homo;
1537: int m;
1538: struct order_spec ord;
1539:
1540: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
1541: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
1542: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
1543: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
1.8 noro 1544: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1545: f = remove_zero_from_list(f);
1546: if ( !BDY(f) ) {
1547: *rp = f; return;
1548: }
1.8 noro 1549: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1550: if ( !m )
1551: error("dp_weyl_gr_mod_main : invalid argument");
1.8 noro 1552: create_order_spec(ARG4(arg),&ord);
1.12 noro 1553: do_weyl = 1;
1.8 noro 1554: dp_gr_mod_main(f,v,homo,m,&ord,rp);
1.12 noro 1555: do_weyl = 0;
1.1 noro 1556: }
1.8 noro 1557:
1.24 noro 1558: static VECT current_dl_weight_vector_obj;
1559: int *current_dl_weight_vector;
1560:
1561: void Pdp_set_weight(arg,rp)
1562: NODE arg;
1563: VECT *rp;
1564: {
1565: VECT v;
1566: int i,n;
1567:
1568: if ( !arg )
1569: *rp = current_dl_weight_vector_obj;
1570: else if ( !ARG0(arg) ) {
1571: current_dl_weight_vector_obj = 0;
1572: current_dl_weight_vector = 0;
1573: *rp = 0;
1574: } else {
1575: asir_assert(ARG0(arg),O_VECT,"dp_set_weight");
1576: v = (VECT)ARG0(arg);
1577: current_dl_weight_vector_obj = v;
1578: n = v->len;
1579: current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
1580: for ( i = 0; i < n; i++ )
1581: current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
1582: *rp = v;
1583: }
1584: }
1585:
1586: static VECT current_weyl_weight_vector_obj;
1587: int *current_weyl_weight_vector;
1.15 noro 1588:
1589: void Pdp_weyl_set_weight(arg,rp)
1590: NODE arg;
1591: VECT *rp;
1592: {
1593: VECT v;
1594: int i,n;
1595:
1596: if ( !arg )
1.24 noro 1597: *rp = current_weyl_weight_vector_obj;
1.15 noro 1598: else {
1599: asir_assert(ARG0(arg),O_VECT,"dp_weyl_set_weight");
1600: v = (VECT)ARG0(arg);
1.24 noro 1601: current_weyl_weight_vector_obj = v;
1.15 noro 1602: n = v->len;
1.24 noro 1603: current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
1.15 noro 1604: for ( i = 0; i < n; i++ )
1.24 noro 1605: current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
1.15 noro 1606: *rp = v;
1607: }
1.25 noro 1608: }
1609:
1610: LIST remove_zero_from_list(LIST l)
1611: {
1612: NODE n,r0,r;
1613: LIST rl;
1614:
1615: asir_assert(l,O_LIST,"remove_zero_from_list");
1616: n = BDY(l);
1617: for ( r0 = 0; n; n = NEXT(n) )
1618: if ( BDY(n) ) {
1619: NEXTNODE(r0,r);
1620: BDY(r) = BDY(n);
1621: }
1622: if ( r0 )
1623: NEXT(r) = 0;
1624: MKLIST(rl,r0);
1625: return rl;
1.26 noro 1626: }
1627:
1628: int get_field_type(P p)
1629: {
1630: int type,t;
1631: DCP dc;
1632:
1633: if ( !p )
1634: return 0;
1635: else if ( NUM(p) )
1636: return NID((Num)p);
1637: else {
1638: type = 0;
1639: for ( dc = DC(p); dc; dc = NEXT(dc) ) {
1640: t = get_field_type(COEF(dc));
1641: if ( !t )
1642: continue;
1643: if ( t < 0 )
1644: return t;
1645: if ( !type )
1646: type = t;
1647: else if ( t != type )
1648: return -1;
1649: }
1650: return type;
1651: }
1.15 noro 1652: }
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