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