Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.47
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.47 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.46 2004/02/03 23:31:57 noro Exp $
1.5 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "base.h"
52: #include "parse.h"
53:
1.8 noro 54: extern int dp_nelim;
55: extern int dp_order_pair_length;
56: extern struct order_pair *dp_order_pair;
1.46 noro 57: extern struct order_spec *dp_current_spec;
1.8 noro 58:
1.11 noro 59: int do_weyl;
1.1 noro 60:
1.44 noro 61: void Pdp_sort();
1.32 noro 62: void Pdp_mul_trunc(),Pdp_quo();
1.1 noro 63: void Pdp_ord(), Pdp_ptod(), Pdp_dtop();
64: void Pdp_ptozp(), Pdp_ptozp2(), Pdp_red(), Pdp_red2(), Pdp_lcm(), Pdp_redble();
65: void Pdp_sp(), Pdp_hm(), Pdp_ht(), Pdp_hc(), Pdp_rest(), Pdp_td(), Pdp_sugar();
1.30 ohara 66: void Pdp_set_sugar();
1.1 noro 67: void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv();
68: void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat();
1.9 noro 69: void Pdp_nf(),Pdp_true_nf();
1.1 noro 70: void Pdp_nf_mod(),Pdp_true_nf_mod();
71: void Pdp_criB(),Pdp_nelim();
1.9 noro 72: void Pdp_minp(),Pdp_sp_mod();
1.1 noro 73: void Pdp_homo(),Pdp_dehomo();
1.16 noro 74: void Pdp_gr_mod_main(),Pdp_gr_f_main();
1.1 noro 75: void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags();
1.16 noro 76: void Pdp_f4_main(),Pdp_f4_mod_main(),Pdp_f4_f_main();
1.1 noro 77: void Pdp_gr_print();
1.28 noro 78: void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_mdtod(), Pdp_nf_tab_f();
1.8 noro 79: void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
80: void Pdp_cont();
1.22 noro 81: void Pdp_gr_checklist();
1.1 noro 82:
1.13 noro 83: void Pdp_weyl_red();
84: void Pdp_weyl_sp();
85: void Pdp_weyl_nf(),Pdp_weyl_nf_mod();
1.16 noro 86: void Pdp_weyl_gr_main(),Pdp_weyl_gr_mod_main(),Pdp_weyl_gr_f_main();
87: void Pdp_weyl_f4_main(),Pdp_weyl_f4_mod_main(),Pdp_weyl_f4_f_main();
1.13 noro 88: void Pdp_weyl_mul(),Pdp_weyl_mul_mod();
1.15 noro 89: void Pdp_weyl_set_weight();
1.24 noro 90: void Pdp_set_weight();
1.16 noro 91: void Pdp_nf_f(),Pdp_weyl_nf_f();
92: void Pdp_lnf_f();
1.40 noro 93: void Pnd_gr(),Pnd_gr_trace(),Pnd_f4();
1.38 noro 94: void Pnd_weyl_gr(),Pnd_weyl_gr_trace();
1.39 noro 95: void Pnd_nf();
1.11 noro 96:
1.25 noro 97: LIST remove_zero_from_list(LIST);
98:
1.1 noro 99: struct ftab dp_tab[] = {
1.8 noro 100: /* content reduction */
1.1 noro 101: {"dp_ptozp",Pdp_ptozp,1},
102: {"dp_ptozp2",Pdp_ptozp2,2},
103: {"dp_prim",Pdp_prim,1},
1.8 noro 104: {"dp_red_coef",Pdp_red_coef,2},
105: {"dp_cont",Pdp_cont,1},
106:
1.11 noro 107: /* polynomial ring */
1.32 noro 108: /* special operations */
109: {"dp_mul_trunc",Pdp_mul_trunc,3},
110: {"dp_quo",Pdp_quo,2},
111:
1.8 noro 112: /* s-poly */
113: {"dp_sp",Pdp_sp,2},
114: {"dp_sp_mod",Pdp_sp_mod,3},
115:
116: /* m-reduction */
1.1 noro 117: {"dp_red",Pdp_red,3},
118: {"dp_red_mod",Pdp_red_mod,4},
1.8 noro 119:
120: /* normal form */
1.1 noro 121: {"dp_nf",Pdp_nf,4},
1.16 noro 122: {"dp_nf_f",Pdp_nf_f,4},
1.1 noro 123: {"dp_true_nf",Pdp_true_nf,4},
124: {"dp_nf_mod",Pdp_nf_mod,5},
125: {"dp_true_nf_mod",Pdp_true_nf_mod,5},
1.8 noro 126: {"dp_lnf_mod",Pdp_lnf_mod,3},
1.28 noro 127: {"dp_nf_tab_f",Pdp_nf_tab_f,2},
1.8 noro 128: {"dp_nf_tab_mod",Pdp_nf_tab_mod,3},
1.16 noro 129: {"dp_lnf_f",Pdp_lnf_f,2},
1.8 noro 130:
131: /* Buchberger algorithm */
1.46 noro 132: {"dp_gr_main",Pdp_gr_main,-5},
1.1 noro 133: {"dp_gr_mod_main",Pdp_gr_mod_main,5},
1.27 noro 134: {"dp_gr_f_main",Pdp_gr_f_main,4},
1.23 noro 135: {"dp_gr_checklist",Pdp_gr_checklist,2},
1.40 noro 136: {"nd_f4",Pnd_f4,4},
1.33 noro 137: {"nd_gr",Pnd_gr,4},
1.36 noro 138: {"nd_gr_trace",Pnd_gr_trace,5},
1.38 noro 139: {"nd_weyl_gr",Pnd_weyl_gr,4},
140: {"nd_weyl_gr_trace",Pnd_weyl_gr_trace,5},
1.39 noro 141: {"nd_nf",Pnd_nf,5},
1.8 noro 142:
143: /* F4 algorithm */
1.1 noro 144: {"dp_f4_main",Pdp_f4_main,3},
145: {"dp_f4_mod_main",Pdp_f4_mod_main,4},
1.8 noro 146:
1.11 noro 147: /* weyl algebra */
1.12 noro 148: /* multiplication */
149: {"dp_weyl_mul",Pdp_weyl_mul,2},
1.13 noro 150: {"dp_weyl_mul_mod",Pdp_weyl_mul_mod,3},
1.12 noro 151:
1.11 noro 152: /* s-poly */
153: {"dp_weyl_sp",Pdp_weyl_sp,2},
154:
155: /* m-reduction */
156: {"dp_weyl_red",Pdp_weyl_red,3},
157:
158: /* normal form */
159: {"dp_weyl_nf",Pdp_weyl_nf,4},
1.13 noro 160: {"dp_weyl_nf_mod",Pdp_weyl_nf_mod,5},
1.16 noro 161: {"dp_weyl_nf_f",Pdp_weyl_nf_f,4},
1.11 noro 162:
163: /* Buchberger algorithm */
164: {"dp_weyl_gr_main",Pdp_weyl_gr_main,5},
165: {"dp_weyl_gr_mod_main",Pdp_weyl_gr_mod_main,5},
1.16 noro 166: {"dp_weyl_gr_f_main",Pdp_weyl_gr_f_main,4},
1.11 noro 167:
168: /* F4 algorithm */
169: {"dp_weyl_f4_main",Pdp_weyl_f4_main,3},
1.19 noro 170: {"dp_weyl_f4_mod_main",Pdp_weyl_f4_mod_main,4},
1.11 noro 171:
1.15 noro 172: /* misc */
1.24 noro 173: {"dp_set_weight",Pdp_set_weight,-1},
1.15 noro 174: {"dp_weyl_set_weight",Pdp_weyl_set_weight,-1},
1.8 noro 175: {0,0,0},
176: };
177:
178: struct ftab dp_supp_tab[] = {
179: /* setting flags */
1.44 noro 180: {"dp_sort",Pdp_sort,1},
1.8 noro 181: {"dp_ord",Pdp_ord,-1},
182: {"dp_set_kara",Pdp_set_kara,-1},
183: {"dp_nelim",Pdp_nelim,-1},
1.1 noro 184: {"dp_gr_flags",Pdp_gr_flags,-1},
185: {"dp_gr_print",Pdp_gr_print,-1},
1.8 noro 186:
187: /* converters */
188: {"dp_ptod",Pdp_ptod,2},
189: {"dp_dtop",Pdp_dtop,2},
190: {"dp_homo",Pdp_homo,1},
191: {"dp_dehomo",Pdp_dehomo,1},
192: {"dp_etov",Pdp_etov,1},
193: {"dp_vtoe",Pdp_vtoe,1},
194: {"dp_dtov",Pdp_dtov,1},
195: {"dp_mdtod",Pdp_mdtod,1},
196: {"dp_mod",Pdp_mod,3},
197: {"dp_rat",Pdp_rat,1},
198:
199: /* criteria */
200: {"dp_cri1",Pdp_cri1,2},
201: {"dp_cri2",Pdp_cri2,2},
202: {"dp_criB",Pdp_criB,3},
203:
204: /* simple operation */
205: {"dp_subd",Pdp_subd,2},
206: {"dp_lcm",Pdp_lcm,2},
207: {"dp_hm",Pdp_hm,1},
208: {"dp_ht",Pdp_ht,1},
209: {"dp_hc",Pdp_hc,1},
210: {"dp_rest",Pdp_rest,1},
211:
212: /* degree and size */
213: {"dp_td",Pdp_td,1},
214: {"dp_mag",Pdp_mag,1},
215: {"dp_sugar",Pdp_sugar,1},
1.30 ohara 216: {"dp_set_sugar",Pdp_set_sugar,2},
1.8 noro 217:
218: /* misc */
219: {"dp_mbase",Pdp_mbase,1},
220: {"dp_redble",Pdp_redble,2},
221: {"dp_sep",Pdp_sep,2},
222: {"dp_idiv",Pdp_idiv,2},
223: {"dp_tdiv",Pdp_tdiv,2},
224: {"dp_minp",Pdp_minp,2},
225:
226: {0,0,0}
1.1 noro 227: };
1.44 noro 228:
229: void Pdp_sort(arg,rp)
230: NODE arg;
231: DP *rp;
232: {
233: dp_sort((DP)ARG0(arg),rp);
234: }
1.1 noro 235:
1.8 noro 236: void Pdp_mdtod(arg,rp)
237: NODE arg;
238: DP *rp;
239: {
240: MP m,mr,mr0;
241: DP p;
242: P t;
243:
244: p = (DP)ARG0(arg);
245: if ( !p )
246: *rp = 0;
247: else {
248: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
249: mptop(m->c,&t); NEXTMP(mr0,mr); mr->c = t; mr->dl = m->dl;
250: }
251: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
252: }
253: }
254:
255: void Pdp_sep(arg,rp)
256: NODE arg;
257: VECT *rp;
258: {
259: DP p,r;
260: MP m,t;
261: MP *w0,*w;
262: int i,n,d,nv,sugar;
263: VECT v;
264: pointer *pv;
265:
266: p = (DP)ARG0(arg); m = BDY(p);
267: d = QTOS((Q)ARG1(arg));
268: for ( t = m, n = 0; t; t = NEXT(t), n++ );
269: if ( d > n )
270: d = n;
271: MKVECT(v,d); *rp = v;
272: pv = BDY(v); nv = p->nv; sugar = p->sugar;
273: w0 = (MP *)MALLOC(d*sizeof(MP)); bzero(w0,d*sizeof(MP));
274: w = (MP *)MALLOC(d*sizeof(MP)); bzero(w,d*sizeof(MP));
275: for ( t = BDY(p), i = 0; t; t = NEXT(t), i++, i %= d ) {
276: NEXTMP(w0[i],w[i]); w[i]->c = t->c; w[i]->dl = t->dl;
277: }
278: for ( i = 0; i < d; i++ ) {
279: NEXT(w[i]) = 0; MKDP(nv,w0[i],r); r->sugar = sugar;
280: pv[i] = (pointer)r;
281: }
282: }
283:
284: void Pdp_idiv(arg,rp)
285: NODE arg;
286: DP *rp;
287: {
288: dp_idiv((DP)ARG0(arg),(Q)ARG1(arg),rp);
289: }
290:
291: void Pdp_cont(arg,rp)
292: NODE arg;
293: Q *rp;
294: {
295: dp_cont((DP)ARG0(arg),rp);
296: }
297:
298: void Pdp_dtov(arg,rp)
299: NODE arg;
300: VECT *rp;
301: {
302: dp_dtov((DP)ARG0(arg),rp);
303: }
304:
305: void Pdp_mbase(arg,rp)
306: NODE arg;
307: LIST *rp;
308: {
309: NODE mb;
310:
311: asir_assert(ARG0(arg),O_LIST,"dp_mbase");
312: dp_mbase(BDY((LIST)ARG0(arg)),&mb);
313: MKLIST(*rp,mb);
314: }
315:
316: void Pdp_etov(arg,rp)
317: NODE arg;
318: VECT *rp;
319: {
320: DP dp;
321: int n,i;
322: int *d;
323: VECT v;
324: Q t;
325:
326: dp = (DP)ARG0(arg);
327: asir_assert(dp,O_DP,"dp_etov");
328: n = dp->nv; d = BDY(dp)->dl->d;
329: MKVECT(v,n);
330: for ( i = 0; i < n; i++ ) {
331: STOQ(d[i],t); v->body[i] = (pointer)t;
332: }
333: *rp = v;
334: }
335:
336: void Pdp_vtoe(arg,rp)
337: NODE arg;
338: DP *rp;
339: {
340: DP dp;
341: DL dl;
342: MP m;
343: int n,i,td;
344: int *d;
345: VECT v;
346:
347: v = (VECT)ARG0(arg);
348: asir_assert(v,O_VECT,"dp_vtoe");
349: n = v->len;
350: NEWDL(dl,n); d = dl->d;
351: for ( i = 0, td = 0; i < n; i++ ) {
1.24 noro 352: d[i] = QTOS((Q)(v->body[i])); td += MUL_WEIGHT(d[i],i);
1.8 noro 353: }
354: dl->td = td;
355: NEWMP(m); m->dl = dl; m->c = (P)ONE; NEXT(m) = 0;
356: MKDP(n,m,dp); dp->sugar = td;
357: *rp = dp;
358: }
359:
360: void Pdp_lnf_mod(arg,rp)
361: NODE arg;
362: LIST *rp;
363: {
364: DP r1,r2;
365: NODE b,g,n;
366: int mod;
367:
368: asir_assert(ARG0(arg),O_LIST,"dp_lnf_mod");
369: asir_assert(ARG1(arg),O_LIST,"dp_lnf_mod");
370: asir_assert(ARG2(arg),O_N,"dp_lnf_mod");
371: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
372: mod = QTOS((Q)ARG2(arg));
373: dp_lnf_mod((DP)BDY(b),(DP)BDY(NEXT(b)),g,mod,&r1,&r2);
374: NEWNODE(n); BDY(n) = (pointer)r1;
375: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
376: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
377: }
378:
1.16 noro 379: void Pdp_lnf_f(arg,rp)
380: NODE arg;
381: LIST *rp;
382: {
383: DP r1,r2;
384: NODE b,g,n;
385:
386: asir_assert(ARG0(arg),O_LIST,"dp_lnf_f");
387: asir_assert(ARG1(arg),O_LIST,"dp_lnf_f");
388: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
389: dp_lnf_f((DP)BDY(b),(DP)BDY(NEXT(b)),g,&r1,&r2);
390: NEWNODE(n); BDY(n) = (pointer)r1;
391: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
392: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
393: }
394:
1.8 noro 395: void Pdp_nf_tab_mod(arg,rp)
396: NODE arg;
397: DP *rp;
398: {
399: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_mod");
400: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_mod");
401: asir_assert(ARG2(arg),O_N,"dp_nf_tab_mod");
402: dp_nf_tab_mod((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),
403: QTOS((Q)ARG2(arg)),rp);
1.28 noro 404: }
405:
406: void Pdp_nf_tab_f(arg,rp)
407: NODE arg;
408: DP *rp;
409: {
410: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_f");
411: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_f");
412: dp_nf_tab_f((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),rp);
1.8 noro 413: }
1.1 noro 414:
415: void Pdp_ord(arg,rp)
416: NODE arg;
417: Obj *rp;
418: {
1.46 noro 419: struct order_spec *spec;
1.1 noro 420:
421: if ( !arg )
1.46 noro 422: *rp = dp_current_spec->obj;
423: else if ( !create_order_spec(0,(Obj)ARG0(arg),&spec) )
1.1 noro 424: error("dp_ord : invalid order specification");
425: else {
1.46 noro 426: initd(spec); *rp = spec->obj;
1.1 noro 427: }
428: }
429:
430: void Pdp_ptod(arg,rp)
431: NODE arg;
432: DP *rp;
433: {
434: NODE n;
435: VL vl,tvl;
436:
437: asir_assert(ARG0(arg),O_P,"dp_ptod");
438: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
439: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
440: if ( !vl ) {
441: NEWVL(vl); tvl = vl;
442: } else {
443: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
444: }
445: VR(tvl) = VR((P)BDY(n));
446: }
447: if ( vl )
448: NEXT(tvl) = 0;
449: ptod(CO,vl,(P)ARG0(arg),rp);
450: }
451:
452: void Pdp_dtop(arg,rp)
453: NODE arg;
454: P *rp;
455: {
456: NODE n;
457: VL vl,tvl;
458:
459: asir_assert(ARG0(arg),O_DP,"dp_dtop");
460: asir_assert(ARG1(arg),O_LIST,"dp_dtop");
461: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
462: if ( !vl ) {
463: NEWVL(vl); tvl = vl;
464: } else {
465: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
466: }
467: VR(tvl) = VR((P)BDY(n));
468: }
469: if ( vl )
470: NEXT(tvl) = 0;
471: dtop(CO,vl,(DP)ARG0(arg),rp);
472: }
473:
474: extern LIST Dist;
475:
476: void Pdp_ptozp(arg,rp)
477: NODE arg;
478: DP *rp;
479: {
480: asir_assert(ARG0(arg),O_DP,"dp_ptozp");
1.10 noro 481: dp_ptozp((DP)ARG0(arg),rp);
1.1 noro 482: }
483:
484: void Pdp_ptozp2(arg,rp)
485: NODE arg;
486: LIST *rp;
487: {
488: DP p0,p1,h,r;
489: NODE n0;
490:
491: p0 = (DP)ARG0(arg); p1 = (DP)ARG1(arg);
492: asir_assert(p0,O_DP,"dp_ptozp2");
493: asir_assert(p1,O_DP,"dp_ptozp2");
1.10 noro 494: dp_ptozp2(p0,p1,&h,&r);
1.1 noro 495: NEWNODE(n0); BDY(n0) = (pointer)h;
496: NEWNODE(NEXT(n0)); BDY(NEXT(n0)) = (pointer)r;
497: NEXT(NEXT(n0)) = 0;
498: MKLIST(*rp,n0);
499: }
500:
501: void Pdp_prim(arg,rp)
502: NODE arg;
503: DP *rp;
504: {
505: DP t;
506:
507: asir_assert(ARG0(arg),O_DP,"dp_prim");
508: dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
509: }
510:
511: void Pdp_mod(arg,rp)
512: NODE arg;
513: DP *rp;
514: {
515: DP p;
516: int mod;
517: NODE subst;
518:
519: asir_assert(ARG0(arg),O_DP,"dp_mod");
520: asir_assert(ARG1(arg),O_N,"dp_mod");
521: asir_assert(ARG2(arg),O_LIST,"dp_mod");
522: p = (DP)ARG0(arg); mod = QTOS((Q)ARG1(arg));
523: subst = BDY((LIST)ARG2(arg));
524: dp_mod(p,mod,subst,rp);
525: }
526:
527: void Pdp_rat(arg,rp)
528: NODE arg;
529: DP *rp;
530: {
531: asir_assert(ARG0(arg),O_DP,"dp_rat");
532: dp_rat((DP)ARG0(arg),rp);
533: }
534:
1.9 noro 535: extern int DP_Multiple;
536:
1.1 noro 537: void Pdp_nf(arg,rp)
538: NODE arg;
539: DP *rp;
540: {
541: NODE b;
542: DP *ps;
543: DP g;
544: int full;
545:
1.11 noro 546: do_weyl = 0;
1.1 noro 547: asir_assert(ARG0(arg),O_LIST,"dp_nf");
548: asir_assert(ARG1(arg),O_DP,"dp_nf");
549: asir_assert(ARG2(arg),O_VECT,"dp_nf");
550: asir_assert(ARG3(arg),O_N,"dp_nf");
551: if ( !(g = (DP)ARG1(arg)) ) {
552: *rp = 0; return;
553: }
554: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
555: full = (Q)ARG3(arg) ? 1 : 0;
1.16 noro 556: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
1.1 noro 557: }
558:
1.11 noro 559: void Pdp_weyl_nf(arg,rp)
560: NODE arg;
561: DP *rp;
562: {
563: NODE b;
564: DP *ps;
565: DP g;
566: int full;
567:
568: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf");
569: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf");
570: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf");
571: asir_assert(ARG3(arg),O_N,"dp_weyl_nf");
572: if ( !(g = (DP)ARG1(arg)) ) {
573: *rp = 0; return;
574: }
575: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
576: full = (Q)ARG3(arg) ? 1 : 0;
1.12 noro 577: do_weyl = 1;
1.16 noro 578: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
579: do_weyl = 0;
580: }
581:
582: /* nf computation using field operations */
583:
584: void Pdp_nf_f(arg,rp)
585: NODE arg;
586: DP *rp;
587: {
588: NODE b;
589: DP *ps;
590: DP g;
591: int full;
592:
593: do_weyl = 0;
594: asir_assert(ARG0(arg),O_LIST,"dp_nf_f");
595: asir_assert(ARG1(arg),O_DP,"dp_nf_f");
596: asir_assert(ARG2(arg),O_VECT,"dp_nf_f");
597: asir_assert(ARG3(arg),O_N,"dp_nf_f");
598: if ( !(g = (DP)ARG1(arg)) ) {
599: *rp = 0; return;
600: }
601: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
602: full = (Q)ARG3(arg) ? 1 : 0;
603: dp_nf_f(b,g,ps,full,rp);
604: }
605:
606: void Pdp_weyl_nf_f(arg,rp)
607: NODE arg;
608: DP *rp;
609: {
610: NODE b;
611: DP *ps;
612: DP g;
613: int full;
614:
615: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_f");
616: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_f");
617: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_f");
618: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_f");
619: if ( !(g = (DP)ARG1(arg)) ) {
620: *rp = 0; return;
621: }
622: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
623: full = (Q)ARG3(arg) ? 1 : 0;
624: do_weyl = 1;
625: dp_nf_f(b,g,ps,full,rp);
1.12 noro 626: do_weyl = 0;
1.11 noro 627: }
628:
1.13 noro 629: void Pdp_nf_mod(arg,rp)
630: NODE arg;
631: DP *rp;
632: {
633: NODE b;
634: DP g;
635: DP *ps;
636: int mod,full,ac;
637: NODE n,n0;
638:
1.14 noro 639: do_weyl = 0;
1.13 noro 640: ac = argc(arg);
1.14 noro 641: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
642: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
643: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
644: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
645: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
1.13 noro 646: if ( !(g = (DP)ARG1(arg)) ) {
647: *rp = 0; return;
648: }
649: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
650: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
651: for ( n0 = n = 0; b; b = NEXT(b) ) {
652: NEXTNODE(n0,n);
653: BDY(n) = (pointer)QTOS((Q)BDY(b));
654: }
655: if ( n0 )
656: NEXT(n) = 0;
657: dp_nf_mod(n0,g,ps,mod,full,rp);
658: }
659:
1.1 noro 660: void Pdp_true_nf(arg,rp)
661: NODE arg;
662: LIST *rp;
663: {
664: NODE b,n;
665: DP *ps;
666: DP g;
667: DP nm;
668: P dn;
669: int full;
670:
1.11 noro 671: do_weyl = 0;
1.1 noro 672: asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
673: asir_assert(ARG1(arg),O_DP,"dp_true_nf");
674: asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
675: asir_assert(ARG3(arg),O_N,"dp_nf");
676: if ( !(g = (DP)ARG1(arg)) ) {
677: nm = 0; dn = (P)ONE;
678: } else {
679: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
680: full = (Q)ARG3(arg) ? 1 : 0;
681: dp_true_nf(b,g,ps,full,&nm,&dn);
682: }
683: NEWNODE(n); BDY(n) = (pointer)nm;
684: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
685: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
686: }
687:
1.13 noro 688: void Pdp_weyl_nf_mod(arg,rp)
1.8 noro 689: NODE arg;
690: DP *rp;
691: {
692: NODE b;
693: DP g;
694: DP *ps;
695: int mod,full,ac;
1.9 noro 696: NODE n,n0;
1.8 noro 697:
698: ac = argc(arg);
1.14 noro 699: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_mod");
700: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_mod");
701: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_mod");
702: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_mod");
703: asir_assert(ARG4(arg),O_N,"dp_weyl_nf_mod");
1.8 noro 704: if ( !(g = (DP)ARG1(arg)) ) {
705: *rp = 0; return;
706: }
707: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
708: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
1.9 noro 709: for ( n0 = n = 0; b; b = NEXT(b) ) {
710: NEXTNODE(n0,n);
711: BDY(n) = (pointer)QTOS((Q)BDY(b));
712: }
713: if ( n0 )
714: NEXT(n) = 0;
1.13 noro 715: do_weyl = 1;
716: dp_nf_mod(n0,g,ps,mod,full,rp);
717: do_weyl = 0;
1.8 noro 718: }
719:
720: void Pdp_true_nf_mod(arg,rp)
721: NODE arg;
722: LIST *rp;
723: {
724: NODE b;
725: DP g,nm;
726: P dn;
727: DP *ps;
728: int mod,full;
729: NODE n;
730:
1.11 noro 731: do_weyl = 0;
1.8 noro 732: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
733: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
734: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
735: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
736: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
737: if ( !(g = (DP)ARG1(arg)) ) {
738: nm = 0; dn = (P)ONEM;
739: } else {
740: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
741: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
742: dp_true_nf_mod(b,g,ps,mod,full,&nm,&dn);
743: }
744: NEWNODE(n); BDY(n) = (pointer)nm;
745: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
746: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.1 noro 747: }
748:
749: void Pdp_tdiv(arg,rp)
750: NODE arg;
751: DP *rp;
752: {
753: MP m,mr,mr0;
754: DP p;
755: Q c;
756: N d,q,r;
757: int sgn;
758:
759: asir_assert(ARG0(arg),O_DP,"dp_tdiv");
760: asir_assert(ARG1(arg),O_N,"dp_tdiv");
761: p = (DP)ARG0(arg); d = NM((Q)ARG1(arg)); sgn = SGN((Q)ARG1(arg));
762: if ( !p )
763: *rp = 0;
764: else {
765: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
766: divn(NM((Q)m->c),d,&q,&r);
767: if ( r ) {
768: *rp = 0; return;
769: } else {
770: NEXTMP(mr0,mr); NTOQ(q,SGN((Q)m->c)*sgn,c);
771: mr->c = (P)c; mr->dl = m->dl;
772: }
773: }
774: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
775: }
776: }
777:
778: void Pdp_red_coef(arg,rp)
779: NODE arg;
780: DP *rp;
781: {
782: MP m,mr,mr0;
783: P q,r;
784: DP p;
785: P mod;
786:
787: p = (DP)ARG0(arg); mod = (P)ARG1(arg);
788: asir_assert(p,O_DP,"dp_red_coef");
789: asir_assert(mod,O_P,"dp_red_coef");
790: if ( !p )
791: *rp = 0;
792: else {
793: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
794: divsrp(CO,m->c,mod,&q,&r);
795: if ( r ) {
796: NEXTMP(mr0,mr); mr->c = r; mr->dl = m->dl;
797: }
798: }
799: if ( mr0 ) {
800: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
801: } else
802: *rp = 0;
803: }
804: }
805:
806: void Pdp_redble(arg,rp)
807: NODE arg;
808: Q *rp;
809: {
810: asir_assert(ARG0(arg),O_DP,"dp_redble");
811: asir_assert(ARG1(arg),O_DP,"dp_redble");
812: if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
813: *rp = ONE;
814: else
815: *rp = 0;
816: }
817:
818: void Pdp_red_mod(arg,rp)
819: NODE arg;
820: LIST *rp;
821: {
822: DP h,r;
823: P dmy;
824: NODE n;
825:
1.11 noro 826: do_weyl = 0;
1.1 noro 827: asir_assert(ARG0(arg),O_DP,"dp_red_mod");
828: asir_assert(ARG1(arg),O_DP,"dp_red_mod");
829: asir_assert(ARG2(arg),O_DP,"dp_red_mod");
830: asir_assert(ARG3(arg),O_N,"dp_red_mod");
831: dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),QTOS((Q)ARG3(arg)),
832: &h,&r,&dmy);
833: NEWNODE(n); BDY(n) = (pointer)h;
834: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
835: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
836: }
1.13 noro 837:
1.1 noro 838: void Pdp_subd(arg,rp)
839: NODE arg;
840: DP *rp;
841: {
842: DP p1,p2;
843:
844: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
845: asir_assert(p1,O_DP,"dp_subd");
846: asir_assert(p2,O_DP,"dp_subd");
847: dp_subd(p1,p2,rp);
848: }
849:
1.32 noro 850: void Pdp_mul_trunc(arg,rp)
851: NODE arg;
852: DP *rp;
853: {
854: DP p1,p2,p;
855:
856: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); p = (DP)ARG2(arg);
857: asir_assert(p1,O_DP,"dp_mul_trunc");
858: asir_assert(p2,O_DP,"dp_mul_trunc");
859: asir_assert(p,O_DP,"dp_mul_trunc");
860: comm_muld_trunc(CO,p1,p2,BDY(p)->dl,rp);
861: }
862:
863: void Pdp_quo(arg,rp)
864: NODE arg;
865: DP *rp;
866: {
867: DP p1,p2;
868:
869: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
870: asir_assert(p1,O_DP,"dp_quo");
871: asir_assert(p2,O_DP,"dp_quo");
872: comm_quod(CO,p1,p2,rp);
873: }
874:
1.12 noro 875: void Pdp_weyl_mul(arg,rp)
876: NODE arg;
877: DP *rp;
878: {
879: DP p1,p2;
880:
881: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1.32 noro 882: asir_assert(p1,O_DP,"dp_weyl_mul"); asir_assert(p2,O_DP,"dp_weyl_mul");
1.12 noro 883: do_weyl = 1;
884: muld(CO,p1,p2,rp);
1.13 noro 885: do_weyl = 0;
886: }
887:
888: void Pdp_weyl_mul_mod(arg,rp)
889: NODE arg;
890: DP *rp;
891: {
892: DP p1,p2;
893: Q m;
894:
895: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); m = (Q)ARG2(arg);
896: asir_assert(p1,O_DP,"dp_weyl_mul_mod");
897: asir_assert(p2,O_DP,"dp_mul_mod");
898: asir_assert(m,O_N,"dp_mul_mod");
899: do_weyl = 1;
900: mulmd(CO,QTOS(m),p1,p2,rp);
1.12 noro 901: do_weyl = 0;
902: }
903:
1.1 noro 904: void Pdp_red(arg,rp)
905: NODE arg;
906: LIST *rp;
907: {
908: NODE n;
1.4 noro 909: DP head,rest,dmy1;
1.1 noro 910: P dmy;
911:
1.11 noro 912: do_weyl = 0;
1.1 noro 913: asir_assert(ARG0(arg),O_DP,"dp_red");
914: asir_assert(ARG1(arg),O_DP,"dp_red");
915: asir_assert(ARG2(arg),O_DP,"dp_red");
1.4 noro 916: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.1 noro 917: NEWNODE(n); BDY(n) = (pointer)head;
918: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
919: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
920: }
921:
1.11 noro 922: void Pdp_weyl_red(arg,rp)
923: NODE arg;
924: LIST *rp;
925: {
926: NODE n;
927: DP head,rest,dmy1;
928: P dmy;
929:
930: asir_assert(ARG0(arg),O_DP,"dp_weyl_red");
931: asir_assert(ARG1(arg),O_DP,"dp_weyl_red");
932: asir_assert(ARG2(arg),O_DP,"dp_weyl_red");
1.12 noro 933: do_weyl = 1;
1.11 noro 934: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.12 noro 935: do_weyl = 0;
1.11 noro 936: NEWNODE(n); BDY(n) = (pointer)head;
937: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
938: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
939: }
940:
1.1 noro 941: void Pdp_sp(arg,rp)
942: NODE arg;
943: DP *rp;
944: {
945: DP p1,p2;
946:
1.11 noro 947: do_weyl = 0;
1.1 noro 948: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
949: asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
950: dp_sp(p1,p2,rp);
951: }
952:
1.11 noro 953: void Pdp_weyl_sp(arg,rp)
954: NODE arg;
955: DP *rp;
956: {
957: DP p1,p2;
958:
959: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
960: asir_assert(p1,O_DP,"dp_weyl_sp"); asir_assert(p2,O_DP,"dp_sp");
1.12 noro 961: do_weyl = 1;
1.11 noro 962: dp_sp(p1,p2,rp);
1.12 noro 963: do_weyl = 0;
1.11 noro 964: }
965:
1.1 noro 966: void Pdp_sp_mod(arg,rp)
967: NODE arg;
968: DP *rp;
969: {
970: DP p1,p2;
971: int mod;
972:
1.11 noro 973: do_weyl = 0;
1.1 noro 974: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
975: asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
976: asir_assert(ARG2(arg),O_N,"dp_sp_mod");
977: mod = QTOS((Q)ARG2(arg));
978: dp_sp_mod(p1,p2,mod,rp);
979: }
980:
981: void Pdp_lcm(arg,rp)
982: NODE arg;
983: DP *rp;
984: {
985: int i,n,td;
986: DL d1,d2,d;
987: MP m;
988: DP p1,p2;
989:
990: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
991: asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
992: n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
993: NEWDL(d,n);
994: for ( i = 0, td = 0; i < n; i++ ) {
1.24 noro 995: d->d[i] = MAX(d1->d[i],d2->d[i]); td += MUL_WEIGHT(d->d[i],i);
1.1 noro 996: }
997: d->td = td;
998: NEWMP(m); m->dl = d; m->c = (P)ONE; NEXT(m) = 0;
999: MKDP(n,m,*rp); (*rp)->sugar = td; /* XXX */
1000: }
1001:
1002: void Pdp_hm(arg,rp)
1003: NODE arg;
1004: DP *rp;
1005: {
1006: DP p;
1007:
1008: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
1009: dp_hm(p,rp);
1010: }
1011:
1012: void Pdp_ht(arg,rp)
1013: NODE arg;
1014: DP *rp;
1015: {
1016: DP p;
1017: MP m,mr;
1018:
1019: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
1020: if ( !p )
1021: *rp = 0;
1022: else {
1023: m = BDY(p);
1024: NEWMP(mr); mr->dl = m->dl; mr->c = (P)ONE; NEXT(mr) = 0;
1025: MKDP(p->nv,mr,*rp); (*rp)->sugar = mr->dl->td; /* XXX */
1026: }
1027: }
1028:
1029: void Pdp_hc(arg,rp)
1030: NODE arg;
1031: P *rp;
1032: {
1033: asir_assert(ARG0(arg),O_DP,"dp_hc");
1034: if ( !ARG0(arg) )
1035: *rp = 0;
1036: else
1037: *rp = BDY((DP)ARG0(arg))->c;
1038: }
1039:
1040: void Pdp_rest(arg,rp)
1041: NODE arg;
1042: DP *rp;
1043: {
1044: asir_assert(ARG0(arg),O_DP,"dp_rest");
1045: if ( !ARG0(arg) )
1046: *rp = 0;
1047: else
1048: dp_rest((DP)ARG0(arg),rp);
1049: }
1050:
1051: void Pdp_td(arg,rp)
1052: NODE arg;
1053: Q *rp;
1054: {
1055: DP p;
1056:
1057: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
1058: if ( !p )
1059: *rp = 0;
1060: else
1061: STOQ(BDY(p)->dl->td,*rp);
1062: }
1063:
1064: void Pdp_sugar(arg,rp)
1065: NODE arg;
1066: Q *rp;
1067: {
1068: DP p;
1069:
1070: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
1071: if ( !p )
1072: *rp = 0;
1073: else
1074: STOQ(p->sugar,*rp);
1.30 ohara 1075: }
1076:
1077: void Pdp_set_sugar(arg,rp)
1078: NODE arg;
1079: Q *rp;
1080: {
1081: DP p;
1082: Q q;
1083: int i;
1084:
1085: p = (DP)ARG0(arg);
1086: q = (Q)ARG1(arg);
1087: if ( p && q) {
1088: asir_assert(p,O_DP,"dp_set_sugar");
1089: asir_assert(q,O_N, "dp_set_sugar");
1090: i = QTOS(q);
1091: if (p->sugar < i) {
1092: p->sugar = i;
1093: }
1094: }
1095: *rp = 0;
1.1 noro 1096: }
1097:
1098: void Pdp_cri1(arg,rp)
1099: NODE arg;
1100: Q *rp;
1101: {
1102: DP p1,p2;
1103: int *d1,*d2;
1104: int i,n;
1105:
1106: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1107: asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
1108: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
1109: for ( i = 0; i < n; i++ )
1110: if ( d1[i] > d2[i] )
1111: break;
1112: *rp = i == n ? ONE : 0;
1113: }
1114:
1115: void Pdp_cri2(arg,rp)
1116: NODE arg;
1117: Q *rp;
1118: {
1119: DP p1,p2;
1120: int *d1,*d2;
1121: int i,n;
1122:
1123: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1124: asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
1125: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
1126: for ( i = 0; i < n; i++ )
1127: if ( MIN(d1[i],d2[i]) >= 1 )
1128: break;
1129: *rp = i == n ? ONE : 0;
1130: }
1131:
1132: void Pdp_minp(arg,rp)
1133: NODE arg;
1134: LIST *rp;
1135: {
1136: NODE tn,tn1,d,dd,dd0,p,tp;
1137: LIST l,minp;
1138: DP lcm,tlcm;
1139: int s,ts;
1140:
1141: asir_assert(ARG0(arg),O_LIST,"dp_minp");
1142: d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
1143: p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
1144: if ( !ARG1(arg) ) {
1145: s = QTOS((Q)BDY(p)); p = NEXT(p);
1146: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1147: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1148: tlcm = (DP)BDY(tp); tp = NEXT(tp);
1149: ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
1150: NEXTNODE(dd0,dd);
1151: if ( ts < s ) {
1152: BDY(dd) = (pointer)minp;
1153: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1154: } else if ( ts == s ) {
1155: if ( compd(CO,lcm,tlcm) > 0 ) {
1156: BDY(dd) = (pointer)minp;
1157: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1158: } else
1159: BDY(dd) = BDY(d);
1160: } else
1161: BDY(dd) = BDY(d);
1162: }
1163: } else {
1164: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1165: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1166: tlcm = (DP)BDY(tp);
1167: NEXTNODE(dd0,dd);
1168: if ( compd(CO,lcm,tlcm) > 0 ) {
1169: BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
1170: } else
1171: BDY(dd) = BDY(d);
1172: }
1173: }
1174: if ( dd0 )
1175: NEXT(dd) = 0;
1176: MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
1177: }
1178:
1179: void Pdp_criB(arg,rp)
1180: NODE arg;
1181: LIST *rp;
1182: {
1183: NODE d,ij,dd,ddd;
1184: int i,j,s,n;
1185: DP *ps;
1186: DL ts,ti,tj,lij,tdl;
1187:
1188: asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
1189: asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
1190: asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
1191: if ( !d )
1192: *rp = (LIST)ARG0(arg);
1193: else {
1194: ts = BDY(ps[s])->dl;
1195: n = ps[s]->nv;
1196: NEWDL(tdl,n);
1197: for ( dd = 0; d; d = NEXT(d) ) {
1198: ij = BDY((LIST)BDY(d));
1199: i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1200: j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1201: lij = BDY((DP)BDY(ij))->dl;
1202: ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
1203: if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
1204: || !dl_equal(n,lij,tdl)
1205: || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
1206: && dl_equal(n,tdl,lij))
1207: || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
1208: && dl_equal(n,tdl,lij)) ) {
1209: MKNODE(ddd,BDY(d),dd);
1210: dd = ddd;
1211: }
1212: }
1213: MKLIST(*rp,dd);
1214: }
1215: }
1216:
1217: void Pdp_nelim(arg,rp)
1218: NODE arg;
1219: Q *rp;
1220: {
1221: if ( arg ) {
1222: asir_assert(ARG0(arg),O_N,"dp_nelim");
1223: dp_nelim = QTOS((Q)ARG0(arg));
1224: }
1225: STOQ(dp_nelim,*rp);
1226: }
1227:
1228: void Pdp_mag(arg,rp)
1229: NODE arg;
1230: Q *rp;
1231: {
1232: DP p;
1233: int s;
1234: MP m;
1235:
1236: p = (DP)ARG0(arg);
1237: asir_assert(p,O_DP,"dp_mag");
1238: if ( !p )
1239: *rp = 0;
1240: else {
1241: for ( s = 0, m = BDY(p); m; m = NEXT(m) )
1242: s += p_mag(m->c);
1243: STOQ(s,*rp);
1244: }
1245: }
1246:
1247: extern int kara_mag;
1248:
1249: void Pdp_set_kara(arg,rp)
1250: NODE arg;
1251: Q *rp;
1252: {
1253: if ( arg ) {
1254: asir_assert(ARG0(arg),O_N,"dp_set_kara");
1255: kara_mag = QTOS((Q)ARG0(arg));
1256: }
1257: STOQ(kara_mag,*rp);
1258: }
1259:
1260: void Pdp_homo(arg,rp)
1261: NODE arg;
1262: DP *rp;
1263: {
1264: asir_assert(ARG0(arg),O_DP,"dp_homo");
1265: dp_homo((DP)ARG0(arg),rp);
1266: }
1267:
1.8 noro 1268: void Pdp_dehomo(arg,rp)
1269: NODE arg;
1.1 noro 1270: DP *rp;
1271: {
1.8 noro 1272: asir_assert(ARG0(arg),O_DP,"dp_dehomo");
1273: dp_dehomo((DP)ARG0(arg),rp);
1274: }
1275:
1276: void Pdp_gr_flags(arg,rp)
1277: NODE arg;
1278: LIST *rp;
1279: {
1280: Obj name,value;
1281: NODE n;
1.1 noro 1282:
1.8 noro 1283: if ( arg ) {
1284: asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
1285: n = BDY((LIST)ARG0(arg));
1286: while ( n ) {
1287: name = (Obj)BDY(n); n = NEXT(n);
1288: if ( !n )
1289: break;
1290: else {
1291: value = (Obj)BDY(n); n = NEXT(n);
1292: }
1293: dp_set_flag(name,value);
1.1 noro 1294: }
1295: }
1.8 noro 1296: dp_make_flaglist(rp);
1297: }
1298:
1.29 noro 1299: extern int DP_Print, DP_PrintShort;
1.8 noro 1300:
1301: void Pdp_gr_print(arg,rp)
1302: NODE arg;
1303: Q *rp;
1304: {
1305: Q q;
1.29 noro 1306: int s;
1.8 noro 1307:
1308: if ( arg ) {
1309: asir_assert(ARG0(arg),O_N,"dp_gr_print");
1.29 noro 1310: q = (Q)ARG0(arg);
1311: s = QTOS(q);
1312: switch ( s ) {
1313: case 0:
1314: DP_Print = 0; DP_PrintShort = 0;
1315: break;
1316: case 1:
1317: DP_Print = 1;
1318: break;
1.41 noro 1319: case 2:
1.29 noro 1320: DP_Print = 0; DP_PrintShort = 1;
1.43 noro 1321: break;
1.41 noro 1322: default:
1323: DP_Print = s; DP_PrintShort = 0;
1.29 noro 1324: break;
1325: }
1326: } else {
1327: if ( DP_Print ) {
1328: STOQ(1,q);
1329: } else if ( DP_PrintShort ) {
1330: STOQ(2,q);
1331: } else
1332: q = 0;
1333: }
1.8 noro 1334: *rp = q;
1.1 noro 1335: }
1336:
1.46 noro 1337: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
1338: int *modular,struct order_spec **ord)
1339: {
1340: NODE t,p;
1341: Q m;
1342: char *key;
1343: Obj value,dmy;
1344: int ord_is_set = 0;
1345: int modular_is_set = 0;
1346: int homo_is_set = 0;
1.47 ! noro 1347: VL vl,vl0;
1.46 noro 1348: LIST vars;
1.47 ! noro 1349: char xiname[BUFSIZ];
! 1350: NODE x0,x;
! 1351: DP d;
! 1352: P xi;
! 1353: int nv,i;
1.46 noro 1354:
1355: /* extract vars */
1356: vars = 0;
1357: for ( t = opt; t; t = NEXT(t) ) {
1358: p = BDY((LIST)BDY(t));
1359: key = BDY((STRING)BDY(p));
1360: value = (Obj)BDY(NEXT(p));
1361: if ( !strcmp(key,"v") ) {
1362: /* variable list */
1363: vars = (LIST)value;
1364: break;
1365: }
1366: }
1.47 ! noro 1367: for ( t = BDY(f); t; t = NEXT(t) )
! 1368: if ( BDY(t) && OID((Obj)BDY(t))==O_DP )
! 1369: break;
! 1370: if ( t ) {
! 1371: /* f is DP list */
! 1372: /* create dummy var list */
! 1373: d = (DP)BDY(t);
! 1374: nv = NV(d);
! 1375: for ( i = 0, vl0 = 0, x0 = 0; i < nv; i++ ) {
! 1376: NEXTVL(vl0,vl);
! 1377: NEXTNODE(x0,x);
! 1378: sprintf(xiname,"x%d",i);
! 1379: makevar(xiname,&xi);
! 1380: x->body = (pointer)xi;
! 1381: vl->v = VR((P)xi);
! 1382: }
! 1383: if ( vl0 ) {
! 1384: NEXT(vl) = 0;
! 1385: NEXT(x) = 0;
! 1386: }
! 1387: MKLIST(vars,x0);
! 1388: *v = vars;
! 1389: vl = vl0;
! 1390: } else if ( !vars ) {
1.46 noro 1391: get_vars((Obj)f,&vl); vltopl(vl,v);
1392: } else {
1393: *v = vars; pltovl(vars,&vl);
1394: }
1395:
1396: for ( t = opt; t; t = NEXT(t) ) {
1397: p = BDY((LIST)BDY(t));
1398: key = BDY((STRING)BDY(p));
1399: value = (Obj)BDY(NEXT(p));
1400: if ( !strcmp(key,"v") ) {
1401: /* variable list; ignore */
1402: } else if ( !strcmp(key,"order") ) {
1403: /* order spec */
1404: create_order_spec(vl,value,ord);
1405: ord_is_set = 1;
1406: } else if ( !strcmp(key,"block") ) {
1407: create_order_spec(0,value,ord);
1408: } else if ( !strcmp(key,"matrix") ) {
1409: create_order_spec(0,value,ord);
1410: } else if ( !strcmp(key,"sugarweight") ) {
1411: /* weight */
1412: Pdp_set_weight(NEXT(p),&dmy);
1413: ord_is_set = 1;
1414: } else if ( !strcmp(key,"homo") ) {
1415: *homo = (Num)value;
1416: homo_is_set = 1;
1417: } else if ( !strcmp(key,"trace") ) {
1418: m = (Q)value;
1419: if ( !m )
1420: *modular = 0;
1421: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1
1422: && BD(NM(m))[0] >= 0x80000000) )
1423: error("parse_gr_option : too large modulus");
1424: else
1425: *modular = QTOS(m);
1426: modular_is_set = 1;
1427: } else
1428: error("parse_gr_option : not implemented");
1429: }
1430: if ( !ord_is_set ) create_order_spec(0,0,ord);
1431: if ( !modular_is_set ) *modular = 0;
1432: if ( !homo_is_set ) *homo = 0;
1433: }
1434:
1.8 noro 1435: void Pdp_gr_main(arg,rp)
1.1 noro 1436: NODE arg;
1.8 noro 1437: LIST *rp;
1.1 noro 1438: {
1.8 noro 1439: LIST f,v;
1.46 noro 1440: VL vl;
1.8 noro 1441: Num homo;
1442: Q m;
1.46 noro 1443: int modular,ac;
1444: struct order_spec *ord;
1.8 noro 1445:
1.11 noro 1446: do_weyl = 0;
1.8 noro 1447: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1.46 noro 1448: f = (LIST)ARG0(arg);
1.25 noro 1449: f = remove_zero_from_list(f);
1450: if ( !BDY(f) ) {
1451: *rp = f; return;
1452: }
1.46 noro 1453: if ( argc(arg) == 5 ) {
1454: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
1455: asir_assert(ARG2(arg),O_N,"dp_gr_main");
1456: asir_assert(ARG3(arg),O_N,"dp_gr_main");
1457: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1458: homo = (Num)ARG2(arg);
1459: m = (Q)ARG3(arg);
1460: if ( !m )
1461: modular = 0;
1462: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1463: error("dp_gr_main : too large modulus");
1464: else
1465: modular = QTOS(m);
1466: create_order_spec(0,ARG4(arg),&ord);
1467: } else if ( (ac=argc(arg)) == 2 && OID(ARG1(arg)) == O_OPTLIST )
1468: parse_gr_option(f,BDY((OPTLIST)ARG1(arg)),&v,&homo,&modular,&ord);
1469: else if ( ac == 1 )
1470: parse_gr_option(f,0,&v,&homo,&modular,&ord);
1.8 noro 1471: else
1.46 noro 1472: error("dp_gr_main : invalid argument");
1473: dp_gr_main(f,v,homo,modular,0,ord,rp);
1.16 noro 1474: }
1475:
1476: void Pdp_gr_f_main(arg,rp)
1477: NODE arg;
1478: LIST *rp;
1479: {
1480: LIST f,v;
1481: Num homo;
1.26 noro 1482: int m,field,t;
1.46 noro 1483: struct order_spec *ord;
1.26 noro 1484: NODE n;
1.16 noro 1485:
1486: do_weyl = 0;
1487: asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
1488: asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
1489: asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
1490: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1491: f = remove_zero_from_list(f);
1492: if ( !BDY(f) ) {
1493: *rp = f; return;
1494: }
1.16 noro 1495: homo = (Num)ARG2(arg);
1.27 noro 1496: #if 0
1497: asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
1.26 noro 1498: m = QTOS((Q)ARG3(arg));
1499: if ( m )
1500: error("dp_gr_f_main : trace lifting is not implemented yet");
1.46 noro 1501: create_order_spec(0,ARG4(arg),&ord);
1.27 noro 1502: #else
1503: m = 0;
1.46 noro 1504: create_order_spec(0,ARG3(arg),&ord);
1.27 noro 1505: #endif
1.26 noro 1506: field = 0;
1507: for ( n = BDY(f); n; n = NEXT(n) ) {
1508: t = get_field_type(BDY(n));
1509: if ( !t )
1510: continue;
1511: if ( t < 0 )
1512: error("dp_gr_f_main : incosistent coefficients");
1513: if ( !field )
1514: field = t;
1515: else if ( t != field )
1516: error("dp_gr_f_main : incosistent coefficients");
1517: }
1.46 noro 1518: dp_gr_main(f,v,homo,m?1:0,field,ord,rp);
1.1 noro 1519: }
1520:
1.8 noro 1521: void Pdp_f4_main(arg,rp)
1522: NODE arg;
1523: LIST *rp;
1.1 noro 1524: {
1.8 noro 1525: LIST f,v;
1.46 noro 1526: struct order_spec *ord;
1.1 noro 1527:
1.11 noro 1528: do_weyl = 0;
1.8 noro 1529: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1530: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1531: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1532: f = remove_zero_from_list(f);
1533: if ( !BDY(f) ) {
1534: *rp = f; return;
1535: }
1.46 noro 1536: create_order_spec(0,ARG2(arg),&ord);
1537: dp_f4_main(f,v,ord,rp);
1.22 noro 1538: }
1539:
1540: /* dp_gr_checklist(list of dp) */
1541:
1542: void Pdp_gr_checklist(arg,rp)
1543: NODE arg;
1544: LIST *rp;
1545: {
1546: VECT g;
1547: LIST dp;
1548: NODE r;
1.23 noro 1549: int n;
1.22 noro 1550:
1551: do_weyl = 0;
1552: asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
1.23 noro 1553: asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
1554: n = QTOS((Q)ARG1(arg));
1555: gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
1.22 noro 1556: r = mknode(2,g,dp);
1557: MKLIST(*rp,r);
1.1 noro 1558: }
1559:
1.8 noro 1560: void Pdp_f4_mod_main(arg,rp)
1561: NODE arg;
1562: LIST *rp;
1.1 noro 1563: {
1.8 noro 1564: LIST f,v;
1565: int m;
1.46 noro 1566: struct order_spec *ord;
1.8 noro 1567:
1.11 noro 1568: do_weyl = 0;
1.17 noro 1569: asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
1570: asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
1571: asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
1.8 noro 1572: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 1573: f = remove_zero_from_list(f);
1574: if ( !BDY(f) ) {
1575: *rp = f; return;
1576: }
1.20 noro 1577: if ( !m )
1578: error("dp_f4_mod_main : invalid argument");
1.46 noro 1579: create_order_spec(0,ARG3(arg),&ord);
1580: dp_f4_mod_main(f,v,m,ord,rp);
1.8 noro 1581: }
1.1 noro 1582:
1.8 noro 1583: void Pdp_gr_mod_main(arg,rp)
1584: NODE arg;
1585: LIST *rp;
1586: {
1587: LIST f,v;
1588: Num homo;
1589: int m;
1.46 noro 1590: struct order_spec *ord;
1.8 noro 1591:
1.11 noro 1592: do_weyl = 0;
1.8 noro 1593: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
1594: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
1595: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
1596: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1.11 noro 1597: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1598: f = remove_zero_from_list(f);
1599: if ( !BDY(f) ) {
1600: *rp = f; return;
1601: }
1.11 noro 1602: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1603: if ( !m )
1604: error("dp_gr_mod_main : invalid argument");
1.46 noro 1605: create_order_spec(0,ARG4(arg),&ord);
1606: dp_gr_mod_main(f,v,homo,m,ord,rp);
1.33 noro 1607: }
1608:
1.40 noro 1609: void Pnd_f4(arg,rp)
1610: NODE arg;
1611: LIST *rp;
1612: {
1613: LIST f,v;
1614: int m,homo;
1.46 noro 1615: struct order_spec *ord;
1.40 noro 1616:
1617: do_weyl = 0;
1618: asir_assert(ARG0(arg),O_LIST,"nd_gr");
1619: asir_assert(ARG1(arg),O_LIST,"nd_gr");
1620: asir_assert(ARG2(arg),O_N,"nd_gr");
1621: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1622: f = remove_zero_from_list(f);
1623: if ( !BDY(f) ) {
1624: *rp = f; return;
1625: }
1626: m = QTOS((Q)ARG2(arg));
1.46 noro 1627: create_order_spec(0,ARG3(arg),&ord);
1628: nd_gr(f,v,m,1,ord,rp);
1.40 noro 1629: }
1630:
1.33 noro 1631: void Pnd_gr(arg,rp)
1632: NODE arg;
1633: LIST *rp;
1634: {
1635: LIST f,v;
1.36 noro 1636: int m,homo;
1.46 noro 1637: struct order_spec *ord;
1.33 noro 1638:
1639: do_weyl = 0;
1640: asir_assert(ARG0(arg),O_LIST,"nd_gr");
1641: asir_assert(ARG1(arg),O_LIST,"nd_gr");
1.36 noro 1642: asir_assert(ARG2(arg),O_N,"nd_gr");
1.33 noro 1643: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1644: f = remove_zero_from_list(f);
1645: if ( !BDY(f) ) {
1646: *rp = f; return;
1647: }
1648: m = QTOS((Q)ARG2(arg));
1.46 noro 1649: create_order_spec(0,ARG3(arg),&ord);
1650: nd_gr(f,v,m,0,ord,rp);
1.36 noro 1651: }
1652:
1653: void Pnd_gr_trace(arg,rp)
1654: NODE arg;
1655: LIST *rp;
1656: {
1657: LIST f,v;
1658: int m,homo;
1.46 noro 1659: struct order_spec *ord;
1.36 noro 1660:
1661: do_weyl = 0;
1662: asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
1663: asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
1664: asir_assert(ARG2(arg),O_N,"nd_gr_trace");
1665: asir_assert(ARG3(arg),O_N,"nd_gr_trace");
1666: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1667: f = remove_zero_from_list(f);
1668: if ( !BDY(f) ) {
1669: *rp = f; return;
1670: }
1671: homo = QTOS((Q)ARG2(arg));
1672: m = QTOS((Q)ARG3(arg));
1.46 noro 1673: create_order_spec(0,ARG4(arg),&ord);
1674: nd_gr_trace(f,v,m,homo,ord,rp);
1.11 noro 1675: }
1676:
1.38 noro 1677: void Pnd_weyl_gr(arg,rp)
1678: NODE arg;
1679: LIST *rp;
1680: {
1681: LIST f,v;
1682: int m,homo;
1.46 noro 1683: struct order_spec *ord;
1.38 noro 1684:
1685: do_weyl = 1;
1686: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr");
1687: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr");
1688: asir_assert(ARG2(arg),O_N,"nd_weyl_gr");
1689: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1690: f = remove_zero_from_list(f);
1691: if ( !BDY(f) ) {
1692: *rp = f; return;
1693: }
1694: m = QTOS((Q)ARG2(arg));
1.46 noro 1695: create_order_spec(0,ARG3(arg),&ord);
1696: nd_gr(f,v,m,0,ord,rp);
1.38 noro 1697: }
1698:
1699: void Pnd_weyl_gr_trace(arg,rp)
1700: NODE arg;
1701: LIST *rp;
1702: {
1703: LIST f,v;
1704: int m,homo;
1.46 noro 1705: struct order_spec *ord;
1.38 noro 1706:
1707: do_weyl = 1;
1708: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr_trace");
1709: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr_trace");
1710: asir_assert(ARG2(arg),O_N,"nd_weyl_gr_trace");
1711: asir_assert(ARG3(arg),O_N,"nd_weyl_gr_trace");
1712: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1713: f = remove_zero_from_list(f);
1714: if ( !BDY(f) ) {
1715: *rp = f; return;
1716: }
1717: homo = QTOS((Q)ARG2(arg));
1718: m = QTOS((Q)ARG3(arg));
1.46 noro 1719: create_order_spec(0,ARG4(arg),&ord);
1720: nd_gr_trace(f,v,m,homo,ord,rp);
1.38 noro 1721: }
1.39 noro 1722:
1723: void Pnd_nf(arg,rp)
1724: NODE arg;
1725: P *rp;
1726: {
1727: P f;
1728: LIST g,v;
1.46 noro 1729: struct order_spec *ord;
1.39 noro 1730:
1731: do_weyl = 0;
1732: asir_assert(ARG0(arg),O_P,"nd_nf");
1733: asir_assert(ARG1(arg),O_LIST,"nd_nf");
1734: asir_assert(ARG2(arg),O_LIST,"nd_nf");
1735: asir_assert(ARG4(arg),O_N,"nd_nf");
1736: f = (P)ARG0(arg);
1737: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
1738: if ( !BDY(g) ) {
1739: *rp = f; return;
1740: }
1741: v = (LIST)ARG2(arg);
1.46 noro 1742: create_order_spec(0,ARG3(arg),&ord);
1743: nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),ord,rp);
1.39 noro 1744: }
1745:
1.11 noro 1746: /* for Weyl algebra */
1747:
1748: void Pdp_weyl_gr_main(arg,rp)
1749: NODE arg;
1750: LIST *rp;
1751: {
1752: LIST f,v;
1753: Num homo;
1754: Q m;
1755: int modular;
1.46 noro 1756: struct order_spec *ord;
1.11 noro 1757:
1758: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1759: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1760: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1761: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1762: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1763: f = remove_zero_from_list(f);
1764: if ( !BDY(f) ) {
1765: *rp = f; return;
1766: }
1.11 noro 1767: homo = (Num)ARG2(arg);
1768: m = (Q)ARG3(arg);
1769: if ( !m )
1770: modular = 0;
1771: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1772: error("dp_gr_main : too large modulus");
1773: else
1774: modular = QTOS(m);
1.46 noro 1775: create_order_spec(0,ARG4(arg),&ord);
1.12 noro 1776: do_weyl = 1;
1.46 noro 1777: dp_gr_main(f,v,homo,modular,0,ord,rp);
1.16 noro 1778: do_weyl = 0;
1779: }
1780:
1781: void Pdp_weyl_gr_f_main(arg,rp)
1782: NODE arg;
1783: LIST *rp;
1784: {
1785: LIST f,v;
1786: Num homo;
1.46 noro 1787: struct order_spec *ord;
1.16 noro 1788:
1789: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1790: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1791: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1792: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1793: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1794: f = remove_zero_from_list(f);
1795: if ( !BDY(f) ) {
1796: *rp = f; return;
1797: }
1.16 noro 1798: homo = (Num)ARG2(arg);
1.46 noro 1799: create_order_spec(0,ARG3(arg),&ord);
1.16 noro 1800: do_weyl = 1;
1.46 noro 1801: dp_gr_main(f,v,homo,0,1,ord,rp);
1.12 noro 1802: do_weyl = 0;
1.11 noro 1803: }
1804:
1805: void Pdp_weyl_f4_main(arg,rp)
1806: NODE arg;
1807: LIST *rp;
1808: {
1809: LIST f,v;
1.46 noro 1810: struct order_spec *ord;
1.11 noro 1811:
1812: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1813: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1814: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1815: f = remove_zero_from_list(f);
1816: if ( !BDY(f) ) {
1817: *rp = f; return;
1818: }
1.46 noro 1819: create_order_spec(0,ARG2(arg),&ord);
1.12 noro 1820: do_weyl = 1;
1.46 noro 1821: dp_f4_main(f,v,ord,rp);
1.12 noro 1822: do_weyl = 0;
1.11 noro 1823: }
1824:
1825: void Pdp_weyl_f4_mod_main(arg,rp)
1826: NODE arg;
1827: LIST *rp;
1828: {
1829: LIST f,v;
1830: int m;
1.46 noro 1831: struct order_spec *ord;
1.11 noro 1832:
1833: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1834: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1835: asir_assert(ARG2(arg),O_N,"dp_f4_main");
1836: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 1837: f = remove_zero_from_list(f);
1838: if ( !BDY(f) ) {
1839: *rp = f; return;
1840: }
1.20 noro 1841: if ( !m )
1842: error("dp_weyl_f4_mod_main : invalid argument");
1.46 noro 1843: create_order_spec(0,ARG3(arg),&ord);
1.12 noro 1844: do_weyl = 1;
1.46 noro 1845: dp_f4_mod_main(f,v,m,ord,rp);
1.12 noro 1846: do_weyl = 0;
1.11 noro 1847: }
1848:
1849: void Pdp_weyl_gr_mod_main(arg,rp)
1850: NODE arg;
1851: LIST *rp;
1852: {
1853: LIST f,v;
1854: Num homo;
1855: int m;
1.46 noro 1856: struct order_spec *ord;
1.11 noro 1857:
1858: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
1859: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
1860: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
1861: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
1.8 noro 1862: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1863: f = remove_zero_from_list(f);
1864: if ( !BDY(f) ) {
1865: *rp = f; return;
1866: }
1.8 noro 1867: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1868: if ( !m )
1869: error("dp_weyl_gr_mod_main : invalid argument");
1.46 noro 1870: create_order_spec(0,ARG4(arg),&ord);
1.12 noro 1871: do_weyl = 1;
1.46 noro 1872: dp_gr_mod_main(f,v,homo,m,ord,rp);
1.12 noro 1873: do_weyl = 0;
1.1 noro 1874: }
1.8 noro 1875:
1.24 noro 1876: static VECT current_dl_weight_vector_obj;
1877: int *current_dl_weight_vector;
1878:
1879: void Pdp_set_weight(arg,rp)
1880: NODE arg;
1881: VECT *rp;
1882: {
1883: VECT v;
1884: int i,n;
1.45 noro 1885: NODE node;
1.24 noro 1886:
1887: if ( !arg )
1888: *rp = current_dl_weight_vector_obj;
1889: else if ( !ARG0(arg) ) {
1890: current_dl_weight_vector_obj = 0;
1891: current_dl_weight_vector = 0;
1892: *rp = 0;
1893: } else {
1.45 noro 1894: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
1895: error("dp_set_weight : invalid argument");
1896: if ( OID(ARG0(arg)) == O_VECT )
1897: v = (VECT)ARG0(arg);
1898: else {
1899: node = (NODE)BDY((LIST)ARG0(arg));
1900: n = length(node);
1901: MKVECT(v,n);
1902: for ( i = 0; i < n; i++, node = NEXT(node) )
1903: BDY(v)[i] = BDY(node);
1904: }
1.24 noro 1905: current_dl_weight_vector_obj = v;
1906: n = v->len;
1907: current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
1908: for ( i = 0; i < n; i++ )
1909: current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
1910: *rp = v;
1911: }
1912: }
1913:
1914: static VECT current_weyl_weight_vector_obj;
1915: int *current_weyl_weight_vector;
1.15 noro 1916:
1917: void Pdp_weyl_set_weight(arg,rp)
1918: NODE arg;
1919: VECT *rp;
1920: {
1921: VECT v;
1922: int i,n;
1923:
1924: if ( !arg )
1.24 noro 1925: *rp = current_weyl_weight_vector_obj;
1.15 noro 1926: else {
1927: asir_assert(ARG0(arg),O_VECT,"dp_weyl_set_weight");
1928: v = (VECT)ARG0(arg);
1.24 noro 1929: current_weyl_weight_vector_obj = v;
1.15 noro 1930: n = v->len;
1.24 noro 1931: current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
1.15 noro 1932: for ( i = 0; i < n; i++ )
1.24 noro 1933: current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
1.15 noro 1934: *rp = v;
1935: }
1.25 noro 1936: }
1937:
1938: LIST remove_zero_from_list(LIST l)
1939: {
1940: NODE n,r0,r;
1941: LIST rl;
1942:
1943: asir_assert(l,O_LIST,"remove_zero_from_list");
1944: n = BDY(l);
1945: for ( r0 = 0; n; n = NEXT(n) )
1946: if ( BDY(n) ) {
1947: NEXTNODE(r0,r);
1948: BDY(r) = BDY(n);
1949: }
1950: if ( r0 )
1951: NEXT(r) = 0;
1952: MKLIST(rl,r0);
1953: return rl;
1.26 noro 1954: }
1955:
1956: int get_field_type(P p)
1957: {
1958: int type,t;
1959: DCP dc;
1960:
1961: if ( !p )
1962: return 0;
1963: else if ( NUM(p) )
1964: return NID((Num)p);
1965: else {
1966: type = 0;
1967: for ( dc = DC(p); dc; dc = NEXT(dc) ) {
1968: t = get_field_type(COEF(dc));
1969: if ( !t )
1970: continue;
1971: if ( t < 0 )
1972: return t;
1973: if ( !type )
1974: type = t;
1975: else if ( t != type )
1976: return -1;
1977: }
1978: return type;
1979: }
1.15 noro 1980: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>