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