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