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