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