Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.10
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.10 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.9 2000/12/08 02:39:05 noro Exp $
1.5 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "base.h"
52: #include "parse.h"
53:
54: extern int dp_fcoeffs;
1.8 noro 55: extern int dp_nelim;
56: extern int dp_order_pair_length;
57: extern struct order_pair *dp_order_pair;
58: extern struct order_spec dp_current_spec;
59:
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();
64: void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv();
65: void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat();
1.9 noro 66: void Pdp_nf(),Pdp_true_nf();
1.1 noro 67: void Pdp_nf_mod(),Pdp_true_nf_mod();
68: void Pdp_criB(),Pdp_nelim();
1.9 noro 69: void Pdp_minp(),Pdp_sp_mod();
1.1 noro 70: void Pdp_homo(),Pdp_dehomo();
71: void Pdp_gr_mod_main();
72: void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags();
73: void Pdp_f4_main(),Pdp_f4_mod_main();
74: void Pdp_gr_print();
1.8 noro 75: void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_mdtod();
76: void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
77: void Pdp_cont();
1.1 noro 78:
79: struct ftab dp_tab[] = {
1.8 noro 80: /* content reduction */
1.1 noro 81: {"dp_ptozp",Pdp_ptozp,1},
82: {"dp_ptozp2",Pdp_ptozp2,2},
83: {"dp_prim",Pdp_prim,1},
1.8 noro 84: {"dp_red_coef",Pdp_red_coef,2},
85: {"dp_cont",Pdp_cont,1},
86:
87: /* s-poly */
88: {"dp_sp",Pdp_sp,2},
89: {"dp_sp_mod",Pdp_sp_mod,3},
90:
91: /* m-reduction */
1.1 noro 92: {"dp_red",Pdp_red,3},
93: {"dp_red_mod",Pdp_red_mod,4},
1.8 noro 94:
95: /* normal form */
1.1 noro 96: {"dp_nf",Pdp_nf,4},
97: {"dp_true_nf",Pdp_true_nf,4},
98: {"dp_nf_mod",Pdp_nf_mod,5},
99: {"dp_true_nf_mod",Pdp_true_nf_mod,5},
1.8 noro 100: {"dp_lnf_mod",Pdp_lnf_mod,3},
101: {"dp_nf_tab_mod",Pdp_nf_tab_mod,3},
102:
103: /* Buchberger algorithm */
1.1 noro 104: {"dp_gr_main",Pdp_gr_main,5},
105: {"dp_gr_mod_main",Pdp_gr_mod_main,5},
1.8 noro 106:
107: /* F4 algorithm */
1.1 noro 108: {"dp_f4_main",Pdp_f4_main,3},
109: {"dp_f4_mod_main",Pdp_f4_mod_main,4},
1.8 noro 110:
111: {0,0,0},
112: };
113:
114: struct ftab dp_supp_tab[] = {
115: /* setting flags */
116: {"dp_ord",Pdp_ord,-1},
117: {"dp_set_kara",Pdp_set_kara,-1},
118: {"dp_nelim",Pdp_nelim,-1},
1.1 noro 119: {"dp_gr_flags",Pdp_gr_flags,-1},
120: {"dp_gr_print",Pdp_gr_print,-1},
1.8 noro 121:
122: /* converters */
123: {"dp_ptod",Pdp_ptod,2},
124: {"dp_dtop",Pdp_dtop,2},
125: {"dp_homo",Pdp_homo,1},
126: {"dp_dehomo",Pdp_dehomo,1},
127: {"dp_etov",Pdp_etov,1},
128: {"dp_vtoe",Pdp_vtoe,1},
129: {"dp_dtov",Pdp_dtov,1},
130: {"dp_mdtod",Pdp_mdtod,1},
131: {"dp_mod",Pdp_mod,3},
132: {"dp_rat",Pdp_rat,1},
133:
134: /* criteria */
135: {"dp_cri1",Pdp_cri1,2},
136: {"dp_cri2",Pdp_cri2,2},
137: {"dp_criB",Pdp_criB,3},
138:
139: /* simple operation */
140: {"dp_subd",Pdp_subd,2},
141: {"dp_lcm",Pdp_lcm,2},
142: {"dp_hm",Pdp_hm,1},
143: {"dp_ht",Pdp_ht,1},
144: {"dp_hc",Pdp_hc,1},
145: {"dp_rest",Pdp_rest,1},
146:
147: /* degree and size */
148: {"dp_td",Pdp_td,1},
149: {"dp_mag",Pdp_mag,1},
150: {"dp_sugar",Pdp_sugar,1},
151:
152: /* misc */
153: {"dp_mbase",Pdp_mbase,1},
154: {"dp_redble",Pdp_redble,2},
155: {"dp_sep",Pdp_sep,2},
156: {"dp_idiv",Pdp_idiv,2},
157: {"dp_tdiv",Pdp_tdiv,2},
158: {"dp_minp",Pdp_minp,2},
159:
160: {0,0,0}
1.1 noro 161: };
162:
1.8 noro 163: void Pdp_mdtod(arg,rp)
164: NODE arg;
165: DP *rp;
166: {
167: MP m,mr,mr0;
168: DP p;
169: P t;
170:
171: p = (DP)ARG0(arg);
172: if ( !p )
173: *rp = 0;
174: else {
175: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
176: mptop(m->c,&t); NEXTMP(mr0,mr); mr->c = t; mr->dl = m->dl;
177: }
178: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
179: }
180: }
181:
182: void Pdp_sep(arg,rp)
183: NODE arg;
184: VECT *rp;
185: {
186: DP p,r;
187: MP m,t;
188: MP *w0,*w;
189: int i,n,d,nv,sugar;
190: VECT v;
191: pointer *pv;
192:
193: p = (DP)ARG0(arg); m = BDY(p);
194: d = QTOS((Q)ARG1(arg));
195: for ( t = m, n = 0; t; t = NEXT(t), n++ );
196: if ( d > n )
197: d = n;
198: MKVECT(v,d); *rp = v;
199: pv = BDY(v); nv = p->nv; sugar = p->sugar;
200: w0 = (MP *)MALLOC(d*sizeof(MP)); bzero(w0,d*sizeof(MP));
201: w = (MP *)MALLOC(d*sizeof(MP)); bzero(w,d*sizeof(MP));
202: for ( t = BDY(p), i = 0; t; t = NEXT(t), i++, i %= d ) {
203: NEXTMP(w0[i],w[i]); w[i]->c = t->c; w[i]->dl = t->dl;
204: }
205: for ( i = 0; i < d; i++ ) {
206: NEXT(w[i]) = 0; MKDP(nv,w0[i],r); r->sugar = sugar;
207: pv[i] = (pointer)r;
208: }
209: }
210:
211: void Pdp_idiv(arg,rp)
212: NODE arg;
213: DP *rp;
214: {
215: dp_idiv((DP)ARG0(arg),(Q)ARG1(arg),rp);
216: }
217:
218: void Pdp_cont(arg,rp)
219: NODE arg;
220: Q *rp;
221: {
222: dp_cont((DP)ARG0(arg),rp);
223: }
224:
225: void Pdp_dtov(arg,rp)
226: NODE arg;
227: VECT *rp;
228: {
229: dp_dtov((DP)ARG0(arg),rp);
230: }
231:
232: void Pdp_mbase(arg,rp)
233: NODE arg;
234: LIST *rp;
235: {
236: NODE mb;
237:
238: asir_assert(ARG0(arg),O_LIST,"dp_mbase");
239: dp_mbase(BDY((LIST)ARG0(arg)),&mb);
240: MKLIST(*rp,mb);
241: }
242:
243: void Pdp_etov(arg,rp)
244: NODE arg;
245: VECT *rp;
246: {
247: DP dp;
248: int n,i;
249: int *d;
250: VECT v;
251: Q t;
252:
253: dp = (DP)ARG0(arg);
254: asir_assert(dp,O_DP,"dp_etov");
255: n = dp->nv; d = BDY(dp)->dl->d;
256: MKVECT(v,n);
257: for ( i = 0; i < n; i++ ) {
258: STOQ(d[i],t); v->body[i] = (pointer)t;
259: }
260: *rp = v;
261: }
262:
263: void Pdp_vtoe(arg,rp)
264: NODE arg;
265: DP *rp;
266: {
267: DP dp;
268: DL dl;
269: MP m;
270: int n,i,td;
271: int *d;
272: VECT v;
273:
274: v = (VECT)ARG0(arg);
275: asir_assert(v,O_VECT,"dp_vtoe");
276: n = v->len;
277: NEWDL(dl,n); d = dl->d;
278: for ( i = 0, td = 0; i < n; i++ ) {
279: d[i] = QTOS((Q)(v->body[i])); td += d[i];
280: }
281: dl->td = td;
282: NEWMP(m); m->dl = dl; m->c = (P)ONE; NEXT(m) = 0;
283: MKDP(n,m,dp); dp->sugar = td;
284: *rp = dp;
285: }
286:
287: void Pdp_lnf_mod(arg,rp)
288: NODE arg;
289: LIST *rp;
290: {
291: DP r1,r2;
292: NODE b,g,n;
293: int mod;
294:
295: asir_assert(ARG0(arg),O_LIST,"dp_lnf_mod");
296: asir_assert(ARG1(arg),O_LIST,"dp_lnf_mod");
297: asir_assert(ARG2(arg),O_N,"dp_lnf_mod");
298: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
299: mod = QTOS((Q)ARG2(arg));
300: dp_lnf_mod((DP)BDY(b),(DP)BDY(NEXT(b)),g,mod,&r1,&r2);
301: NEWNODE(n); BDY(n) = (pointer)r1;
302: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
303: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
304: }
305:
306: void Pdp_nf_tab_mod(arg,rp)
307: NODE arg;
308: DP *rp;
309: {
310: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_mod");
311: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_mod");
312: asir_assert(ARG2(arg),O_N,"dp_nf_tab_mod");
313: dp_nf_tab_mod((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),
314: QTOS((Q)ARG2(arg)),rp);
315: }
1.1 noro 316:
317: void Pdp_ord(arg,rp)
318: NODE arg;
319: Obj *rp;
320: {
321: struct order_spec spec;
322:
323: if ( !arg )
324: *rp = dp_current_spec.obj;
325: else if ( !create_order_spec((Obj)ARG0(arg),&spec) )
326: error("dp_ord : invalid order specification");
327: else {
328: initd(&spec); *rp = spec.obj;
329: }
330: }
331:
332: void Pdp_ptod(arg,rp)
333: NODE arg;
334: DP *rp;
335: {
336: NODE n;
337: VL vl,tvl;
338:
339: asir_assert(ARG0(arg),O_P,"dp_ptod");
340: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
341: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
342: if ( !vl ) {
343: NEWVL(vl); tvl = vl;
344: } else {
345: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
346: }
347: VR(tvl) = VR((P)BDY(n));
348: }
349: if ( vl )
350: NEXT(tvl) = 0;
351: ptod(CO,vl,(P)ARG0(arg),rp);
352: }
353:
354: void Pdp_dtop(arg,rp)
355: NODE arg;
356: P *rp;
357: {
358: NODE n;
359: VL vl,tvl;
360:
361: asir_assert(ARG0(arg),O_DP,"dp_dtop");
362: asir_assert(ARG1(arg),O_LIST,"dp_dtop");
363: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
364: if ( !vl ) {
365: NEWVL(vl); tvl = vl;
366: } else {
367: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
368: }
369: VR(tvl) = VR((P)BDY(n));
370: }
371: if ( vl )
372: NEXT(tvl) = 0;
373: dtop(CO,vl,(DP)ARG0(arg),rp);
374: }
375:
376: extern LIST Dist;
377:
378: void Pdp_ptozp(arg,rp)
379: NODE arg;
380: DP *rp;
381: {
382: asir_assert(ARG0(arg),O_DP,"dp_ptozp");
1.10 ! noro 383: dp_ptozp((DP)ARG0(arg),rp);
1.1 noro 384: }
385:
386: void Pdp_ptozp2(arg,rp)
387: NODE arg;
388: LIST *rp;
389: {
390: DP p0,p1,h,r;
391: NODE n0;
392:
393: p0 = (DP)ARG0(arg); p1 = (DP)ARG1(arg);
394: asir_assert(p0,O_DP,"dp_ptozp2");
395: asir_assert(p1,O_DP,"dp_ptozp2");
1.10 ! noro 396: dp_ptozp2(p0,p1,&h,&r);
1.1 noro 397: NEWNODE(n0); BDY(n0) = (pointer)h;
398: NEWNODE(NEXT(n0)); BDY(NEXT(n0)) = (pointer)r;
399: NEXT(NEXT(n0)) = 0;
400: MKLIST(*rp,n0);
401: }
402:
403: void Pdp_prim(arg,rp)
404: NODE arg;
405: DP *rp;
406: {
407: DP t;
408:
409: asir_assert(ARG0(arg),O_DP,"dp_prim");
410: dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
411: }
412:
413: void Pdp_mod(arg,rp)
414: NODE arg;
415: DP *rp;
416: {
417: DP p;
418: int mod;
419: NODE subst;
420:
421: asir_assert(ARG0(arg),O_DP,"dp_mod");
422: asir_assert(ARG1(arg),O_N,"dp_mod");
423: asir_assert(ARG2(arg),O_LIST,"dp_mod");
424: p = (DP)ARG0(arg); mod = QTOS((Q)ARG1(arg));
425: subst = BDY((LIST)ARG2(arg));
426: dp_mod(p,mod,subst,rp);
427: }
428:
429: void Pdp_rat(arg,rp)
430: NODE arg;
431: DP *rp;
432: {
433: asir_assert(ARG0(arg),O_DP,"dp_rat");
434: dp_rat((DP)ARG0(arg),rp);
435: }
436:
1.9 noro 437: extern int DP_Multiple;
438:
1.1 noro 439: void Pdp_nf(arg,rp)
440: NODE arg;
441: DP *rp;
442: {
443: NODE b;
444: DP *ps;
445: DP g;
446: int full;
447:
448: asir_assert(ARG0(arg),O_LIST,"dp_nf");
449: asir_assert(ARG1(arg),O_DP,"dp_nf");
450: asir_assert(ARG2(arg),O_VECT,"dp_nf");
451: asir_assert(ARG3(arg),O_N,"dp_nf");
452: if ( !(g = (DP)ARG1(arg)) ) {
453: *rp = 0; return;
454: }
455: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
456: full = (Q)ARG3(arg) ? 1 : 0;
1.9 noro 457: dp_nf_ptozp(b,g,ps,full,DP_Multiple,rp);
1.1 noro 458: }
459:
460: void Pdp_true_nf(arg,rp)
461: NODE arg;
462: LIST *rp;
463: {
464: NODE b,n;
465: DP *ps;
466: DP g;
467: DP nm;
468: P dn;
469: int full;
470:
471: asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
472: asir_assert(ARG1(arg),O_DP,"dp_true_nf");
473: asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
474: asir_assert(ARG3(arg),O_N,"dp_nf");
475: if ( !(g = (DP)ARG1(arg)) ) {
476: nm = 0; dn = (P)ONE;
477: } else {
478: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
479: full = (Q)ARG3(arg) ? 1 : 0;
480: dp_true_nf(b,g,ps,full,&nm,&dn);
481: }
482: NEWNODE(n); BDY(n) = (pointer)nm;
483: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
484: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
485: }
486:
1.8 noro 487: void Pdp_nf_mod(arg,rp)
488: NODE arg;
489: DP *rp;
490: {
491: NODE b;
492: DP g;
493: DP *ps;
494: int mod,full,ac;
1.9 noro 495: NODE n,n0;
1.8 noro 496:
497: ac = argc(arg);
498: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
499: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
500: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
501: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
502: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
503: if ( !(g = (DP)ARG1(arg)) ) {
504: *rp = 0; return;
505: }
506: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
507: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
1.9 noro 508: for ( n0 = n = 0; b; b = NEXT(b) ) {
509: NEXTNODE(n0,n);
510: BDY(n) = (pointer)QTOS((Q)BDY(b));
511: }
512: if ( n0 )
513: NEXT(n) = 0;
514: dp_nf_mod(n,g,ps,mod,full,rp);
1.8 noro 515: }
516:
517: void Pdp_true_nf_mod(arg,rp)
518: NODE arg;
519: LIST *rp;
520: {
521: NODE b;
522: DP g,nm;
523: P dn;
524: DP *ps;
525: int mod,full;
526: NODE n;
527:
528: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
529: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
530: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
531: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
532: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
533: if ( !(g = (DP)ARG1(arg)) ) {
534: nm = 0; dn = (P)ONEM;
535: } else {
536: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
537: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
538: dp_true_nf_mod(b,g,ps,mod,full,&nm,&dn);
539: }
540: NEWNODE(n); BDY(n) = (pointer)nm;
541: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
542: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.1 noro 543: }
544:
545: void Pdp_tdiv(arg,rp)
546: NODE arg;
547: DP *rp;
548: {
549: MP m,mr,mr0;
550: DP p;
551: Q c;
552: N d,q,r;
553: int sgn;
554:
555: asir_assert(ARG0(arg),O_DP,"dp_tdiv");
556: asir_assert(ARG1(arg),O_N,"dp_tdiv");
557: p = (DP)ARG0(arg); d = NM((Q)ARG1(arg)); sgn = SGN((Q)ARG1(arg));
558: if ( !p )
559: *rp = 0;
560: else {
561: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
562: divn(NM((Q)m->c),d,&q,&r);
563: if ( r ) {
564: *rp = 0; return;
565: } else {
566: NEXTMP(mr0,mr); NTOQ(q,SGN((Q)m->c)*sgn,c);
567: mr->c = (P)c; mr->dl = m->dl;
568: }
569: }
570: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
571: }
572: }
573:
574: void Pdp_red_coef(arg,rp)
575: NODE arg;
576: DP *rp;
577: {
578: MP m,mr,mr0;
579: P q,r;
580: DP p;
581: P mod;
582:
583: p = (DP)ARG0(arg); mod = (P)ARG1(arg);
584: asir_assert(p,O_DP,"dp_red_coef");
585: asir_assert(mod,O_P,"dp_red_coef");
586: if ( !p )
587: *rp = 0;
588: else {
589: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
590: divsrp(CO,m->c,mod,&q,&r);
591: if ( r ) {
592: NEXTMP(mr0,mr); mr->c = r; mr->dl = m->dl;
593: }
594: }
595: if ( mr0 ) {
596: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
597: } else
598: *rp = 0;
599: }
600: }
601:
602: void Pdp_redble(arg,rp)
603: NODE arg;
604: Q *rp;
605: {
606: asir_assert(ARG0(arg),O_DP,"dp_redble");
607: asir_assert(ARG1(arg),O_DP,"dp_redble");
608: if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
609: *rp = ONE;
610: else
611: *rp = 0;
612: }
613:
614: void Pdp_red_mod(arg,rp)
615: NODE arg;
616: LIST *rp;
617: {
618: DP h,r;
619: P dmy;
620: NODE n;
621:
622: asir_assert(ARG0(arg),O_DP,"dp_red_mod");
623: asir_assert(ARG1(arg),O_DP,"dp_red_mod");
624: asir_assert(ARG2(arg),O_DP,"dp_red_mod");
625: asir_assert(ARG3(arg),O_N,"dp_red_mod");
626: dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),QTOS((Q)ARG3(arg)),
627: &h,&r,&dmy);
628: NEWNODE(n); BDY(n) = (pointer)h;
629: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
630: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
631: }
632: void Pdp_subd(arg,rp)
633: NODE arg;
634: DP *rp;
635: {
636: DP p1,p2;
637:
638: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
639: asir_assert(p1,O_DP,"dp_subd");
640: asir_assert(p2,O_DP,"dp_subd");
641: dp_subd(p1,p2,rp);
642: }
643:
644: void Pdp_red(arg,rp)
645: NODE arg;
646: LIST *rp;
647: {
648: NODE n;
1.4 noro 649: DP head,rest,dmy1;
1.1 noro 650: P dmy;
651:
652: asir_assert(ARG0(arg),O_DP,"dp_red");
653: asir_assert(ARG1(arg),O_DP,"dp_red");
654: asir_assert(ARG2(arg),O_DP,"dp_red");
1.4 noro 655: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.1 noro 656: NEWNODE(n); BDY(n) = (pointer)head;
657: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
658: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
659: }
660:
661: void Pdp_sp(arg,rp)
662: NODE arg;
663: DP *rp;
664: {
665: DP p1,p2;
666:
667: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
668: asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
669: dp_sp(p1,p2,rp);
670: }
671:
672: void Pdp_sp_mod(arg,rp)
673: NODE arg;
674: DP *rp;
675: {
676: DP p1,p2;
677: int mod;
678:
679: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
680: asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
681: asir_assert(ARG2(arg),O_N,"dp_sp_mod");
682: mod = QTOS((Q)ARG2(arg));
683: dp_sp_mod(p1,p2,mod,rp);
684: }
685:
686: void Pdp_lcm(arg,rp)
687: NODE arg;
688: DP *rp;
689: {
690: int i,n,td;
691: DL d1,d2,d;
692: MP m;
693: DP p1,p2;
694:
695: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
696: asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
697: n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
698: NEWDL(d,n);
699: for ( i = 0, td = 0; i < n; i++ ) {
700: d->d[i] = MAX(d1->d[i],d2->d[i]); td += d->d[i];
701: }
702: d->td = td;
703: NEWMP(m); m->dl = d; m->c = (P)ONE; NEXT(m) = 0;
704: MKDP(n,m,*rp); (*rp)->sugar = td; /* XXX */
705: }
706:
707: void Pdp_hm(arg,rp)
708: NODE arg;
709: DP *rp;
710: {
711: DP p;
712:
713: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
714: dp_hm(p,rp);
715: }
716:
717: void Pdp_ht(arg,rp)
718: NODE arg;
719: DP *rp;
720: {
721: DP p;
722: MP m,mr;
723:
724: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
725: if ( !p )
726: *rp = 0;
727: else {
728: m = BDY(p);
729: NEWMP(mr); mr->dl = m->dl; mr->c = (P)ONE; NEXT(mr) = 0;
730: MKDP(p->nv,mr,*rp); (*rp)->sugar = mr->dl->td; /* XXX */
731: }
732: }
733:
734: void Pdp_hc(arg,rp)
735: NODE arg;
736: P *rp;
737: {
738: asir_assert(ARG0(arg),O_DP,"dp_hc");
739: if ( !ARG0(arg) )
740: *rp = 0;
741: else
742: *rp = BDY((DP)ARG0(arg))->c;
743: }
744:
745: void Pdp_rest(arg,rp)
746: NODE arg;
747: DP *rp;
748: {
749: asir_assert(ARG0(arg),O_DP,"dp_rest");
750: if ( !ARG0(arg) )
751: *rp = 0;
752: else
753: dp_rest((DP)ARG0(arg),rp);
754: }
755:
756: void Pdp_td(arg,rp)
757: NODE arg;
758: Q *rp;
759: {
760: DP p;
761:
762: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
763: if ( !p )
764: *rp = 0;
765: else
766: STOQ(BDY(p)->dl->td,*rp);
767: }
768:
769: void Pdp_sugar(arg,rp)
770: NODE arg;
771: Q *rp;
772: {
773: DP p;
774:
775: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
776: if ( !p )
777: *rp = 0;
778: else
779: STOQ(p->sugar,*rp);
780: }
781:
782: void Pdp_cri1(arg,rp)
783: NODE arg;
784: Q *rp;
785: {
786: DP p1,p2;
787: int *d1,*d2;
788: int i,n;
789:
790: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
791: asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
792: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
793: for ( i = 0; i < n; i++ )
794: if ( d1[i] > d2[i] )
795: break;
796: *rp = i == n ? ONE : 0;
797: }
798:
799: void Pdp_cri2(arg,rp)
800: NODE arg;
801: Q *rp;
802: {
803: DP p1,p2;
804: int *d1,*d2;
805: int i,n;
806:
807: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
808: asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
809: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
810: for ( i = 0; i < n; i++ )
811: if ( MIN(d1[i],d2[i]) >= 1 )
812: break;
813: *rp = i == n ? ONE : 0;
814: }
815:
816: void Pdp_minp(arg,rp)
817: NODE arg;
818: LIST *rp;
819: {
820: NODE tn,tn1,d,dd,dd0,p,tp;
821: LIST l,minp;
822: DP lcm,tlcm;
823: int s,ts;
824:
825: asir_assert(ARG0(arg),O_LIST,"dp_minp");
826: d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
827: p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
828: if ( !ARG1(arg) ) {
829: s = QTOS((Q)BDY(p)); p = NEXT(p);
830: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
831: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
832: tlcm = (DP)BDY(tp); tp = NEXT(tp);
833: ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
834: NEXTNODE(dd0,dd);
835: if ( ts < s ) {
836: BDY(dd) = (pointer)minp;
837: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
838: } else if ( ts == s ) {
839: if ( compd(CO,lcm,tlcm) > 0 ) {
840: BDY(dd) = (pointer)minp;
841: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
842: } else
843: BDY(dd) = BDY(d);
844: } else
845: BDY(dd) = BDY(d);
846: }
847: } else {
848: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
849: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
850: tlcm = (DP)BDY(tp);
851: NEXTNODE(dd0,dd);
852: if ( compd(CO,lcm,tlcm) > 0 ) {
853: BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
854: } else
855: BDY(dd) = BDY(d);
856: }
857: }
858: if ( dd0 )
859: NEXT(dd) = 0;
860: MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
861: }
862:
863: void Pdp_criB(arg,rp)
864: NODE arg;
865: LIST *rp;
866: {
867: NODE d,ij,dd,ddd;
868: int i,j,s,n;
869: DP *ps;
870: DL ts,ti,tj,lij,tdl;
871:
872: asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
873: asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
874: asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
875: if ( !d )
876: *rp = (LIST)ARG0(arg);
877: else {
878: ts = BDY(ps[s])->dl;
879: n = ps[s]->nv;
880: NEWDL(tdl,n);
881: for ( dd = 0; d; d = NEXT(d) ) {
882: ij = BDY((LIST)BDY(d));
883: i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
884: j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
885: lij = BDY((DP)BDY(ij))->dl;
886: ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
887: if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
888: || !dl_equal(n,lij,tdl)
889: || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
890: && dl_equal(n,tdl,lij))
891: || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
892: && dl_equal(n,tdl,lij)) ) {
893: MKNODE(ddd,BDY(d),dd);
894: dd = ddd;
895: }
896: }
897: MKLIST(*rp,dd);
898: }
899: }
900:
901: void Pdp_nelim(arg,rp)
902: NODE arg;
903: Q *rp;
904: {
905: if ( arg ) {
906: asir_assert(ARG0(arg),O_N,"dp_nelim");
907: dp_nelim = QTOS((Q)ARG0(arg));
908: }
909: STOQ(dp_nelim,*rp);
910: }
911:
912: void Pdp_mag(arg,rp)
913: NODE arg;
914: Q *rp;
915: {
916: DP p;
917: int s;
918: MP m;
919:
920: p = (DP)ARG0(arg);
921: asir_assert(p,O_DP,"dp_mag");
922: if ( !p )
923: *rp = 0;
924: else {
925: for ( s = 0, m = BDY(p); m; m = NEXT(m) )
926: s += p_mag(m->c);
927: STOQ(s,*rp);
928: }
929: }
930:
931: extern int kara_mag;
932:
933: void Pdp_set_kara(arg,rp)
934: NODE arg;
935: Q *rp;
936: {
937: if ( arg ) {
938: asir_assert(ARG0(arg),O_N,"dp_set_kara");
939: kara_mag = QTOS((Q)ARG0(arg));
940: }
941: STOQ(kara_mag,*rp);
942: }
943:
944: void Pdp_homo(arg,rp)
945: NODE arg;
946: DP *rp;
947: {
948: asir_assert(ARG0(arg),O_DP,"dp_homo");
949: dp_homo((DP)ARG0(arg),rp);
950: }
951:
1.8 noro 952: void Pdp_dehomo(arg,rp)
953: NODE arg;
1.1 noro 954: DP *rp;
955: {
1.8 noro 956: asir_assert(ARG0(arg),O_DP,"dp_dehomo");
957: dp_dehomo((DP)ARG0(arg),rp);
958: }
959:
960: void Pdp_gr_flags(arg,rp)
961: NODE arg;
962: LIST *rp;
963: {
964: Obj name,value;
965: NODE n;
1.1 noro 966:
1.8 noro 967: if ( arg ) {
968: asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
969: n = BDY((LIST)ARG0(arg));
970: while ( n ) {
971: name = (Obj)BDY(n); n = NEXT(n);
972: if ( !n )
973: break;
974: else {
975: value = (Obj)BDY(n); n = NEXT(n);
976: }
977: dp_set_flag(name,value);
1.1 noro 978: }
979: }
1.8 noro 980: dp_make_flaglist(rp);
981: }
982:
983: extern int DP_Print;
984:
985: void Pdp_gr_print(arg,rp)
986: NODE arg;
987: Q *rp;
988: {
989: Q q;
990:
991: if ( arg ) {
992: asir_assert(ARG0(arg),O_N,"dp_gr_print");
993: q = (Q)ARG0(arg); DP_Print = QTOS(q);
994: } else
995: STOQ(DP_Print,q);
996: *rp = q;
1.1 noro 997: }
998:
1.8 noro 999: void Pdp_gr_main(arg,rp)
1.1 noro 1000: NODE arg;
1.8 noro 1001: LIST *rp;
1.1 noro 1002: {
1.8 noro 1003: LIST f,v;
1004: Num homo;
1005: Q m;
1006: int modular;
1007: struct order_spec ord;
1008:
1009: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1010: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
1011: asir_assert(ARG2(arg),O_N,"dp_gr_main");
1012: asir_assert(ARG3(arg),O_N,"dp_gr_main");
1013: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1014: homo = (Num)ARG2(arg);
1015: m = (Q)ARG3(arg);
1016: if ( !m )
1017: modular = 0;
1018: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1019: error("dp_gr_main : too large modulus");
1020: else
1021: modular = QTOS(m);
1022: create_order_spec(ARG4(arg),&ord);
1023: dp_gr_main(f,v,homo,modular,&ord,rp);
1.1 noro 1024: }
1025:
1.8 noro 1026: void Pdp_f4_main(arg,rp)
1027: NODE arg;
1028: LIST *rp;
1.1 noro 1029: {
1.8 noro 1030: LIST f,v;
1031: struct order_spec ord;
1.1 noro 1032:
1.8 noro 1033: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1034: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1035: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1036: create_order_spec(ARG2(arg),&ord);
1037: dp_f4_main(f,v,&ord,rp);
1.1 noro 1038: }
1039:
1.8 noro 1040: void Pdp_f4_mod_main(arg,rp)
1041: NODE arg;
1042: LIST *rp;
1.1 noro 1043: {
1.8 noro 1044: LIST f,v;
1045: int m;
1046: struct order_spec ord;
1047:
1048: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1049: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1050: asir_assert(ARG2(arg),O_N,"dp_f4_main");
1051: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1052: create_order_spec(ARG3(arg),&ord);
1053: dp_f4_mod_main(f,v,m,&ord,rp);
1054: }
1.1 noro 1055:
1.8 noro 1056: void Pdp_gr_mod_main(arg,rp)
1057: NODE arg;
1058: LIST *rp;
1059: {
1060: LIST f,v;
1061: Num homo;
1062: int m;
1063: struct order_spec ord;
1064:
1065: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
1066: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
1067: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
1068: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1069: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1070: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1071: create_order_spec(ARG4(arg),&ord);
1072: dp_gr_mod_main(f,v,homo,m,&ord,rp);
1.1 noro 1073: }
1.8 noro 1074:
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