Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.9
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.9 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.8 2000/12/05 06:59:15 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");
383: if ( Dist )
384: dp_ptozp_d(BDY(Dist),length(BDY(Dist)),(DP)ARG0(arg),rp);
385: else
386: dp_ptozp((DP)ARG0(arg),rp);
387: }
388:
389: void Pdp_ptozp2(arg,rp)
390: NODE arg;
391: LIST *rp;
392: {
393: DP p0,p1,h,r;
394: NODE n0;
395:
396: p0 = (DP)ARG0(arg); p1 = (DP)ARG1(arg);
397: asir_assert(p0,O_DP,"dp_ptozp2");
398: asir_assert(p1,O_DP,"dp_ptozp2");
399: if ( Dist )
400: dp_ptozp2_d(BDY(Dist),length(BDY(Dist)),p0,p1,&h,&r);
401: else
402: dp_ptozp2(p0,p1,&h,&r);
403: NEWNODE(n0); BDY(n0) = (pointer)h;
404: NEWNODE(NEXT(n0)); BDY(NEXT(n0)) = (pointer)r;
405: NEXT(NEXT(n0)) = 0;
406: MKLIST(*rp,n0);
407: }
408:
409: void Pdp_prim(arg,rp)
410: NODE arg;
411: DP *rp;
412: {
413: DP t;
414:
415: asir_assert(ARG0(arg),O_DP,"dp_prim");
416: dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
417: }
418:
419: void Pdp_mod(arg,rp)
420: NODE arg;
421: DP *rp;
422: {
423: DP p;
424: int mod;
425: NODE subst;
426:
427: asir_assert(ARG0(arg),O_DP,"dp_mod");
428: asir_assert(ARG1(arg),O_N,"dp_mod");
429: asir_assert(ARG2(arg),O_LIST,"dp_mod");
430: p = (DP)ARG0(arg); mod = QTOS((Q)ARG1(arg));
431: subst = BDY((LIST)ARG2(arg));
432: dp_mod(p,mod,subst,rp);
433: }
434:
435: void Pdp_rat(arg,rp)
436: NODE arg;
437: DP *rp;
438: {
439: asir_assert(ARG0(arg),O_DP,"dp_rat");
440: dp_rat((DP)ARG0(arg),rp);
441: }
442:
1.9 ! noro 443: extern int DP_Multiple;
! 444:
1.1 noro 445: void Pdp_nf(arg,rp)
446: NODE arg;
447: DP *rp;
448: {
449: NODE b;
450: DP *ps;
451: DP g;
452: int full;
453:
454: asir_assert(ARG0(arg),O_LIST,"dp_nf");
455: asir_assert(ARG1(arg),O_DP,"dp_nf");
456: asir_assert(ARG2(arg),O_VECT,"dp_nf");
457: asir_assert(ARG3(arg),O_N,"dp_nf");
458: if ( !(g = (DP)ARG1(arg)) ) {
459: *rp = 0; return;
460: }
461: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
462: full = (Q)ARG3(arg) ? 1 : 0;
1.9 ! noro 463: dp_nf_ptozp(b,g,ps,full,DP_Multiple,rp);
1.1 noro 464: }
465:
466: void Pdp_true_nf(arg,rp)
467: NODE arg;
468: LIST *rp;
469: {
470: NODE b,n;
471: DP *ps;
472: DP g;
473: DP nm;
474: P dn;
475: int full;
476:
477: asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
478: asir_assert(ARG1(arg),O_DP,"dp_true_nf");
479: asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
480: asir_assert(ARG3(arg),O_N,"dp_nf");
481: if ( !(g = (DP)ARG1(arg)) ) {
482: nm = 0; dn = (P)ONE;
483: } else {
484: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
485: full = (Q)ARG3(arg) ? 1 : 0;
486: dp_true_nf(b,g,ps,full,&nm,&dn);
487: }
488: NEWNODE(n); BDY(n) = (pointer)nm;
489: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
490: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
491: }
492:
1.8 noro 493: void Pdp_nf_mod(arg,rp)
494: NODE arg;
495: DP *rp;
496: {
497: NODE b;
498: DP g;
499: DP *ps;
500: int mod,full,ac;
1.9 ! noro 501: NODE n,n0;
1.8 noro 502:
503: ac = argc(arg);
504: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
505: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
506: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
507: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
508: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
509: if ( !(g = (DP)ARG1(arg)) ) {
510: *rp = 0; return;
511: }
512: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
513: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
1.9 ! noro 514: for ( n0 = n = 0; b; b = NEXT(b) ) {
! 515: NEXTNODE(n0,n);
! 516: BDY(n) = (pointer)QTOS((Q)BDY(b));
! 517: }
! 518: if ( n0 )
! 519: NEXT(n) = 0;
! 520: dp_nf_mod(n,g,ps,mod,full,rp);
1.8 noro 521: }
522:
523: void Pdp_true_nf_mod(arg,rp)
524: NODE arg;
525: LIST *rp;
526: {
527: NODE b;
528: DP g,nm;
529: P dn;
530: DP *ps;
531: int mod,full;
532: NODE n;
533:
534: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
535: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
536: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
537: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
538: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
539: if ( !(g = (DP)ARG1(arg)) ) {
540: nm = 0; dn = (P)ONEM;
541: } else {
542: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
543: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
544: dp_true_nf_mod(b,g,ps,mod,full,&nm,&dn);
545: }
546: NEWNODE(n); BDY(n) = (pointer)nm;
547: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
548: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.1 noro 549: }
550:
551: void Pdp_tdiv(arg,rp)
552: NODE arg;
553: DP *rp;
554: {
555: MP m,mr,mr0;
556: DP p;
557: Q c;
558: N d,q,r;
559: int sgn;
560:
561: asir_assert(ARG0(arg),O_DP,"dp_tdiv");
562: asir_assert(ARG1(arg),O_N,"dp_tdiv");
563: p = (DP)ARG0(arg); d = NM((Q)ARG1(arg)); sgn = SGN((Q)ARG1(arg));
564: if ( !p )
565: *rp = 0;
566: else {
567: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
568: divn(NM((Q)m->c),d,&q,&r);
569: if ( r ) {
570: *rp = 0; return;
571: } else {
572: NEXTMP(mr0,mr); NTOQ(q,SGN((Q)m->c)*sgn,c);
573: mr->c = (P)c; mr->dl = m->dl;
574: }
575: }
576: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
577: }
578: }
579:
580: void Pdp_red_coef(arg,rp)
581: NODE arg;
582: DP *rp;
583: {
584: MP m,mr,mr0;
585: P q,r;
586: DP p;
587: P mod;
588:
589: p = (DP)ARG0(arg); mod = (P)ARG1(arg);
590: asir_assert(p,O_DP,"dp_red_coef");
591: asir_assert(mod,O_P,"dp_red_coef");
592: if ( !p )
593: *rp = 0;
594: else {
595: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
596: divsrp(CO,m->c,mod,&q,&r);
597: if ( r ) {
598: NEXTMP(mr0,mr); mr->c = r; mr->dl = m->dl;
599: }
600: }
601: if ( mr0 ) {
602: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
603: } else
604: *rp = 0;
605: }
606: }
607:
608: void Pdp_redble(arg,rp)
609: NODE arg;
610: Q *rp;
611: {
612: asir_assert(ARG0(arg),O_DP,"dp_redble");
613: asir_assert(ARG1(arg),O_DP,"dp_redble");
614: if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
615: *rp = ONE;
616: else
617: *rp = 0;
618: }
619:
620: void Pdp_red_mod(arg,rp)
621: NODE arg;
622: LIST *rp;
623: {
624: DP h,r;
625: P dmy;
626: NODE n;
627:
628: asir_assert(ARG0(arg),O_DP,"dp_red_mod");
629: asir_assert(ARG1(arg),O_DP,"dp_red_mod");
630: asir_assert(ARG2(arg),O_DP,"dp_red_mod");
631: asir_assert(ARG3(arg),O_N,"dp_red_mod");
632: dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),QTOS((Q)ARG3(arg)),
633: &h,&r,&dmy);
634: NEWNODE(n); BDY(n) = (pointer)h;
635: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
636: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
637: }
638: void Pdp_subd(arg,rp)
639: NODE arg;
640: DP *rp;
641: {
642: DP p1,p2;
643:
644: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
645: asir_assert(p1,O_DP,"dp_subd");
646: asir_assert(p2,O_DP,"dp_subd");
647: dp_subd(p1,p2,rp);
648: }
649:
650: void Pdp_red(arg,rp)
651: NODE arg;
652: LIST *rp;
653: {
654: NODE n;
1.4 noro 655: DP head,rest,dmy1;
1.1 noro 656: P dmy;
657:
658: asir_assert(ARG0(arg),O_DP,"dp_red");
659: asir_assert(ARG1(arg),O_DP,"dp_red");
660: asir_assert(ARG2(arg),O_DP,"dp_red");
1.4 noro 661: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.1 noro 662: NEWNODE(n); BDY(n) = (pointer)head;
663: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
664: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
665: }
666:
667: void Pdp_sp(arg,rp)
668: NODE arg;
669: DP *rp;
670: {
671: DP p1,p2;
672:
673: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
674: asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
675: dp_sp(p1,p2,rp);
676: }
677:
678: void Pdp_sp_mod(arg,rp)
679: NODE arg;
680: DP *rp;
681: {
682: DP p1,p2;
683: int mod;
684:
685: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
686: asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
687: asir_assert(ARG2(arg),O_N,"dp_sp_mod");
688: mod = QTOS((Q)ARG2(arg));
689: dp_sp_mod(p1,p2,mod,rp);
690: }
691:
692: void Pdp_lcm(arg,rp)
693: NODE arg;
694: DP *rp;
695: {
696: int i,n,td;
697: DL d1,d2,d;
698: MP m;
699: DP p1,p2;
700:
701: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
702: asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
703: n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
704: NEWDL(d,n);
705: for ( i = 0, td = 0; i < n; i++ ) {
706: d->d[i] = MAX(d1->d[i],d2->d[i]); td += d->d[i];
707: }
708: d->td = td;
709: NEWMP(m); m->dl = d; m->c = (P)ONE; NEXT(m) = 0;
710: MKDP(n,m,*rp); (*rp)->sugar = td; /* XXX */
711: }
712:
713: void Pdp_hm(arg,rp)
714: NODE arg;
715: DP *rp;
716: {
717: DP p;
718:
719: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
720: dp_hm(p,rp);
721: }
722:
723: void Pdp_ht(arg,rp)
724: NODE arg;
725: DP *rp;
726: {
727: DP p;
728: MP m,mr;
729:
730: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
731: if ( !p )
732: *rp = 0;
733: else {
734: m = BDY(p);
735: NEWMP(mr); mr->dl = m->dl; mr->c = (P)ONE; NEXT(mr) = 0;
736: MKDP(p->nv,mr,*rp); (*rp)->sugar = mr->dl->td; /* XXX */
737: }
738: }
739:
740: void Pdp_hc(arg,rp)
741: NODE arg;
742: P *rp;
743: {
744: asir_assert(ARG0(arg),O_DP,"dp_hc");
745: if ( !ARG0(arg) )
746: *rp = 0;
747: else
748: *rp = BDY((DP)ARG0(arg))->c;
749: }
750:
751: void Pdp_rest(arg,rp)
752: NODE arg;
753: DP *rp;
754: {
755: asir_assert(ARG0(arg),O_DP,"dp_rest");
756: if ( !ARG0(arg) )
757: *rp = 0;
758: else
759: dp_rest((DP)ARG0(arg),rp);
760: }
761:
762: void Pdp_td(arg,rp)
763: NODE arg;
764: Q *rp;
765: {
766: DP p;
767:
768: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
769: if ( !p )
770: *rp = 0;
771: else
772: STOQ(BDY(p)->dl->td,*rp);
773: }
774:
775: void Pdp_sugar(arg,rp)
776: NODE arg;
777: Q *rp;
778: {
779: DP p;
780:
781: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
782: if ( !p )
783: *rp = 0;
784: else
785: STOQ(p->sugar,*rp);
786: }
787:
788: void Pdp_cri1(arg,rp)
789: NODE arg;
790: Q *rp;
791: {
792: DP p1,p2;
793: int *d1,*d2;
794: int i,n;
795:
796: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
797: asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
798: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
799: for ( i = 0; i < n; i++ )
800: if ( d1[i] > d2[i] )
801: break;
802: *rp = i == n ? ONE : 0;
803: }
804:
805: void Pdp_cri2(arg,rp)
806: NODE arg;
807: Q *rp;
808: {
809: DP p1,p2;
810: int *d1,*d2;
811: int i,n;
812:
813: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
814: asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
815: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
816: for ( i = 0; i < n; i++ )
817: if ( MIN(d1[i],d2[i]) >= 1 )
818: break;
819: *rp = i == n ? ONE : 0;
820: }
821:
822: void Pdp_minp(arg,rp)
823: NODE arg;
824: LIST *rp;
825: {
826: NODE tn,tn1,d,dd,dd0,p,tp;
827: LIST l,minp;
828: DP lcm,tlcm;
829: int s,ts;
830:
831: asir_assert(ARG0(arg),O_LIST,"dp_minp");
832: d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
833: p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
834: if ( !ARG1(arg) ) {
835: s = QTOS((Q)BDY(p)); p = NEXT(p);
836: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
837: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
838: tlcm = (DP)BDY(tp); tp = NEXT(tp);
839: ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
840: NEXTNODE(dd0,dd);
841: if ( ts < s ) {
842: BDY(dd) = (pointer)minp;
843: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
844: } else if ( ts == s ) {
845: if ( compd(CO,lcm,tlcm) > 0 ) {
846: BDY(dd) = (pointer)minp;
847: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
848: } else
849: BDY(dd) = BDY(d);
850: } else
851: BDY(dd) = BDY(d);
852: }
853: } else {
854: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
855: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
856: tlcm = (DP)BDY(tp);
857: NEXTNODE(dd0,dd);
858: if ( compd(CO,lcm,tlcm) > 0 ) {
859: BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
860: } else
861: BDY(dd) = BDY(d);
862: }
863: }
864: if ( dd0 )
865: NEXT(dd) = 0;
866: MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
867: }
868:
869: void Pdp_criB(arg,rp)
870: NODE arg;
871: LIST *rp;
872: {
873: NODE d,ij,dd,ddd;
874: int i,j,s,n;
875: DP *ps;
876: DL ts,ti,tj,lij,tdl;
877:
878: asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
879: asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
880: asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
881: if ( !d )
882: *rp = (LIST)ARG0(arg);
883: else {
884: ts = BDY(ps[s])->dl;
885: n = ps[s]->nv;
886: NEWDL(tdl,n);
887: for ( dd = 0; d; d = NEXT(d) ) {
888: ij = BDY((LIST)BDY(d));
889: i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
890: j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
891: lij = BDY((DP)BDY(ij))->dl;
892: ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
893: if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
894: || !dl_equal(n,lij,tdl)
895: || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
896: && dl_equal(n,tdl,lij))
897: || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
898: && dl_equal(n,tdl,lij)) ) {
899: MKNODE(ddd,BDY(d),dd);
900: dd = ddd;
901: }
902: }
903: MKLIST(*rp,dd);
904: }
905: }
906:
907: void Pdp_nelim(arg,rp)
908: NODE arg;
909: Q *rp;
910: {
911: if ( arg ) {
912: asir_assert(ARG0(arg),O_N,"dp_nelim");
913: dp_nelim = QTOS((Q)ARG0(arg));
914: }
915: STOQ(dp_nelim,*rp);
916: }
917:
918: void Pdp_mag(arg,rp)
919: NODE arg;
920: Q *rp;
921: {
922: DP p;
923: int s;
924: MP m;
925:
926: p = (DP)ARG0(arg);
927: asir_assert(p,O_DP,"dp_mag");
928: if ( !p )
929: *rp = 0;
930: else {
931: for ( s = 0, m = BDY(p); m; m = NEXT(m) )
932: s += p_mag(m->c);
933: STOQ(s,*rp);
934: }
935: }
936:
937: extern int kara_mag;
938:
939: void Pdp_set_kara(arg,rp)
940: NODE arg;
941: Q *rp;
942: {
943: if ( arg ) {
944: asir_assert(ARG0(arg),O_N,"dp_set_kara");
945: kara_mag = QTOS((Q)ARG0(arg));
946: }
947: STOQ(kara_mag,*rp);
948: }
949:
950: void Pdp_homo(arg,rp)
951: NODE arg;
952: DP *rp;
953: {
954: asir_assert(ARG0(arg),O_DP,"dp_homo");
955: dp_homo((DP)ARG0(arg),rp);
956: }
957:
1.8 noro 958: void Pdp_dehomo(arg,rp)
959: NODE arg;
1.1 noro 960: DP *rp;
961: {
1.8 noro 962: asir_assert(ARG0(arg),O_DP,"dp_dehomo");
963: dp_dehomo((DP)ARG0(arg),rp);
964: }
965:
966: void Pdp_gr_flags(arg,rp)
967: NODE arg;
968: LIST *rp;
969: {
970: Obj name,value;
971: NODE n;
1.1 noro 972:
1.8 noro 973: if ( arg ) {
974: asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
975: n = BDY((LIST)ARG0(arg));
976: while ( n ) {
977: name = (Obj)BDY(n); n = NEXT(n);
978: if ( !n )
979: break;
980: else {
981: value = (Obj)BDY(n); n = NEXT(n);
982: }
983: dp_set_flag(name,value);
1.1 noro 984: }
985: }
1.8 noro 986: dp_make_flaglist(rp);
987: }
988:
989: extern int DP_Print;
990:
991: void Pdp_gr_print(arg,rp)
992: NODE arg;
993: Q *rp;
994: {
995: Q q;
996:
997: if ( arg ) {
998: asir_assert(ARG0(arg),O_N,"dp_gr_print");
999: q = (Q)ARG0(arg); DP_Print = QTOS(q);
1000: } else
1001: STOQ(DP_Print,q);
1002: *rp = q;
1.1 noro 1003: }
1004:
1.8 noro 1005: void Pdp_gr_main(arg,rp)
1.1 noro 1006: NODE arg;
1.8 noro 1007: LIST *rp;
1.1 noro 1008: {
1.8 noro 1009: LIST f,v;
1010: Num homo;
1011: Q m;
1012: int modular;
1013: struct order_spec ord;
1014:
1015: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1016: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
1017: asir_assert(ARG2(arg),O_N,"dp_gr_main");
1018: asir_assert(ARG3(arg),O_N,"dp_gr_main");
1019: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1020: homo = (Num)ARG2(arg);
1021: m = (Q)ARG3(arg);
1022: if ( !m )
1023: modular = 0;
1024: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1025: error("dp_gr_main : too large modulus");
1026: else
1027: modular = QTOS(m);
1028: create_order_spec(ARG4(arg),&ord);
1029: dp_gr_main(f,v,homo,modular,&ord,rp);
1.1 noro 1030: }
1031:
1.8 noro 1032: void Pdp_f4_main(arg,rp)
1033: NODE arg;
1034: LIST *rp;
1.1 noro 1035: {
1.8 noro 1036: LIST f,v;
1037: struct order_spec ord;
1.1 noro 1038:
1.8 noro 1039: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1040: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1041: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1042: create_order_spec(ARG2(arg),&ord);
1043: dp_f4_main(f,v,&ord,rp);
1.1 noro 1044: }
1045:
1.8 noro 1046: void Pdp_f4_mod_main(arg,rp)
1047: NODE arg;
1048: LIST *rp;
1.1 noro 1049: {
1.8 noro 1050: LIST f,v;
1051: int m;
1052: struct order_spec ord;
1053:
1054: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1055: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1056: asir_assert(ARG2(arg),O_N,"dp_f4_main");
1057: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1058: create_order_spec(ARG3(arg),&ord);
1059: dp_f4_mod_main(f,v,m,&ord,rp);
1060: }
1.1 noro 1061:
1.8 noro 1062: void Pdp_gr_mod_main(arg,rp)
1063: NODE arg;
1064: LIST *rp;
1065: {
1066: LIST f,v;
1067: Num homo;
1068: int m;
1069: struct order_spec ord;
1070:
1071: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
1072: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
1073: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
1074: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1075: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1076: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1077: create_order_spec(ARG4(arg),&ord);
1078: dp_gr_mod_main(f,v,homo,m,&ord,rp);
1.1 noro 1079: }
1.8 noro 1080:
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