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