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