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