Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.25
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.25 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.24 2002/01/28 00:54:41 noro Exp $
1.5 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "base.h"
52: #include "parse.h"
53:
54: extern int dp_fcoeffs;
1.8 noro 55: extern int dp_nelim;
56: extern int dp_order_pair_length;
57: extern struct order_pair *dp_order_pair;
58: extern struct order_spec dp_current_spec;
59:
1.11 noro 60: int do_weyl;
1.1 noro 61:
62: void Pdp_ord(), Pdp_ptod(), Pdp_dtop();
63: void Pdp_ptozp(), Pdp_ptozp2(), Pdp_red(), Pdp_red2(), Pdp_lcm(), Pdp_redble();
64: void Pdp_sp(), Pdp_hm(), Pdp_ht(), Pdp_hc(), Pdp_rest(), Pdp_td(), Pdp_sugar();
65: void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv();
66: void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat();
1.9 noro 67: void Pdp_nf(),Pdp_true_nf();
1.1 noro 68: void Pdp_nf_mod(),Pdp_true_nf_mod();
69: void Pdp_criB(),Pdp_nelim();
1.9 noro 70: void Pdp_minp(),Pdp_sp_mod();
1.1 noro 71: void Pdp_homo(),Pdp_dehomo();
1.16 noro 72: void Pdp_gr_mod_main(),Pdp_gr_f_main();
1.1 noro 73: void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags();
1.16 noro 74: void Pdp_f4_main(),Pdp_f4_mod_main(),Pdp_f4_f_main();
1.1 noro 75: void Pdp_gr_print();
1.8 noro 76: void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_mdtod();
77: void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
78: void Pdp_cont();
1.22 noro 79: void Pdp_gr_checklist();
1.1 noro 80:
1.13 noro 81: void Pdp_weyl_red();
82: void Pdp_weyl_sp();
83: void Pdp_weyl_nf(),Pdp_weyl_nf_mod();
1.16 noro 84: void Pdp_weyl_gr_main(),Pdp_weyl_gr_mod_main(),Pdp_weyl_gr_f_main();
85: void Pdp_weyl_f4_main(),Pdp_weyl_f4_mod_main(),Pdp_weyl_f4_f_main();
1.13 noro 86: void Pdp_weyl_mul(),Pdp_weyl_mul_mod();
1.15 noro 87: void Pdp_weyl_set_weight();
1.24 noro 88: void Pdp_set_weight();
1.16 noro 89: void Pdp_nf_f(),Pdp_weyl_nf_f();
90: void Pdp_lnf_f();
1.11 noro 91:
1.25 ! noro 92: LIST remove_zero_from_list(LIST);
! 93:
1.1 noro 94: struct ftab dp_tab[] = {
1.8 noro 95: /* content reduction */
1.1 noro 96: {"dp_ptozp",Pdp_ptozp,1},
97: {"dp_ptozp2",Pdp_ptozp2,2},
98: {"dp_prim",Pdp_prim,1},
1.8 noro 99: {"dp_red_coef",Pdp_red_coef,2},
100: {"dp_cont",Pdp_cont,1},
101:
1.11 noro 102: /* polynomial ring */
1.8 noro 103: /* s-poly */
104: {"dp_sp",Pdp_sp,2},
105: {"dp_sp_mod",Pdp_sp_mod,3},
106:
107: /* m-reduction */
1.1 noro 108: {"dp_red",Pdp_red,3},
109: {"dp_red_mod",Pdp_red_mod,4},
1.8 noro 110:
111: /* normal form */
1.1 noro 112: {"dp_nf",Pdp_nf,4},
1.16 noro 113: {"dp_nf_f",Pdp_nf_f,4},
1.1 noro 114: {"dp_true_nf",Pdp_true_nf,4},
115: {"dp_nf_mod",Pdp_nf_mod,5},
116: {"dp_true_nf_mod",Pdp_true_nf_mod,5},
1.8 noro 117: {"dp_lnf_mod",Pdp_lnf_mod,3},
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.16 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);
379: }
1.1 noro 380:
381: void Pdp_ord(arg,rp)
382: NODE arg;
383: Obj *rp;
384: {
385: struct order_spec spec;
386:
387: if ( !arg )
388: *rp = dp_current_spec.obj;
389: else if ( !create_order_spec((Obj)ARG0(arg),&spec) )
390: error("dp_ord : invalid order specification");
391: else {
392: initd(&spec); *rp = spec.obj;
393: }
394: }
395:
396: void Pdp_ptod(arg,rp)
397: NODE arg;
398: DP *rp;
399: {
400: NODE n;
401: VL vl,tvl;
402:
403: asir_assert(ARG0(arg),O_P,"dp_ptod");
404: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
405: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
406: if ( !vl ) {
407: NEWVL(vl); tvl = vl;
408: } else {
409: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
410: }
411: VR(tvl) = VR((P)BDY(n));
412: }
413: if ( vl )
414: NEXT(tvl) = 0;
415: ptod(CO,vl,(P)ARG0(arg),rp);
416: }
417:
418: void Pdp_dtop(arg,rp)
419: NODE arg;
420: P *rp;
421: {
422: NODE n;
423: VL vl,tvl;
424:
425: asir_assert(ARG0(arg),O_DP,"dp_dtop");
426: asir_assert(ARG1(arg),O_LIST,"dp_dtop");
427: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
428: if ( !vl ) {
429: NEWVL(vl); tvl = vl;
430: } else {
431: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
432: }
433: VR(tvl) = VR((P)BDY(n));
434: }
435: if ( vl )
436: NEXT(tvl) = 0;
437: dtop(CO,vl,(DP)ARG0(arg),rp);
438: }
439:
440: extern LIST Dist;
441:
442: void Pdp_ptozp(arg,rp)
443: NODE arg;
444: DP *rp;
445: {
446: asir_assert(ARG0(arg),O_DP,"dp_ptozp");
1.10 noro 447: dp_ptozp((DP)ARG0(arg),rp);
1.1 noro 448: }
449:
450: void Pdp_ptozp2(arg,rp)
451: NODE arg;
452: LIST *rp;
453: {
454: DP p0,p1,h,r;
455: NODE n0;
456:
457: p0 = (DP)ARG0(arg); p1 = (DP)ARG1(arg);
458: asir_assert(p0,O_DP,"dp_ptozp2");
459: asir_assert(p1,O_DP,"dp_ptozp2");
1.10 noro 460: dp_ptozp2(p0,p1,&h,&r);
1.1 noro 461: NEWNODE(n0); BDY(n0) = (pointer)h;
462: NEWNODE(NEXT(n0)); BDY(NEXT(n0)) = (pointer)r;
463: NEXT(NEXT(n0)) = 0;
464: MKLIST(*rp,n0);
465: }
466:
467: void Pdp_prim(arg,rp)
468: NODE arg;
469: DP *rp;
470: {
471: DP t;
472:
473: asir_assert(ARG0(arg),O_DP,"dp_prim");
474: dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
475: }
476:
477: void Pdp_mod(arg,rp)
478: NODE arg;
479: DP *rp;
480: {
481: DP p;
482: int mod;
483: NODE subst;
484:
485: asir_assert(ARG0(arg),O_DP,"dp_mod");
486: asir_assert(ARG1(arg),O_N,"dp_mod");
487: asir_assert(ARG2(arg),O_LIST,"dp_mod");
488: p = (DP)ARG0(arg); mod = QTOS((Q)ARG1(arg));
489: subst = BDY((LIST)ARG2(arg));
490: dp_mod(p,mod,subst,rp);
491: }
492:
493: void Pdp_rat(arg,rp)
494: NODE arg;
495: DP *rp;
496: {
497: asir_assert(ARG0(arg),O_DP,"dp_rat");
498: dp_rat((DP)ARG0(arg),rp);
499: }
500:
1.9 noro 501: extern int DP_Multiple;
502:
1.1 noro 503: void Pdp_nf(arg,rp)
504: NODE arg;
505: DP *rp;
506: {
507: NODE b;
508: DP *ps;
509: DP g;
510: int full;
511:
1.11 noro 512: do_weyl = 0;
1.1 noro 513: asir_assert(ARG0(arg),O_LIST,"dp_nf");
514: asir_assert(ARG1(arg),O_DP,"dp_nf");
515: asir_assert(ARG2(arg),O_VECT,"dp_nf");
516: asir_assert(ARG3(arg),O_N,"dp_nf");
517: if ( !(g = (DP)ARG1(arg)) ) {
518: *rp = 0; return;
519: }
520: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
521: full = (Q)ARG3(arg) ? 1 : 0;
1.16 noro 522: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
1.1 noro 523: }
524:
1.11 noro 525: void Pdp_weyl_nf(arg,rp)
526: NODE arg;
527: DP *rp;
528: {
529: NODE b;
530: DP *ps;
531: DP g;
532: int full;
533:
534: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf");
535: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf");
536: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf");
537: asir_assert(ARG3(arg),O_N,"dp_weyl_nf");
538: if ( !(g = (DP)ARG1(arg)) ) {
539: *rp = 0; return;
540: }
541: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
542: full = (Q)ARG3(arg) ? 1 : 0;
1.12 noro 543: do_weyl = 1;
1.16 noro 544: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
545: do_weyl = 0;
546: }
547:
548: /* nf computation using field operations */
549:
550: void Pdp_nf_f(arg,rp)
551: NODE arg;
552: DP *rp;
553: {
554: NODE b;
555: DP *ps;
556: DP g;
557: int full;
558:
559: do_weyl = 0;
560: asir_assert(ARG0(arg),O_LIST,"dp_nf_f");
561: asir_assert(ARG1(arg),O_DP,"dp_nf_f");
562: asir_assert(ARG2(arg),O_VECT,"dp_nf_f");
563: asir_assert(ARG3(arg),O_N,"dp_nf_f");
564: if ( !(g = (DP)ARG1(arg)) ) {
565: *rp = 0; return;
566: }
567: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
568: full = (Q)ARG3(arg) ? 1 : 0;
569: dp_nf_f(b,g,ps,full,rp);
570: }
571:
572: void Pdp_weyl_nf_f(arg,rp)
573: NODE arg;
574: DP *rp;
575: {
576: NODE b;
577: DP *ps;
578: DP g;
579: int full;
580:
581: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_f");
582: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_f");
583: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_f");
584: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_f");
585: if ( !(g = (DP)ARG1(arg)) ) {
586: *rp = 0; return;
587: }
588: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
589: full = (Q)ARG3(arg) ? 1 : 0;
590: do_weyl = 1;
591: dp_nf_f(b,g,ps,full,rp);
1.12 noro 592: do_weyl = 0;
1.11 noro 593: }
594:
1.13 noro 595: void Pdp_nf_mod(arg,rp)
596: NODE arg;
597: DP *rp;
598: {
599: NODE b;
600: DP g;
601: DP *ps;
602: int mod,full,ac;
603: NODE n,n0;
604:
1.14 noro 605: do_weyl = 0;
1.13 noro 606: ac = argc(arg);
1.14 noro 607: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
608: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
609: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
610: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
611: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
1.13 noro 612: if ( !(g = (DP)ARG1(arg)) ) {
613: *rp = 0; return;
614: }
615: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
616: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
617: for ( n0 = n = 0; b; b = NEXT(b) ) {
618: NEXTNODE(n0,n);
619: BDY(n) = (pointer)QTOS((Q)BDY(b));
620: }
621: if ( n0 )
622: NEXT(n) = 0;
623: dp_nf_mod(n0,g,ps,mod,full,rp);
624: }
625:
1.1 noro 626: void Pdp_true_nf(arg,rp)
627: NODE arg;
628: LIST *rp;
629: {
630: NODE b,n;
631: DP *ps;
632: DP g;
633: DP nm;
634: P dn;
635: int full;
636:
1.11 noro 637: do_weyl = 0;
1.1 noro 638: asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
639: asir_assert(ARG1(arg),O_DP,"dp_true_nf");
640: asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
641: asir_assert(ARG3(arg),O_N,"dp_nf");
642: if ( !(g = (DP)ARG1(arg)) ) {
643: nm = 0; dn = (P)ONE;
644: } else {
645: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
646: full = (Q)ARG3(arg) ? 1 : 0;
647: dp_true_nf(b,g,ps,full,&nm,&dn);
648: }
649: NEWNODE(n); BDY(n) = (pointer)nm;
650: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
651: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
652: }
653:
1.13 noro 654: void Pdp_weyl_nf_mod(arg,rp)
1.8 noro 655: NODE arg;
656: DP *rp;
657: {
658: NODE b;
659: DP g;
660: DP *ps;
661: int mod,full,ac;
1.9 noro 662: NODE n,n0;
1.8 noro 663:
664: ac = argc(arg);
1.14 noro 665: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_mod");
666: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_mod");
667: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_mod");
668: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_mod");
669: asir_assert(ARG4(arg),O_N,"dp_weyl_nf_mod");
1.8 noro 670: if ( !(g = (DP)ARG1(arg)) ) {
671: *rp = 0; return;
672: }
673: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
674: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
1.9 noro 675: for ( n0 = n = 0; b; b = NEXT(b) ) {
676: NEXTNODE(n0,n);
677: BDY(n) = (pointer)QTOS((Q)BDY(b));
678: }
679: if ( n0 )
680: NEXT(n) = 0;
1.13 noro 681: do_weyl = 1;
682: dp_nf_mod(n0,g,ps,mod,full,rp);
683: do_weyl = 0;
1.8 noro 684: }
685:
686: void Pdp_true_nf_mod(arg,rp)
687: NODE arg;
688: LIST *rp;
689: {
690: NODE b;
691: DP g,nm;
692: P dn;
693: DP *ps;
694: int mod,full;
695: NODE n;
696:
1.11 noro 697: do_weyl = 0;
1.8 noro 698: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
699: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
700: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
701: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
702: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
703: if ( !(g = (DP)ARG1(arg)) ) {
704: nm = 0; dn = (P)ONEM;
705: } else {
706: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
707: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
708: dp_true_nf_mod(b,g,ps,mod,full,&nm,&dn);
709: }
710: NEWNODE(n); BDY(n) = (pointer)nm;
711: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
712: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.1 noro 713: }
714:
715: void Pdp_tdiv(arg,rp)
716: NODE arg;
717: DP *rp;
718: {
719: MP m,mr,mr0;
720: DP p;
721: Q c;
722: N d,q,r;
723: int sgn;
724:
725: asir_assert(ARG0(arg),O_DP,"dp_tdiv");
726: asir_assert(ARG1(arg),O_N,"dp_tdiv");
727: p = (DP)ARG0(arg); d = NM((Q)ARG1(arg)); sgn = SGN((Q)ARG1(arg));
728: if ( !p )
729: *rp = 0;
730: else {
731: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
732: divn(NM((Q)m->c),d,&q,&r);
733: if ( r ) {
734: *rp = 0; return;
735: } else {
736: NEXTMP(mr0,mr); NTOQ(q,SGN((Q)m->c)*sgn,c);
737: mr->c = (P)c; mr->dl = m->dl;
738: }
739: }
740: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
741: }
742: }
743:
744: void Pdp_red_coef(arg,rp)
745: NODE arg;
746: DP *rp;
747: {
748: MP m,mr,mr0;
749: P q,r;
750: DP p;
751: P mod;
752:
753: p = (DP)ARG0(arg); mod = (P)ARG1(arg);
754: asir_assert(p,O_DP,"dp_red_coef");
755: asir_assert(mod,O_P,"dp_red_coef");
756: if ( !p )
757: *rp = 0;
758: else {
759: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
760: divsrp(CO,m->c,mod,&q,&r);
761: if ( r ) {
762: NEXTMP(mr0,mr); mr->c = r; mr->dl = m->dl;
763: }
764: }
765: if ( mr0 ) {
766: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
767: } else
768: *rp = 0;
769: }
770: }
771:
772: void Pdp_redble(arg,rp)
773: NODE arg;
774: Q *rp;
775: {
776: asir_assert(ARG0(arg),O_DP,"dp_redble");
777: asir_assert(ARG1(arg),O_DP,"dp_redble");
778: if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
779: *rp = ONE;
780: else
781: *rp = 0;
782: }
783:
784: void Pdp_red_mod(arg,rp)
785: NODE arg;
786: LIST *rp;
787: {
788: DP h,r;
789: P dmy;
790: NODE n;
791:
1.11 noro 792: do_weyl = 0;
1.1 noro 793: asir_assert(ARG0(arg),O_DP,"dp_red_mod");
794: asir_assert(ARG1(arg),O_DP,"dp_red_mod");
795: asir_assert(ARG2(arg),O_DP,"dp_red_mod");
796: asir_assert(ARG3(arg),O_N,"dp_red_mod");
797: dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),QTOS((Q)ARG3(arg)),
798: &h,&r,&dmy);
799: NEWNODE(n); BDY(n) = (pointer)h;
800: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
801: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
802: }
1.13 noro 803:
1.1 noro 804: void Pdp_subd(arg,rp)
805: NODE arg;
806: DP *rp;
807: {
808: DP p1,p2;
809:
810: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
811: asir_assert(p1,O_DP,"dp_subd");
812: asir_assert(p2,O_DP,"dp_subd");
813: dp_subd(p1,p2,rp);
814: }
815:
1.12 noro 816: void Pdp_weyl_mul(arg,rp)
817: NODE arg;
818: DP *rp;
819: {
820: DP p1,p2;
821:
822: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
823: asir_assert(p1,O_DP,"dp_weyl_mul"); asir_assert(p2,O_DP,"dp_mul");
824: do_weyl = 1;
825: muld(CO,p1,p2,rp);
1.13 noro 826: do_weyl = 0;
827: }
828:
829: void Pdp_weyl_mul_mod(arg,rp)
830: NODE arg;
831: DP *rp;
832: {
833: DP p1,p2;
834: Q m;
835:
836: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); m = (Q)ARG2(arg);
837: asir_assert(p1,O_DP,"dp_weyl_mul_mod");
838: asir_assert(p2,O_DP,"dp_mul_mod");
839: asir_assert(m,O_N,"dp_mul_mod");
840: do_weyl = 1;
841: mulmd(CO,QTOS(m),p1,p2,rp);
1.12 noro 842: do_weyl = 0;
843: }
844:
1.1 noro 845: void Pdp_red(arg,rp)
846: NODE arg;
847: LIST *rp;
848: {
849: NODE n;
1.4 noro 850: DP head,rest,dmy1;
1.1 noro 851: P dmy;
852:
1.11 noro 853: do_weyl = 0;
1.1 noro 854: asir_assert(ARG0(arg),O_DP,"dp_red");
855: asir_assert(ARG1(arg),O_DP,"dp_red");
856: asir_assert(ARG2(arg),O_DP,"dp_red");
1.4 noro 857: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.1 noro 858: NEWNODE(n); BDY(n) = (pointer)head;
859: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
860: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
861: }
862:
1.11 noro 863: void Pdp_weyl_red(arg,rp)
864: NODE arg;
865: LIST *rp;
866: {
867: NODE n;
868: DP head,rest,dmy1;
869: P dmy;
870:
871: asir_assert(ARG0(arg),O_DP,"dp_weyl_red");
872: asir_assert(ARG1(arg),O_DP,"dp_weyl_red");
873: asir_assert(ARG2(arg),O_DP,"dp_weyl_red");
1.12 noro 874: do_weyl = 1;
1.11 noro 875: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.12 noro 876: do_weyl = 0;
1.11 noro 877: NEWNODE(n); BDY(n) = (pointer)head;
878: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
879: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
880: }
881:
1.1 noro 882: void Pdp_sp(arg,rp)
883: NODE arg;
884: DP *rp;
885: {
886: DP p1,p2;
887:
1.11 noro 888: do_weyl = 0;
1.1 noro 889: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
890: asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
891: dp_sp(p1,p2,rp);
892: }
893:
1.11 noro 894: void Pdp_weyl_sp(arg,rp)
895: NODE arg;
896: DP *rp;
897: {
898: DP p1,p2;
899:
900: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
901: asir_assert(p1,O_DP,"dp_weyl_sp"); asir_assert(p2,O_DP,"dp_sp");
1.12 noro 902: do_weyl = 1;
1.11 noro 903: dp_sp(p1,p2,rp);
1.12 noro 904: do_weyl = 0;
1.11 noro 905: }
906:
1.1 noro 907: void Pdp_sp_mod(arg,rp)
908: NODE arg;
909: DP *rp;
910: {
911: DP p1,p2;
912: int mod;
913:
1.11 noro 914: do_weyl = 0;
1.1 noro 915: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
916: asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
917: asir_assert(ARG2(arg),O_N,"dp_sp_mod");
918: mod = QTOS((Q)ARG2(arg));
919: dp_sp_mod(p1,p2,mod,rp);
920: }
921:
922: void Pdp_lcm(arg,rp)
923: NODE arg;
924: DP *rp;
925: {
926: int i,n,td;
927: DL d1,d2,d;
928: MP m;
929: DP p1,p2;
930:
931: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
932: asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
933: n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
934: NEWDL(d,n);
935: for ( i = 0, td = 0; i < n; i++ ) {
1.24 noro 936: d->d[i] = MAX(d1->d[i],d2->d[i]); td += MUL_WEIGHT(d->d[i],i);
1.1 noro 937: }
938: d->td = td;
939: NEWMP(m); m->dl = d; m->c = (P)ONE; NEXT(m) = 0;
940: MKDP(n,m,*rp); (*rp)->sugar = td; /* XXX */
941: }
942:
943: void Pdp_hm(arg,rp)
944: NODE arg;
945: DP *rp;
946: {
947: DP p;
948:
949: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
950: dp_hm(p,rp);
951: }
952:
953: void Pdp_ht(arg,rp)
954: NODE arg;
955: DP *rp;
956: {
957: DP p;
958: MP m,mr;
959:
960: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
961: if ( !p )
962: *rp = 0;
963: else {
964: m = BDY(p);
965: NEWMP(mr); mr->dl = m->dl; mr->c = (P)ONE; NEXT(mr) = 0;
966: MKDP(p->nv,mr,*rp); (*rp)->sugar = mr->dl->td; /* XXX */
967: }
968: }
969:
970: void Pdp_hc(arg,rp)
971: NODE arg;
972: P *rp;
973: {
974: asir_assert(ARG0(arg),O_DP,"dp_hc");
975: if ( !ARG0(arg) )
976: *rp = 0;
977: else
978: *rp = BDY((DP)ARG0(arg))->c;
979: }
980:
981: void Pdp_rest(arg,rp)
982: NODE arg;
983: DP *rp;
984: {
985: asir_assert(ARG0(arg),O_DP,"dp_rest");
986: if ( !ARG0(arg) )
987: *rp = 0;
988: else
989: dp_rest((DP)ARG0(arg),rp);
990: }
991:
992: void Pdp_td(arg,rp)
993: NODE arg;
994: Q *rp;
995: {
996: DP p;
997:
998: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
999: if ( !p )
1000: *rp = 0;
1001: else
1002: STOQ(BDY(p)->dl->td,*rp);
1003: }
1004:
1005: void Pdp_sugar(arg,rp)
1006: NODE arg;
1007: Q *rp;
1008: {
1009: DP p;
1010:
1011: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
1012: if ( !p )
1013: *rp = 0;
1014: else
1015: STOQ(p->sugar,*rp);
1016: }
1017:
1018: void Pdp_cri1(arg,rp)
1019: NODE arg;
1020: Q *rp;
1021: {
1022: DP p1,p2;
1023: int *d1,*d2;
1024: int i,n;
1025:
1026: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1027: asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
1028: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
1029: for ( i = 0; i < n; i++ )
1030: if ( d1[i] > d2[i] )
1031: break;
1032: *rp = i == n ? ONE : 0;
1033: }
1034:
1035: void Pdp_cri2(arg,rp)
1036: NODE arg;
1037: Q *rp;
1038: {
1039: DP p1,p2;
1040: int *d1,*d2;
1041: int i,n;
1042:
1043: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1044: asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
1045: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
1046: for ( i = 0; i < n; i++ )
1047: if ( MIN(d1[i],d2[i]) >= 1 )
1048: break;
1049: *rp = i == n ? ONE : 0;
1050: }
1051:
1052: void Pdp_minp(arg,rp)
1053: NODE arg;
1054: LIST *rp;
1055: {
1056: NODE tn,tn1,d,dd,dd0,p,tp;
1057: LIST l,minp;
1058: DP lcm,tlcm;
1059: int s,ts;
1060:
1061: asir_assert(ARG0(arg),O_LIST,"dp_minp");
1062: d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
1063: p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
1064: if ( !ARG1(arg) ) {
1065: s = QTOS((Q)BDY(p)); p = NEXT(p);
1066: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1067: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1068: tlcm = (DP)BDY(tp); tp = NEXT(tp);
1069: ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
1070: NEXTNODE(dd0,dd);
1071: if ( ts < s ) {
1072: BDY(dd) = (pointer)minp;
1073: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1074: } else if ( ts == s ) {
1075: if ( compd(CO,lcm,tlcm) > 0 ) {
1076: BDY(dd) = (pointer)minp;
1077: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1078: } else
1079: BDY(dd) = BDY(d);
1080: } else
1081: BDY(dd) = BDY(d);
1082: }
1083: } else {
1084: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1085: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1086: tlcm = (DP)BDY(tp);
1087: NEXTNODE(dd0,dd);
1088: if ( compd(CO,lcm,tlcm) > 0 ) {
1089: BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
1090: } else
1091: BDY(dd) = BDY(d);
1092: }
1093: }
1094: if ( dd0 )
1095: NEXT(dd) = 0;
1096: MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
1097: }
1098:
1099: void Pdp_criB(arg,rp)
1100: NODE arg;
1101: LIST *rp;
1102: {
1103: NODE d,ij,dd,ddd;
1104: int i,j,s,n;
1105: DP *ps;
1106: DL ts,ti,tj,lij,tdl;
1107:
1108: asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
1109: asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
1110: asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
1111: if ( !d )
1112: *rp = (LIST)ARG0(arg);
1113: else {
1114: ts = BDY(ps[s])->dl;
1115: n = ps[s]->nv;
1116: NEWDL(tdl,n);
1117: for ( dd = 0; d; d = NEXT(d) ) {
1118: ij = BDY((LIST)BDY(d));
1119: i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1120: j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1121: lij = BDY((DP)BDY(ij))->dl;
1122: ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
1123: if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
1124: || !dl_equal(n,lij,tdl)
1125: || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
1126: && dl_equal(n,tdl,lij))
1127: || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
1128: && dl_equal(n,tdl,lij)) ) {
1129: MKNODE(ddd,BDY(d),dd);
1130: dd = ddd;
1131: }
1132: }
1133: MKLIST(*rp,dd);
1134: }
1135: }
1136:
1137: void Pdp_nelim(arg,rp)
1138: NODE arg;
1139: Q *rp;
1140: {
1141: if ( arg ) {
1142: asir_assert(ARG0(arg),O_N,"dp_nelim");
1143: dp_nelim = QTOS((Q)ARG0(arg));
1144: }
1145: STOQ(dp_nelim,*rp);
1146: }
1147:
1148: void Pdp_mag(arg,rp)
1149: NODE arg;
1150: Q *rp;
1151: {
1152: DP p;
1153: int s;
1154: MP m;
1155:
1156: p = (DP)ARG0(arg);
1157: asir_assert(p,O_DP,"dp_mag");
1158: if ( !p )
1159: *rp = 0;
1160: else {
1161: for ( s = 0, m = BDY(p); m; m = NEXT(m) )
1162: s += p_mag(m->c);
1163: STOQ(s,*rp);
1164: }
1165: }
1166:
1167: extern int kara_mag;
1168:
1169: void Pdp_set_kara(arg,rp)
1170: NODE arg;
1171: Q *rp;
1172: {
1173: if ( arg ) {
1174: asir_assert(ARG0(arg),O_N,"dp_set_kara");
1175: kara_mag = QTOS((Q)ARG0(arg));
1176: }
1177: STOQ(kara_mag,*rp);
1178: }
1179:
1180: void Pdp_homo(arg,rp)
1181: NODE arg;
1182: DP *rp;
1183: {
1184: asir_assert(ARG0(arg),O_DP,"dp_homo");
1185: dp_homo((DP)ARG0(arg),rp);
1186: }
1187:
1.8 noro 1188: void Pdp_dehomo(arg,rp)
1189: NODE arg;
1.1 noro 1190: DP *rp;
1191: {
1.8 noro 1192: asir_assert(ARG0(arg),O_DP,"dp_dehomo");
1193: dp_dehomo((DP)ARG0(arg),rp);
1194: }
1195:
1196: void Pdp_gr_flags(arg,rp)
1197: NODE arg;
1198: LIST *rp;
1199: {
1200: Obj name,value;
1201: NODE n;
1.1 noro 1202:
1.8 noro 1203: if ( arg ) {
1204: asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
1205: n = BDY((LIST)ARG0(arg));
1206: while ( n ) {
1207: name = (Obj)BDY(n); n = NEXT(n);
1208: if ( !n )
1209: break;
1210: else {
1211: value = (Obj)BDY(n); n = NEXT(n);
1212: }
1213: dp_set_flag(name,value);
1.1 noro 1214: }
1215: }
1.8 noro 1216: dp_make_flaglist(rp);
1217: }
1218:
1219: extern int DP_Print;
1220:
1221: void Pdp_gr_print(arg,rp)
1222: NODE arg;
1223: Q *rp;
1224: {
1225: Q q;
1226:
1227: if ( arg ) {
1228: asir_assert(ARG0(arg),O_N,"dp_gr_print");
1229: q = (Q)ARG0(arg); DP_Print = QTOS(q);
1230: } else
1231: STOQ(DP_Print,q);
1232: *rp = q;
1.1 noro 1233: }
1234:
1.8 noro 1235: void Pdp_gr_main(arg,rp)
1.1 noro 1236: NODE arg;
1.8 noro 1237: LIST *rp;
1.1 noro 1238: {
1.8 noro 1239: LIST f,v;
1240: Num homo;
1241: Q m;
1242: int modular;
1243: struct order_spec ord;
1244:
1.11 noro 1245: do_weyl = 0;
1.8 noro 1246: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1247: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
1248: asir_assert(ARG2(arg),O_N,"dp_gr_main");
1249: asir_assert(ARG3(arg),O_N,"dp_gr_main");
1250: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 ! noro 1251: f = remove_zero_from_list(f);
! 1252: if ( !BDY(f) ) {
! 1253: *rp = f; return;
! 1254: }
1.8 noro 1255: homo = (Num)ARG2(arg);
1256: m = (Q)ARG3(arg);
1257: if ( !m )
1258: modular = 0;
1259: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1260: error("dp_gr_main : too large modulus");
1261: else
1262: modular = QTOS(m);
1263: create_order_spec(ARG4(arg),&ord);
1.16 noro 1264: dp_gr_main(f,v,homo,modular,0,&ord,rp);
1265: }
1266:
1267: void Pdp_gr_f_main(arg,rp)
1268: NODE arg;
1269: LIST *rp;
1270: {
1271: LIST f,v;
1272: Num homo;
1273: struct order_spec ord;
1274:
1275: do_weyl = 0;
1276: asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
1277: asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
1278: asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
1279: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 ! noro 1280: f = remove_zero_from_list(f);
! 1281: if ( !BDY(f) ) {
! 1282: *rp = f; return;
! 1283: }
1.16 noro 1284: homo = (Num)ARG2(arg);
1285: create_order_spec(ARG3(arg),&ord);
1286: dp_gr_main(f,v,homo,0,1,&ord,rp);
1.1 noro 1287: }
1288:
1.8 noro 1289: void Pdp_f4_main(arg,rp)
1290: NODE arg;
1291: LIST *rp;
1.1 noro 1292: {
1.8 noro 1293: LIST f,v;
1294: struct order_spec ord;
1.1 noro 1295:
1.11 noro 1296: do_weyl = 0;
1.8 noro 1297: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1298: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1299: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 ! noro 1300: f = remove_zero_from_list(f);
! 1301: if ( !BDY(f) ) {
! 1302: *rp = f; return;
! 1303: }
1.8 noro 1304: create_order_spec(ARG2(arg),&ord);
1.17 noro 1305: dp_f4_main(f,v,&ord,rp);
1.22 noro 1306: }
1307:
1308: /* dp_gr_checklist(list of dp) */
1309:
1310: void Pdp_gr_checklist(arg,rp)
1311: NODE arg;
1312: LIST *rp;
1313: {
1314: VECT g;
1315: LIST dp;
1316: NODE r;
1.23 noro 1317: int n;
1.22 noro 1318:
1319: do_weyl = 0;
1320: asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
1.23 noro 1321: asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
1322: n = QTOS((Q)ARG1(arg));
1323: gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
1.22 noro 1324: r = mknode(2,g,dp);
1325: MKLIST(*rp,r);
1.1 noro 1326: }
1327:
1.8 noro 1328: void Pdp_f4_mod_main(arg,rp)
1329: NODE arg;
1330: LIST *rp;
1.1 noro 1331: {
1.8 noro 1332: LIST f,v;
1333: int m;
1334: struct order_spec ord;
1335:
1.11 noro 1336: do_weyl = 0;
1.17 noro 1337: asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
1338: asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
1339: asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
1.8 noro 1340: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 ! noro 1341: f = remove_zero_from_list(f);
! 1342: if ( !BDY(f) ) {
! 1343: *rp = f; return;
! 1344: }
1.20 noro 1345: if ( !m )
1346: error("dp_f4_mod_main : invalid argument");
1.8 noro 1347: create_order_spec(ARG3(arg),&ord);
1348: dp_f4_mod_main(f,v,m,&ord,rp);
1349: }
1.1 noro 1350:
1.8 noro 1351: void Pdp_gr_mod_main(arg,rp)
1352: NODE arg;
1353: LIST *rp;
1354: {
1355: LIST f,v;
1356: Num homo;
1357: int m;
1358: struct order_spec ord;
1359:
1.11 noro 1360: do_weyl = 0;
1.8 noro 1361: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
1362: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
1363: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
1364: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1.11 noro 1365: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 ! noro 1366: f = remove_zero_from_list(f);
! 1367: if ( !BDY(f) ) {
! 1368: *rp = f; return;
! 1369: }
1.11 noro 1370: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1371: if ( !m )
1372: error("dp_gr_mod_main : invalid argument");
1.11 noro 1373: create_order_spec(ARG4(arg),&ord);
1374: dp_gr_mod_main(f,v,homo,m,&ord,rp);
1375: }
1376:
1377: /* for Weyl algebra */
1378:
1379: void Pdp_weyl_gr_main(arg,rp)
1380: NODE arg;
1381: LIST *rp;
1382: {
1383: LIST f,v;
1384: Num homo;
1385: Q m;
1386: int modular;
1387: struct order_spec ord;
1388:
1389: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1390: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1391: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1392: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1393: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 ! noro 1394: f = remove_zero_from_list(f);
! 1395: if ( !BDY(f) ) {
! 1396: *rp = f; return;
! 1397: }
1.11 noro 1398: homo = (Num)ARG2(arg);
1399: m = (Q)ARG3(arg);
1400: if ( !m )
1401: modular = 0;
1402: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1403: error("dp_gr_main : too large modulus");
1404: else
1405: modular = QTOS(m);
1406: create_order_spec(ARG4(arg),&ord);
1.12 noro 1407: do_weyl = 1;
1.16 noro 1408: dp_gr_main(f,v,homo,modular,0,&ord,rp);
1409: do_weyl = 0;
1410: }
1411:
1412: void Pdp_weyl_gr_f_main(arg,rp)
1413: NODE arg;
1414: LIST *rp;
1415: {
1416: LIST f,v;
1417: Num homo;
1418: struct order_spec ord;
1419:
1420: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1421: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1422: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1423: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1424: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 ! noro 1425: f = remove_zero_from_list(f);
! 1426: if ( !BDY(f) ) {
! 1427: *rp = f; return;
! 1428: }
1.16 noro 1429: homo = (Num)ARG2(arg);
1430: create_order_spec(ARG3(arg),&ord);
1431: do_weyl = 1;
1432: dp_gr_main(f,v,homo,0,1,&ord,rp);
1.12 noro 1433: do_weyl = 0;
1.11 noro 1434: }
1435:
1436: void Pdp_weyl_f4_main(arg,rp)
1437: NODE arg;
1438: LIST *rp;
1439: {
1440: LIST f,v;
1441: struct order_spec ord;
1442:
1443: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1444: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1445: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 ! noro 1446: f = remove_zero_from_list(f);
! 1447: if ( !BDY(f) ) {
! 1448: *rp = f; return;
! 1449: }
1.11 noro 1450: create_order_spec(ARG2(arg),&ord);
1.12 noro 1451: do_weyl = 1;
1.17 noro 1452: dp_f4_main(f,v,&ord,rp);
1.12 noro 1453: do_weyl = 0;
1.11 noro 1454: }
1455:
1456: void Pdp_weyl_f4_mod_main(arg,rp)
1457: NODE arg;
1458: LIST *rp;
1459: {
1460: LIST f,v;
1461: int m;
1462: struct order_spec ord;
1463:
1464: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1465: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1466: asir_assert(ARG2(arg),O_N,"dp_f4_main");
1467: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 ! noro 1468: f = remove_zero_from_list(f);
! 1469: if ( !BDY(f) ) {
! 1470: *rp = f; return;
! 1471: }
1.20 noro 1472: if ( !m )
1473: error("dp_weyl_f4_mod_main : invalid argument");
1.11 noro 1474: create_order_spec(ARG3(arg),&ord);
1.12 noro 1475: do_weyl = 1;
1.11 noro 1476: dp_f4_mod_main(f,v,m,&ord,rp);
1.12 noro 1477: do_weyl = 0;
1.11 noro 1478: }
1479:
1480: void Pdp_weyl_gr_mod_main(arg,rp)
1481: NODE arg;
1482: LIST *rp;
1483: {
1484: LIST f,v;
1485: Num homo;
1486: int m;
1487: struct order_spec ord;
1488:
1489: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
1490: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
1491: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
1492: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
1.8 noro 1493: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 ! noro 1494: f = remove_zero_from_list(f);
! 1495: if ( !BDY(f) ) {
! 1496: *rp = f; return;
! 1497: }
1.8 noro 1498: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1499: if ( !m )
1500: error("dp_weyl_gr_mod_main : invalid argument");
1.8 noro 1501: create_order_spec(ARG4(arg),&ord);
1.12 noro 1502: do_weyl = 1;
1.8 noro 1503: dp_gr_mod_main(f,v,homo,m,&ord,rp);
1.12 noro 1504: do_weyl = 0;
1.1 noro 1505: }
1.8 noro 1506:
1.24 noro 1507: static VECT current_dl_weight_vector_obj;
1508: int *current_dl_weight_vector;
1509:
1510: void Pdp_set_weight(arg,rp)
1511: NODE arg;
1512: VECT *rp;
1513: {
1514: VECT v;
1515: int i,n;
1516:
1517: if ( !arg )
1518: *rp = current_dl_weight_vector_obj;
1519: else if ( !ARG0(arg) ) {
1520: current_dl_weight_vector_obj = 0;
1521: current_dl_weight_vector = 0;
1522: *rp = 0;
1523: } else {
1524: asir_assert(ARG0(arg),O_VECT,"dp_set_weight");
1525: v = (VECT)ARG0(arg);
1526: current_dl_weight_vector_obj = v;
1527: n = v->len;
1528: current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
1529: for ( i = 0; i < n; i++ )
1530: current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
1531: *rp = v;
1532: }
1533: }
1534:
1535: static VECT current_weyl_weight_vector_obj;
1536: int *current_weyl_weight_vector;
1.15 noro 1537:
1538: void Pdp_weyl_set_weight(arg,rp)
1539: NODE arg;
1540: VECT *rp;
1541: {
1542: VECT v;
1543: int i,n;
1544:
1545: if ( !arg )
1.24 noro 1546: *rp = current_weyl_weight_vector_obj;
1.15 noro 1547: else {
1548: asir_assert(ARG0(arg),O_VECT,"dp_weyl_set_weight");
1549: v = (VECT)ARG0(arg);
1.24 noro 1550: current_weyl_weight_vector_obj = v;
1.15 noro 1551: n = v->len;
1.24 noro 1552: current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
1.15 noro 1553: for ( i = 0; i < n; i++ )
1.24 noro 1554: current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
1.15 noro 1555: *rp = v;
1556: }
1.25 ! noro 1557: }
! 1558:
! 1559: LIST remove_zero_from_list(LIST l)
! 1560: {
! 1561: NODE n,r0,r;
! 1562: LIST rl;
! 1563:
! 1564: asir_assert(l,O_LIST,"remove_zero_from_list");
! 1565: n = BDY(l);
! 1566: for ( r0 = 0; n; n = NEXT(n) )
! 1567: if ( BDY(n) ) {
! 1568: NEXTNODE(r0,r);
! 1569: BDY(r) = BDY(n);
! 1570: }
! 1571: if ( r0 )
! 1572: NEXT(r) = 0;
! 1573: MKLIST(rl,r0);
! 1574: return rl;
1.15 noro 1575: }
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