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