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