Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.46
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.46 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.45 2003/12/25 08:46:19 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;
! 1347: VL vl;
! 1348: LIST vars;
! 1349:
! 1350: /* extract vars */
! 1351: vars = 0;
! 1352: for ( t = opt; t; t = NEXT(t) ) {
! 1353: p = BDY((LIST)BDY(t));
! 1354: key = BDY((STRING)BDY(p));
! 1355: value = (Obj)BDY(NEXT(p));
! 1356: if ( !strcmp(key,"v") ) {
! 1357: /* variable list */
! 1358: vars = (LIST)value;
! 1359: break;
! 1360: }
! 1361: }
! 1362: if ( !vars ) {
! 1363: get_vars((Obj)f,&vl); vltopl(vl,v);
! 1364: } else {
! 1365: *v = vars; pltovl(vars,&vl);
! 1366: }
! 1367:
! 1368: for ( t = opt; t; t = NEXT(t) ) {
! 1369: p = BDY((LIST)BDY(t));
! 1370: key = BDY((STRING)BDY(p));
! 1371: value = (Obj)BDY(NEXT(p));
! 1372: if ( !strcmp(key,"v") ) {
! 1373: /* variable list; ignore */
! 1374: } else if ( !strcmp(key,"order") ) {
! 1375: /* order spec */
! 1376: create_order_spec(vl,value,ord);
! 1377: ord_is_set = 1;
! 1378: } else if ( !strcmp(key,"block") ) {
! 1379: create_order_spec(0,value,ord);
! 1380: } else if ( !strcmp(key,"matrix") ) {
! 1381: create_order_spec(0,value,ord);
! 1382: } else if ( !strcmp(key,"sugarweight") ) {
! 1383: /* weight */
! 1384: Pdp_set_weight(NEXT(p),&dmy);
! 1385: ord_is_set = 1;
! 1386: } else if ( !strcmp(key,"homo") ) {
! 1387: *homo = (Num)value;
! 1388: homo_is_set = 1;
! 1389: } else if ( !strcmp(key,"trace") ) {
! 1390: m = (Q)value;
! 1391: if ( !m )
! 1392: *modular = 0;
! 1393: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1
! 1394: && BD(NM(m))[0] >= 0x80000000) )
! 1395: error("parse_gr_option : too large modulus");
! 1396: else
! 1397: *modular = QTOS(m);
! 1398: modular_is_set = 1;
! 1399: } else
! 1400: error("parse_gr_option : not implemented");
! 1401: }
! 1402: if ( !ord_is_set ) create_order_spec(0,0,ord);
! 1403: if ( !modular_is_set ) *modular = 0;
! 1404: if ( !homo_is_set ) *homo = 0;
! 1405: }
! 1406:
1.8 noro 1407: void Pdp_gr_main(arg,rp)
1.1 noro 1408: NODE arg;
1.8 noro 1409: LIST *rp;
1.1 noro 1410: {
1.8 noro 1411: LIST f,v;
1.46 ! noro 1412: VL vl;
1.8 noro 1413: Num homo;
1414: Q m;
1.46 ! noro 1415: int modular,ac;
! 1416: struct order_spec *ord;
1.8 noro 1417:
1.11 noro 1418: do_weyl = 0;
1.8 noro 1419: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1.46 ! noro 1420: f = (LIST)ARG0(arg);
1.25 noro 1421: f = remove_zero_from_list(f);
1422: if ( !BDY(f) ) {
1423: *rp = f; return;
1424: }
1.46 ! noro 1425: if ( argc(arg) == 5 ) {
! 1426: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
! 1427: asir_assert(ARG2(arg),O_N,"dp_gr_main");
! 1428: asir_assert(ARG3(arg),O_N,"dp_gr_main");
! 1429: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 1430: homo = (Num)ARG2(arg);
! 1431: m = (Q)ARG3(arg);
! 1432: if ( !m )
! 1433: modular = 0;
! 1434: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
! 1435: error("dp_gr_main : too large modulus");
! 1436: else
! 1437: modular = QTOS(m);
! 1438: create_order_spec(0,ARG4(arg),&ord);
! 1439: } else if ( (ac=argc(arg)) == 2 && OID(ARG1(arg)) == O_OPTLIST )
! 1440: parse_gr_option(f,BDY((OPTLIST)ARG1(arg)),&v,&homo,&modular,&ord);
! 1441: else if ( ac == 1 )
! 1442: parse_gr_option(f,0,&v,&homo,&modular,&ord);
1.8 noro 1443: else
1.46 ! noro 1444: error("dp_gr_main : invalid argument");
! 1445: dp_gr_main(f,v,homo,modular,0,ord,rp);
1.16 noro 1446: }
1447:
1448: void Pdp_gr_f_main(arg,rp)
1449: NODE arg;
1450: LIST *rp;
1451: {
1452: LIST f,v;
1453: Num homo;
1.26 noro 1454: int m,field,t;
1.46 ! noro 1455: struct order_spec *ord;
1.26 noro 1456: NODE n;
1.16 noro 1457:
1458: do_weyl = 0;
1459: asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
1460: asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
1461: asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
1462: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1463: f = remove_zero_from_list(f);
1464: if ( !BDY(f) ) {
1465: *rp = f; return;
1466: }
1.16 noro 1467: homo = (Num)ARG2(arg);
1.27 noro 1468: #if 0
1469: asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
1.26 noro 1470: m = QTOS((Q)ARG3(arg));
1471: if ( m )
1472: error("dp_gr_f_main : trace lifting is not implemented yet");
1.46 ! noro 1473: create_order_spec(0,ARG4(arg),&ord);
1.27 noro 1474: #else
1475: m = 0;
1.46 ! noro 1476: create_order_spec(0,ARG3(arg),&ord);
1.27 noro 1477: #endif
1.26 noro 1478: field = 0;
1479: for ( n = BDY(f); n; n = NEXT(n) ) {
1480: t = get_field_type(BDY(n));
1481: if ( !t )
1482: continue;
1483: if ( t < 0 )
1484: error("dp_gr_f_main : incosistent coefficients");
1485: if ( !field )
1486: field = t;
1487: else if ( t != field )
1488: error("dp_gr_f_main : incosistent coefficients");
1489: }
1.46 ! noro 1490: dp_gr_main(f,v,homo,m?1:0,field,ord,rp);
1.1 noro 1491: }
1492:
1.8 noro 1493: void Pdp_f4_main(arg,rp)
1494: NODE arg;
1495: LIST *rp;
1.1 noro 1496: {
1.8 noro 1497: LIST f,v;
1.46 ! noro 1498: struct order_spec *ord;
1.1 noro 1499:
1.11 noro 1500: do_weyl = 0;
1.8 noro 1501: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1502: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1503: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1504: f = remove_zero_from_list(f);
1505: if ( !BDY(f) ) {
1506: *rp = f; return;
1507: }
1.46 ! noro 1508: create_order_spec(0,ARG2(arg),&ord);
! 1509: dp_f4_main(f,v,ord,rp);
1.22 noro 1510: }
1511:
1512: /* dp_gr_checklist(list of dp) */
1513:
1514: void Pdp_gr_checklist(arg,rp)
1515: NODE arg;
1516: LIST *rp;
1517: {
1518: VECT g;
1519: LIST dp;
1520: NODE r;
1.23 noro 1521: int n;
1.22 noro 1522:
1523: do_weyl = 0;
1524: asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
1.23 noro 1525: asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
1526: n = QTOS((Q)ARG1(arg));
1527: gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
1.22 noro 1528: r = mknode(2,g,dp);
1529: MKLIST(*rp,r);
1.1 noro 1530: }
1531:
1.8 noro 1532: void Pdp_f4_mod_main(arg,rp)
1533: NODE arg;
1534: LIST *rp;
1.1 noro 1535: {
1.8 noro 1536: LIST f,v;
1537: int m;
1.46 ! noro 1538: struct order_spec *ord;
1.8 noro 1539:
1.11 noro 1540: do_weyl = 0;
1.17 noro 1541: asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
1542: asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
1543: asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
1.8 noro 1544: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 1545: f = remove_zero_from_list(f);
1546: if ( !BDY(f) ) {
1547: *rp = f; return;
1548: }
1.20 noro 1549: if ( !m )
1550: error("dp_f4_mod_main : invalid argument");
1.46 ! noro 1551: create_order_spec(0,ARG3(arg),&ord);
! 1552: dp_f4_mod_main(f,v,m,ord,rp);
1.8 noro 1553: }
1.1 noro 1554:
1.8 noro 1555: void Pdp_gr_mod_main(arg,rp)
1556: NODE arg;
1557: LIST *rp;
1558: {
1559: LIST f,v;
1560: Num homo;
1561: int m;
1.46 ! noro 1562: struct order_spec *ord;
1.8 noro 1563:
1.11 noro 1564: do_weyl = 0;
1.8 noro 1565: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
1566: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
1567: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
1568: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1.11 noro 1569: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1570: f = remove_zero_from_list(f);
1571: if ( !BDY(f) ) {
1572: *rp = f; return;
1573: }
1.11 noro 1574: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1575: if ( !m )
1576: error("dp_gr_mod_main : invalid argument");
1.46 ! noro 1577: create_order_spec(0,ARG4(arg),&ord);
! 1578: dp_gr_mod_main(f,v,homo,m,ord,rp);
1.33 noro 1579: }
1580:
1.40 noro 1581: void Pnd_f4(arg,rp)
1582: NODE arg;
1583: LIST *rp;
1584: {
1585: LIST f,v;
1586: int m,homo;
1.46 ! noro 1587: struct order_spec *ord;
1.40 noro 1588:
1589: do_weyl = 0;
1590: asir_assert(ARG0(arg),O_LIST,"nd_gr");
1591: asir_assert(ARG1(arg),O_LIST,"nd_gr");
1592: asir_assert(ARG2(arg),O_N,"nd_gr");
1593: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1594: f = remove_zero_from_list(f);
1595: if ( !BDY(f) ) {
1596: *rp = f; return;
1597: }
1598: m = QTOS((Q)ARG2(arg));
1.46 ! noro 1599: create_order_spec(0,ARG3(arg),&ord);
! 1600: nd_gr(f,v,m,1,ord,rp);
1.40 noro 1601: }
1602:
1.33 noro 1603: void Pnd_gr(arg,rp)
1604: NODE arg;
1605: LIST *rp;
1606: {
1607: LIST f,v;
1.36 noro 1608: int m,homo;
1.46 ! noro 1609: struct order_spec *ord;
1.33 noro 1610:
1611: do_weyl = 0;
1612: asir_assert(ARG0(arg),O_LIST,"nd_gr");
1613: asir_assert(ARG1(arg),O_LIST,"nd_gr");
1.36 noro 1614: asir_assert(ARG2(arg),O_N,"nd_gr");
1.33 noro 1615: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1616: f = remove_zero_from_list(f);
1617: if ( !BDY(f) ) {
1618: *rp = f; return;
1619: }
1620: m = QTOS((Q)ARG2(arg));
1.46 ! noro 1621: create_order_spec(0,ARG3(arg),&ord);
! 1622: nd_gr(f,v,m,0,ord,rp);
1.36 noro 1623: }
1624:
1625: void Pnd_gr_trace(arg,rp)
1626: NODE arg;
1627: LIST *rp;
1628: {
1629: LIST f,v;
1630: int m,homo;
1.46 ! noro 1631: struct order_spec *ord;
1.36 noro 1632:
1633: do_weyl = 0;
1634: asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
1635: asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
1636: asir_assert(ARG2(arg),O_N,"nd_gr_trace");
1637: asir_assert(ARG3(arg),O_N,"nd_gr_trace");
1638: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1639: f = remove_zero_from_list(f);
1640: if ( !BDY(f) ) {
1641: *rp = f; return;
1642: }
1643: homo = QTOS((Q)ARG2(arg));
1644: m = QTOS((Q)ARG3(arg));
1.46 ! noro 1645: create_order_spec(0,ARG4(arg),&ord);
! 1646: nd_gr_trace(f,v,m,homo,ord,rp);
1.11 noro 1647: }
1648:
1.38 noro 1649: void Pnd_weyl_gr(arg,rp)
1650: NODE arg;
1651: LIST *rp;
1652: {
1653: LIST f,v;
1654: int m,homo;
1.46 ! noro 1655: struct order_spec *ord;
1.38 noro 1656:
1657: do_weyl = 1;
1658: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr");
1659: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr");
1660: asir_assert(ARG2(arg),O_N,"nd_weyl_gr");
1661: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1662: f = remove_zero_from_list(f);
1663: if ( !BDY(f) ) {
1664: *rp = f; return;
1665: }
1666: m = QTOS((Q)ARG2(arg));
1.46 ! noro 1667: create_order_spec(0,ARG3(arg),&ord);
! 1668: nd_gr(f,v,m,0,ord,rp);
1.38 noro 1669: }
1670:
1671: void Pnd_weyl_gr_trace(arg,rp)
1672: NODE arg;
1673: LIST *rp;
1674: {
1675: LIST f,v;
1676: int m,homo;
1.46 ! noro 1677: struct order_spec *ord;
1.38 noro 1678:
1679: do_weyl = 1;
1680: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr_trace");
1681: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr_trace");
1682: asir_assert(ARG2(arg),O_N,"nd_weyl_gr_trace");
1683: asir_assert(ARG3(arg),O_N,"nd_weyl_gr_trace");
1684: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1685: f = remove_zero_from_list(f);
1686: if ( !BDY(f) ) {
1687: *rp = f; return;
1688: }
1689: homo = QTOS((Q)ARG2(arg));
1690: m = QTOS((Q)ARG3(arg));
1.46 ! noro 1691: create_order_spec(0,ARG4(arg),&ord);
! 1692: nd_gr_trace(f,v,m,homo,ord,rp);
1.38 noro 1693: }
1.39 noro 1694:
1695: void Pnd_nf(arg,rp)
1696: NODE arg;
1697: P *rp;
1698: {
1699: P f;
1700: LIST g,v;
1.46 ! noro 1701: struct order_spec *ord;
1.39 noro 1702:
1703: do_weyl = 0;
1704: asir_assert(ARG0(arg),O_P,"nd_nf");
1705: asir_assert(ARG1(arg),O_LIST,"nd_nf");
1706: asir_assert(ARG2(arg),O_LIST,"nd_nf");
1707: asir_assert(ARG4(arg),O_N,"nd_nf");
1708: f = (P)ARG0(arg);
1709: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
1710: if ( !BDY(g) ) {
1711: *rp = f; return;
1712: }
1713: v = (LIST)ARG2(arg);
1.46 ! noro 1714: create_order_spec(0,ARG3(arg),&ord);
! 1715: nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),ord,rp);
1.39 noro 1716: }
1717:
1.11 noro 1718: /* for Weyl algebra */
1719:
1720: void Pdp_weyl_gr_main(arg,rp)
1721: NODE arg;
1722: LIST *rp;
1723: {
1724: LIST f,v;
1725: Num homo;
1726: Q m;
1727: int modular;
1.46 ! noro 1728: struct order_spec *ord;
1.11 noro 1729:
1730: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1731: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1732: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1733: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1734: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1735: f = remove_zero_from_list(f);
1736: if ( !BDY(f) ) {
1737: *rp = f; return;
1738: }
1.11 noro 1739: homo = (Num)ARG2(arg);
1740: m = (Q)ARG3(arg);
1741: if ( !m )
1742: modular = 0;
1743: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1744: error("dp_gr_main : too large modulus");
1745: else
1746: modular = QTOS(m);
1.46 ! noro 1747: create_order_spec(0,ARG4(arg),&ord);
1.12 noro 1748: do_weyl = 1;
1.46 ! noro 1749: dp_gr_main(f,v,homo,modular,0,ord,rp);
1.16 noro 1750: do_weyl = 0;
1751: }
1752:
1753: void Pdp_weyl_gr_f_main(arg,rp)
1754: NODE arg;
1755: LIST *rp;
1756: {
1757: LIST f,v;
1758: Num homo;
1.46 ! noro 1759: struct order_spec *ord;
1.16 noro 1760:
1761: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1762: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1763: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1764: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1765: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1766: f = remove_zero_from_list(f);
1767: if ( !BDY(f) ) {
1768: *rp = f; return;
1769: }
1.16 noro 1770: homo = (Num)ARG2(arg);
1.46 ! noro 1771: create_order_spec(0,ARG3(arg),&ord);
1.16 noro 1772: do_weyl = 1;
1.46 ! noro 1773: dp_gr_main(f,v,homo,0,1,ord,rp);
1.12 noro 1774: do_weyl = 0;
1.11 noro 1775: }
1776:
1777: void Pdp_weyl_f4_main(arg,rp)
1778: NODE arg;
1779: LIST *rp;
1780: {
1781: LIST f,v;
1.46 ! noro 1782: struct order_spec *ord;
1.11 noro 1783:
1784: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1785: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1786: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1787: f = remove_zero_from_list(f);
1788: if ( !BDY(f) ) {
1789: *rp = f; return;
1790: }
1.46 ! noro 1791: create_order_spec(0,ARG2(arg),&ord);
1.12 noro 1792: do_weyl = 1;
1.46 ! noro 1793: dp_f4_main(f,v,ord,rp);
1.12 noro 1794: do_weyl = 0;
1.11 noro 1795: }
1796:
1797: void Pdp_weyl_f4_mod_main(arg,rp)
1798: NODE arg;
1799: LIST *rp;
1800: {
1801: LIST f,v;
1802: int m;
1.46 ! noro 1803: struct order_spec *ord;
1.11 noro 1804:
1805: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1806: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1807: asir_assert(ARG2(arg),O_N,"dp_f4_main");
1808: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 1809: f = remove_zero_from_list(f);
1810: if ( !BDY(f) ) {
1811: *rp = f; return;
1812: }
1.20 noro 1813: if ( !m )
1814: error("dp_weyl_f4_mod_main : invalid argument");
1.46 ! noro 1815: create_order_spec(0,ARG3(arg),&ord);
1.12 noro 1816: do_weyl = 1;
1.46 ! noro 1817: dp_f4_mod_main(f,v,m,ord,rp);
1.12 noro 1818: do_weyl = 0;
1.11 noro 1819: }
1820:
1821: void Pdp_weyl_gr_mod_main(arg,rp)
1822: NODE arg;
1823: LIST *rp;
1824: {
1825: LIST f,v;
1826: Num homo;
1827: int m;
1.46 ! noro 1828: struct order_spec *ord;
1.11 noro 1829:
1830: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
1831: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
1832: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
1833: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
1.8 noro 1834: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1835: f = remove_zero_from_list(f);
1836: if ( !BDY(f) ) {
1837: *rp = f; return;
1838: }
1.8 noro 1839: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1840: if ( !m )
1841: error("dp_weyl_gr_mod_main : invalid argument");
1.46 ! noro 1842: create_order_spec(0,ARG4(arg),&ord);
1.12 noro 1843: do_weyl = 1;
1.46 ! noro 1844: dp_gr_mod_main(f,v,homo,m,ord,rp);
1.12 noro 1845: do_weyl = 0;
1.1 noro 1846: }
1.8 noro 1847:
1.24 noro 1848: static VECT current_dl_weight_vector_obj;
1849: int *current_dl_weight_vector;
1850:
1851: void Pdp_set_weight(arg,rp)
1852: NODE arg;
1853: VECT *rp;
1854: {
1855: VECT v;
1856: int i,n;
1.45 noro 1857: NODE node;
1.24 noro 1858:
1859: if ( !arg )
1860: *rp = current_dl_weight_vector_obj;
1861: else if ( !ARG0(arg) ) {
1862: current_dl_weight_vector_obj = 0;
1863: current_dl_weight_vector = 0;
1864: *rp = 0;
1865: } else {
1.45 noro 1866: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
1867: error("dp_set_weight : invalid argument");
1868: if ( OID(ARG0(arg)) == O_VECT )
1869: v = (VECT)ARG0(arg);
1870: else {
1871: node = (NODE)BDY((LIST)ARG0(arg));
1872: n = length(node);
1873: MKVECT(v,n);
1874: for ( i = 0; i < n; i++, node = NEXT(node) )
1875: BDY(v)[i] = BDY(node);
1876: }
1.24 noro 1877: current_dl_weight_vector_obj = v;
1878: n = v->len;
1879: current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
1880: for ( i = 0; i < n; i++ )
1881: current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
1882: *rp = v;
1883: }
1884: }
1885:
1886: static VECT current_weyl_weight_vector_obj;
1887: int *current_weyl_weight_vector;
1.15 noro 1888:
1889: void Pdp_weyl_set_weight(arg,rp)
1890: NODE arg;
1891: VECT *rp;
1892: {
1893: VECT v;
1894: int i,n;
1895:
1896: if ( !arg )
1.24 noro 1897: *rp = current_weyl_weight_vector_obj;
1.15 noro 1898: else {
1899: asir_assert(ARG0(arg),O_VECT,"dp_weyl_set_weight");
1900: v = (VECT)ARG0(arg);
1.24 noro 1901: current_weyl_weight_vector_obj = v;
1.15 noro 1902: n = v->len;
1.24 noro 1903: current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
1.15 noro 1904: for ( i = 0; i < n; i++ )
1.24 noro 1905: current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
1.15 noro 1906: *rp = v;
1907: }
1.25 noro 1908: }
1909:
1910: LIST remove_zero_from_list(LIST l)
1911: {
1912: NODE n,r0,r;
1913: LIST rl;
1914:
1915: asir_assert(l,O_LIST,"remove_zero_from_list");
1916: n = BDY(l);
1917: for ( r0 = 0; n; n = NEXT(n) )
1918: if ( BDY(n) ) {
1919: NEXTNODE(r0,r);
1920: BDY(r) = BDY(n);
1921: }
1922: if ( r0 )
1923: NEXT(r) = 0;
1924: MKLIST(rl,r0);
1925: return rl;
1.26 noro 1926: }
1927:
1928: int get_field_type(P p)
1929: {
1930: int type,t;
1931: DCP dc;
1932:
1933: if ( !p )
1934: return 0;
1935: else if ( NUM(p) )
1936: return NID((Num)p);
1937: else {
1938: type = 0;
1939: for ( dc = DC(p); dc; dc = NEXT(dc) ) {
1940: t = get_field_type(COEF(dc));
1941: if ( !t )
1942: continue;
1943: if ( t < 0 )
1944: return t;
1945: if ( !type )
1946: type = t;
1947: else if ( t != type )
1948: return -1;
1949: }
1950: return type;
1951: }
1.15 noro 1952: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>