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