Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.41
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.41 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.40 2003/09/11 09:03:52 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;
1.41 ! noro 1310: case 2:
1.29 noro 1311: DP_Print = 0; DP_PrintShort = 1;
1.41 ! noro 1312: default:
! 1313: DP_Print = s; DP_PrintShort = 0;
1.29 noro 1314: break;
1315: }
1316: } else {
1317: if ( DP_Print ) {
1318: STOQ(1,q);
1319: } else if ( DP_PrintShort ) {
1320: STOQ(2,q);
1321: } else
1322: q = 0;
1323: }
1.8 noro 1324: *rp = q;
1.1 noro 1325: }
1326:
1.8 noro 1327: void Pdp_gr_main(arg,rp)
1.1 noro 1328: NODE arg;
1.8 noro 1329: LIST *rp;
1.1 noro 1330: {
1.8 noro 1331: LIST f,v;
1332: Num homo;
1333: Q m;
1334: int modular;
1335: struct order_spec ord;
1336:
1.11 noro 1337: do_weyl = 0;
1.8 noro 1338: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1339: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
1340: asir_assert(ARG2(arg),O_N,"dp_gr_main");
1341: asir_assert(ARG3(arg),O_N,"dp_gr_main");
1342: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1343: f = remove_zero_from_list(f);
1344: if ( !BDY(f) ) {
1345: *rp = f; return;
1346: }
1.8 noro 1347: homo = (Num)ARG2(arg);
1348: m = (Q)ARG3(arg);
1349: if ( !m )
1350: modular = 0;
1351: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1352: error("dp_gr_main : too large modulus");
1353: else
1354: modular = QTOS(m);
1355: create_order_spec(ARG4(arg),&ord);
1.16 noro 1356: dp_gr_main(f,v,homo,modular,0,&ord,rp);
1357: }
1358:
1359: void Pdp_gr_f_main(arg,rp)
1360: NODE arg;
1361: LIST *rp;
1362: {
1363: LIST f,v;
1364: Num homo;
1.26 noro 1365: int m,field,t;
1.16 noro 1366: struct order_spec ord;
1.26 noro 1367: NODE n;
1.16 noro 1368:
1369: do_weyl = 0;
1370: asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
1371: asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
1372: asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
1373: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1374: f = remove_zero_from_list(f);
1375: if ( !BDY(f) ) {
1376: *rp = f; return;
1377: }
1.16 noro 1378: homo = (Num)ARG2(arg);
1.27 noro 1379: #if 0
1380: asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
1.26 noro 1381: m = QTOS((Q)ARG3(arg));
1382: if ( m )
1383: error("dp_gr_f_main : trace lifting is not implemented yet");
1384: create_order_spec(ARG4(arg),&ord);
1.27 noro 1385: #else
1386: m = 0;
1387: create_order_spec(ARG3(arg),&ord);
1388: #endif
1.26 noro 1389: field = 0;
1390: for ( n = BDY(f); n; n = NEXT(n) ) {
1391: t = get_field_type(BDY(n));
1392: if ( !t )
1393: continue;
1394: if ( t < 0 )
1395: error("dp_gr_f_main : incosistent coefficients");
1396: if ( !field )
1397: field = t;
1398: else if ( t != field )
1399: error("dp_gr_f_main : incosistent coefficients");
1400: }
1401: dp_gr_main(f,v,homo,m?1:0,field,&ord,rp);
1.1 noro 1402: }
1403:
1.8 noro 1404: void Pdp_f4_main(arg,rp)
1405: NODE arg;
1406: LIST *rp;
1.1 noro 1407: {
1.8 noro 1408: LIST f,v;
1409: struct order_spec ord;
1.1 noro 1410:
1.11 noro 1411: do_weyl = 0;
1.8 noro 1412: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1413: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1414: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1415: f = remove_zero_from_list(f);
1416: if ( !BDY(f) ) {
1417: *rp = f; return;
1418: }
1.8 noro 1419: create_order_spec(ARG2(arg),&ord);
1.17 noro 1420: dp_f4_main(f,v,&ord,rp);
1.22 noro 1421: }
1422:
1423: /* dp_gr_checklist(list of dp) */
1424:
1425: void Pdp_gr_checklist(arg,rp)
1426: NODE arg;
1427: LIST *rp;
1428: {
1429: VECT g;
1430: LIST dp;
1431: NODE r;
1.23 noro 1432: int n;
1.22 noro 1433:
1434: do_weyl = 0;
1435: asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
1.23 noro 1436: asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
1437: n = QTOS((Q)ARG1(arg));
1438: gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
1.22 noro 1439: r = mknode(2,g,dp);
1440: MKLIST(*rp,r);
1.1 noro 1441: }
1442:
1.8 noro 1443: void Pdp_f4_mod_main(arg,rp)
1444: NODE arg;
1445: LIST *rp;
1.1 noro 1446: {
1.8 noro 1447: LIST f,v;
1448: int m;
1449: struct order_spec ord;
1450:
1.11 noro 1451: do_weyl = 0;
1.17 noro 1452: asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
1453: asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
1454: asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
1.8 noro 1455: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 1456: f = remove_zero_from_list(f);
1457: if ( !BDY(f) ) {
1458: *rp = f; return;
1459: }
1.20 noro 1460: if ( !m )
1461: error("dp_f4_mod_main : invalid argument");
1.8 noro 1462: create_order_spec(ARG3(arg),&ord);
1463: dp_f4_mod_main(f,v,m,&ord,rp);
1464: }
1.1 noro 1465:
1.8 noro 1466: void Pdp_gr_mod_main(arg,rp)
1467: NODE arg;
1468: LIST *rp;
1469: {
1470: LIST f,v;
1471: Num homo;
1472: int m;
1473: struct order_spec ord;
1474:
1.11 noro 1475: do_weyl = 0;
1.8 noro 1476: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
1477: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
1478: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
1479: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1.11 noro 1480: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1481: f = remove_zero_from_list(f);
1482: if ( !BDY(f) ) {
1483: *rp = f; return;
1484: }
1.11 noro 1485: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1486: if ( !m )
1487: error("dp_gr_mod_main : invalid argument");
1.11 noro 1488: create_order_spec(ARG4(arg),&ord);
1489: dp_gr_mod_main(f,v,homo,m,&ord,rp);
1.33 noro 1490: }
1491:
1.40 noro 1492: void Pnd_f4(arg,rp)
1493: NODE arg;
1494: LIST *rp;
1495: {
1496: LIST f,v;
1497: int m,homo;
1498: struct order_spec ord;
1499:
1500: do_weyl = 0;
1501: asir_assert(ARG0(arg),O_LIST,"nd_gr");
1502: asir_assert(ARG1(arg),O_LIST,"nd_gr");
1503: asir_assert(ARG2(arg),O_N,"nd_gr");
1504: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1505: f = remove_zero_from_list(f);
1506: if ( !BDY(f) ) {
1507: *rp = f; return;
1508: }
1509: m = QTOS((Q)ARG2(arg));
1510: create_order_spec(ARG3(arg),&ord);
1511: nd_gr(f,v,m,1,&ord,rp);
1512: }
1513:
1.33 noro 1514: void Pnd_gr(arg,rp)
1515: NODE arg;
1516: LIST *rp;
1517: {
1518: LIST f,v;
1.36 noro 1519: int m,homo;
1.33 noro 1520: struct order_spec ord;
1521:
1522: do_weyl = 0;
1523: asir_assert(ARG0(arg),O_LIST,"nd_gr");
1524: asir_assert(ARG1(arg),O_LIST,"nd_gr");
1.36 noro 1525: asir_assert(ARG2(arg),O_N,"nd_gr");
1.33 noro 1526: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1527: f = remove_zero_from_list(f);
1528: if ( !BDY(f) ) {
1529: *rp = f; return;
1530: }
1531: m = QTOS((Q)ARG2(arg));
1532: create_order_spec(ARG3(arg),&ord);
1.40 noro 1533: nd_gr(f,v,m,0,&ord,rp);
1.36 noro 1534: }
1535:
1536: void Pnd_gr_trace(arg,rp)
1537: NODE arg;
1538: LIST *rp;
1539: {
1540: LIST f,v;
1541: int m,homo;
1542: struct order_spec ord;
1543:
1544: do_weyl = 0;
1545: asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
1546: asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
1547: asir_assert(ARG2(arg),O_N,"nd_gr_trace");
1548: asir_assert(ARG3(arg),O_N,"nd_gr_trace");
1549: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1550: f = remove_zero_from_list(f);
1551: if ( !BDY(f) ) {
1552: *rp = f; return;
1553: }
1554: homo = QTOS((Q)ARG2(arg));
1555: m = QTOS((Q)ARG3(arg));
1556: create_order_spec(ARG4(arg),&ord);
1557: nd_gr_trace(f,v,m,homo,&ord,rp);
1.11 noro 1558: }
1559:
1.38 noro 1560: void Pnd_weyl_gr(arg,rp)
1561: NODE arg;
1562: LIST *rp;
1563: {
1564: LIST f,v;
1565: int m,homo;
1566: struct order_spec ord;
1567:
1568: do_weyl = 1;
1569: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr");
1570: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr");
1571: asir_assert(ARG2(arg),O_N,"nd_weyl_gr");
1572: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1573: f = remove_zero_from_list(f);
1574: if ( !BDY(f) ) {
1575: *rp = f; return;
1576: }
1577: m = QTOS((Q)ARG2(arg));
1578: create_order_spec(ARG3(arg),&ord);
1579: nd_gr(f,v,m,&ord,rp);
1580: }
1581:
1582: void Pnd_weyl_gr_trace(arg,rp)
1583: NODE arg;
1584: LIST *rp;
1585: {
1586: LIST f,v;
1587: int m,homo;
1588: struct order_spec ord;
1589:
1590: do_weyl = 1;
1591: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr_trace");
1592: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr_trace");
1593: asir_assert(ARG2(arg),O_N,"nd_weyl_gr_trace");
1594: asir_assert(ARG3(arg),O_N,"nd_weyl_gr_trace");
1595: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1596: f = remove_zero_from_list(f);
1597: if ( !BDY(f) ) {
1598: *rp = f; return;
1599: }
1600: homo = QTOS((Q)ARG2(arg));
1601: m = QTOS((Q)ARG3(arg));
1602: create_order_spec(ARG4(arg),&ord);
1603: nd_gr_trace(f,v,m,homo,&ord,rp);
1604: }
1.39 noro 1605:
1606: void Pnd_nf(arg,rp)
1607: NODE arg;
1608: P *rp;
1609: {
1610: P f;
1611: LIST g,v;
1612: struct order_spec ord;
1613:
1614: do_weyl = 0;
1615: asir_assert(ARG0(arg),O_P,"nd_nf");
1616: asir_assert(ARG1(arg),O_LIST,"nd_nf");
1617: asir_assert(ARG2(arg),O_LIST,"nd_nf");
1618: asir_assert(ARG4(arg),O_N,"nd_nf");
1619: f = (P)ARG0(arg);
1620: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
1621: if ( !BDY(g) ) {
1622: *rp = f; return;
1623: }
1624: v = (LIST)ARG2(arg);
1625: create_order_spec(ARG3(arg),&ord);
1626: nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),&ord,rp);
1627: }
1628:
1.11 noro 1629: /* for Weyl algebra */
1630:
1631: void Pdp_weyl_gr_main(arg,rp)
1632: NODE arg;
1633: LIST *rp;
1634: {
1635: LIST f,v;
1636: Num homo;
1637: Q m;
1638: int modular;
1639: struct order_spec ord;
1640:
1641: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1642: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1643: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1644: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1645: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1646: f = remove_zero_from_list(f);
1647: if ( !BDY(f) ) {
1648: *rp = f; return;
1649: }
1.11 noro 1650: homo = (Num)ARG2(arg);
1651: m = (Q)ARG3(arg);
1652: if ( !m )
1653: modular = 0;
1654: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1655: error("dp_gr_main : too large modulus");
1656: else
1657: modular = QTOS(m);
1658: create_order_spec(ARG4(arg),&ord);
1.12 noro 1659: do_weyl = 1;
1.16 noro 1660: dp_gr_main(f,v,homo,modular,0,&ord,rp);
1661: do_weyl = 0;
1662: }
1663:
1664: void Pdp_weyl_gr_f_main(arg,rp)
1665: NODE arg;
1666: LIST *rp;
1667: {
1668: LIST f,v;
1669: Num homo;
1670: struct order_spec ord;
1671:
1672: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1673: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1674: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1675: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1676: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1677: f = remove_zero_from_list(f);
1678: if ( !BDY(f) ) {
1679: *rp = f; return;
1680: }
1.16 noro 1681: homo = (Num)ARG2(arg);
1682: create_order_spec(ARG3(arg),&ord);
1683: do_weyl = 1;
1684: dp_gr_main(f,v,homo,0,1,&ord,rp);
1.12 noro 1685: do_weyl = 0;
1.11 noro 1686: }
1687:
1688: void Pdp_weyl_f4_main(arg,rp)
1689: NODE arg;
1690: LIST *rp;
1691: {
1692: LIST f,v;
1693: struct order_spec ord;
1694:
1695: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1696: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1697: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1698: f = remove_zero_from_list(f);
1699: if ( !BDY(f) ) {
1700: *rp = f; return;
1701: }
1.11 noro 1702: create_order_spec(ARG2(arg),&ord);
1.12 noro 1703: do_weyl = 1;
1.17 noro 1704: dp_f4_main(f,v,&ord,rp);
1.12 noro 1705: do_weyl = 0;
1.11 noro 1706: }
1707:
1708: void Pdp_weyl_f4_mod_main(arg,rp)
1709: NODE arg;
1710: LIST *rp;
1711: {
1712: LIST f,v;
1713: int m;
1714: struct order_spec ord;
1715:
1716: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1717: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1718: asir_assert(ARG2(arg),O_N,"dp_f4_main");
1719: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 1720: f = remove_zero_from_list(f);
1721: if ( !BDY(f) ) {
1722: *rp = f; return;
1723: }
1.20 noro 1724: if ( !m )
1725: error("dp_weyl_f4_mod_main : invalid argument");
1.11 noro 1726: create_order_spec(ARG3(arg),&ord);
1.12 noro 1727: do_weyl = 1;
1.11 noro 1728: dp_f4_mod_main(f,v,m,&ord,rp);
1.12 noro 1729: do_weyl = 0;
1.11 noro 1730: }
1731:
1732: void Pdp_weyl_gr_mod_main(arg,rp)
1733: NODE arg;
1734: LIST *rp;
1735: {
1736: LIST f,v;
1737: Num homo;
1738: int m;
1739: struct order_spec ord;
1740:
1741: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
1742: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
1743: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
1744: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
1.8 noro 1745: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1746: f = remove_zero_from_list(f);
1747: if ( !BDY(f) ) {
1748: *rp = f; return;
1749: }
1.8 noro 1750: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1751: if ( !m )
1752: error("dp_weyl_gr_mod_main : invalid argument");
1.8 noro 1753: create_order_spec(ARG4(arg),&ord);
1.12 noro 1754: do_weyl = 1;
1.8 noro 1755: dp_gr_mod_main(f,v,homo,m,&ord,rp);
1.12 noro 1756: do_weyl = 0;
1.1 noro 1757: }
1.8 noro 1758:
1.24 noro 1759: static VECT current_dl_weight_vector_obj;
1760: int *current_dl_weight_vector;
1761:
1762: void Pdp_set_weight(arg,rp)
1763: NODE arg;
1764: VECT *rp;
1765: {
1766: VECT v;
1767: int i,n;
1768:
1769: if ( !arg )
1770: *rp = current_dl_weight_vector_obj;
1771: else if ( !ARG0(arg) ) {
1772: current_dl_weight_vector_obj = 0;
1773: current_dl_weight_vector = 0;
1774: *rp = 0;
1775: } else {
1776: asir_assert(ARG0(arg),O_VECT,"dp_set_weight");
1777: v = (VECT)ARG0(arg);
1778: current_dl_weight_vector_obj = v;
1779: n = v->len;
1780: current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
1781: for ( i = 0; i < n; i++ )
1782: current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
1783: *rp = v;
1784: }
1785: }
1786:
1787: static VECT current_weyl_weight_vector_obj;
1788: int *current_weyl_weight_vector;
1.15 noro 1789:
1790: void Pdp_weyl_set_weight(arg,rp)
1791: NODE arg;
1792: VECT *rp;
1793: {
1794: VECT v;
1795: int i,n;
1796:
1797: if ( !arg )
1.24 noro 1798: *rp = current_weyl_weight_vector_obj;
1.15 noro 1799: else {
1800: asir_assert(ARG0(arg),O_VECT,"dp_weyl_set_weight");
1801: v = (VECT)ARG0(arg);
1.24 noro 1802: current_weyl_weight_vector_obj = v;
1.15 noro 1803: n = v->len;
1.24 noro 1804: current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
1.15 noro 1805: for ( i = 0; i < n; i++ )
1.24 noro 1806: current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
1.15 noro 1807: *rp = v;
1808: }
1.25 noro 1809: }
1810:
1811: LIST remove_zero_from_list(LIST l)
1812: {
1813: NODE n,r0,r;
1814: LIST rl;
1815:
1816: asir_assert(l,O_LIST,"remove_zero_from_list");
1817: n = BDY(l);
1818: for ( r0 = 0; n; n = NEXT(n) )
1819: if ( BDY(n) ) {
1820: NEXTNODE(r0,r);
1821: BDY(r) = BDY(n);
1822: }
1823: if ( r0 )
1824: NEXT(r) = 0;
1825: MKLIST(rl,r0);
1826: return rl;
1.26 noro 1827: }
1828:
1829: int get_field_type(P p)
1830: {
1831: int type,t;
1832: DCP dc;
1833:
1834: if ( !p )
1835: return 0;
1836: else if ( NUM(p) )
1837: return NID((Num)p);
1838: else {
1839: type = 0;
1840: for ( dc = DC(p); dc; dc = NEXT(dc) ) {
1841: t = get_field_type(COEF(dc));
1842: if ( !t )
1843: continue;
1844: if ( t < 0 )
1845: return t;
1846: if ( !type )
1847: type = t;
1848: else if ( t != type )
1849: return -1;
1850: }
1851: return type;
1852: }
1.15 noro 1853: }
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