Annotation of OpenXM_contrib2/asir2018/builtin/dp.c, Revision 1.8
1.1 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
26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
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.8 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2018/builtin/dp.c,v 1.7 2019/03/18 07:09:58 noro Exp $
1.1 noro 49: */
50: #include "ca.h"
51: #include "base.h"
52: #include "parse.h"
53:
54: extern int dp_fcoeffs;
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: extern struct modorder_spec *dp_current_modspec;
60: extern int nd_rref2;
61:
62: int do_weyl;
63:
1.3 noro 64: void Pdp_monomial_hilbert_poincare();
1.1 noro 65: void Pdp_sort();
66: void Pdp_mul_trunc(),Pdp_quo();
67: void Pdp_ord(), Pdp_ptod(), Pdp_dtop(), Phomogenize();
68: void Pdp_ptozp(), Pdp_ptozp2(), Pdp_red(), Pdp_red2(), Pdp_lcm(), Pdp_redble();
69: void Pdp_sp(), Pdp_hm(), Pdp_ht(), Pdp_hc(), Pdp_rest(), Pdp_td(), Pdp_sugar();
70: void Pdp_set_sugar();
71: void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv();
72: void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat();
73: void Pdp_nf(),Pdp_true_nf(),Pdp_true_nf_marked(),Pdp_true_nf_marked_mod();
74:
75: void Pdp_true_nf_and_quotient(),Pdp_true_nf_and_quotient_mod();
76: void Pdp_true_nf_and_quotient_marked(),Pdp_true_nf_and_quotient_marked_mod();
77:
78: void Pdp_nf_mod(),Pdp_true_nf_mod();
79: void Pdp_criB(),Pdp_nelim();
80: void Pdp_minp(),Pdp_sp_mod();
81: void Pdp_homo(),Pdp_dehomo();
82: void Pdp_gr_mod_main(),Pdp_gr_f_main();
83: void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags();
84: void Pdp_interreduce();
85: void Pdp_f4_main(),Pdp_f4_mod_main(),Pdp_f4_f_main();
86: void Pdp_gr_print();
87: void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_mdtod(), Pdp_nf_tab_f();
88: void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
89: void Pdp_cont();
90: void Pdp_gr_checklist();
91: void Pdp_ltod(),Pdpv_ord(),Pdpv_ht(),Pdpv_hm(),Pdpv_hc();
92: void Pdpm_ltod(),Pdpm_dtol(),Pdpm_ord(),Pdpm_nf(),Pdpm_weyl_nf(),Pdpm_sp(),Pdpm_weyl_sp();
93: void Pdpm_hm(),Pdpm_ht(),Pdpm_hc();
94:
95: void Pdp_weyl_red();
96: void Pdp_weyl_sp();
97:
98: void Pdp_weyl_nf(),Pdp_weyl_nf_mod();
99: void Pdp_weyl_true_nf_and_quotient(),Pdp_weyl_true_nf_and_quotient_mod();
100: void Pdp_weyl_true_nf_and_quotient_marked(),Pdp_weyl_true_nf_and_quotient_marked_mod();
101:
102: void Pdp_weyl_gr_main(),Pdp_weyl_gr_mod_main(),Pdp_weyl_gr_f_main();
103: void Pdp_weyl_f4_main(),Pdp_weyl_f4_mod_main(),Pdp_weyl_f4_f_main();
104: void Pdp_weyl_mul(),Pdp_weyl_mul_mod(),Pdp_weyl_act();
105: void Pdp_weyl_set_weight();
106: void Pdp_set_weight(),Pdp_set_top_weight(),Pdp_set_module_weight();
107: void Pdp_nf_f(),Pdp_weyl_nf_f();
108: void Pdpm_nf_f(),Pdpm_weyl_nf_f();
109: void Pdp_lnf_f();
110: void Pnd_gr(),Pnd_gr_trace(),Pnd_f4(),Pnd_f4_trace();
111: void Pnd_gr_postproc(), Pnd_weyl_gr_postproc();
112: void Pnd_gr_recompute_trace(), Pnd_btog();
113: void Pnd_weyl_gr(),Pnd_weyl_gr_trace();
114: void Pnd_nf(),Pnd_weyl_nf();
115: void Pdp_initial_term();
116: void Pdp_order();
117: void Pdp_inv_or_split();
118: void Pdp_compute_last_t();
119: void Pdp_compute_last_w();
120: void Pdp_compute_essential_df();
121: void Pdp_get_denomlist();
122: void Pdp_symb_add();
123: void Pdp_mono_raddec();
124: void Pdp_mono_reduce();
125: void Pdp_rref2(),Psumi_updatepairs(),Psumi_symbolic();
126:
127: LIST dp_initial_term();
128: LIST dp_order();
129: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
130: int *modular,struct order_spec **ord);
131: NODE dp_inv_or_split(NODE gb,DP f,struct order_spec *spec, DP *inv);
132:
133: LIST remove_zero_from_list(LIST);
134:
135: struct ftab dp_tab[] = {
136: /* content reduction */
137: {"dp_ptozp",Pdp_ptozp,1},
138: {"dp_ptozp2",Pdp_ptozp2,2},
139: {"dp_prim",Pdp_prim,1},
140: {"dp_red_coef",Pdp_red_coef,2},
141: {"dp_cont",Pdp_cont,1},
142:
143: /* polynomial ring */
144: /* special operations */
145: {"dp_mul_trunc",Pdp_mul_trunc,3},
146: {"dp_quo",Pdp_quo,2},
147:
148: /* s-poly */
149: {"dp_sp",Pdp_sp,2},
150: {"dp_sp_mod",Pdp_sp_mod,3},
151:
152: /* m-reduction */
153: {"dp_red",Pdp_red,3},
154: {"dp_red_mod",Pdp_red_mod,4},
155:
156: /* normal form */
157: {"dp_nf",Pdp_nf,4},
158: {"dp_nf_mod",Pdp_nf_mod,5},
159: {"dp_nf_f",Pdp_nf_f,4},
160: {"dpm_nf_f",Pdpm_nf_f,4},
161: {"dpm_weyl_nf_f",Pdpm_weyl_nf_f,4},
162: {"dpm_nf",Pdpm_nf,4},
163: {"dpm_sp",Pdpm_sp,2},
164: {"dpm_weyl_sp",Pdpm_weyl_sp,2},
165:
166: {"dp_true_nf",Pdp_true_nf,4},
167: {"dp_true_nf_mod",Pdp_true_nf_mod,5},
168: {"dp_true_nf_marked",Pdp_true_nf_marked,4},
169: {"dp_true_nf_marked_mod",Pdp_true_nf_marked_mod,5},
170:
171: {"dp_true_nf_and_quotient",Pdp_true_nf_and_quotient,3},
172: {"dp_true_nf_and_quotient_mod",Pdp_true_nf_and_quotient_mod,4},
173: {"dp_true_nf_and_quotient_marked",Pdp_true_nf_and_quotient_marked,4},
174: {"dp_true_nf_and_quotient_marked_mod",Pdp_true_nf_and_quotient_marked_mod,5},
175:
176: {"dp_lnf_mod",Pdp_lnf_mod,3},
177: {"dp_nf_tab_f",Pdp_nf_tab_f,2},
178: {"dp_nf_tab_mod",Pdp_nf_tab_mod,3},
179: {"dp_lnf_f",Pdp_lnf_f,2},
180:
181: /* Buchberger algorithm */
182: {"dp_gr_main",Pdp_gr_main,-5},
183: {"dp_interreduce",Pdp_interreduce,3},
184: {"dp_gr_mod_main",Pdp_gr_mod_main,5},
185: {"dp_gr_f_main",Pdp_gr_f_main,4},
186: {"dp_gr_checklist",Pdp_gr_checklist,2},
187: {"nd_f4",Pnd_f4,-4},
188: {"nd_gr",Pnd_gr,-4},
189: {"nd_gr_trace",Pnd_gr_trace,-5},
190: {"nd_f4_trace",Pnd_f4_trace,-5},
191: {"nd_gr_postproc",Pnd_gr_postproc,5},
192: {"nd_gr_recompute_trace",Pnd_gr_recompute_trace,5},
193: {"nd_btog",Pnd_btog,-6},
194: {"nd_weyl_gr_postproc",Pnd_weyl_gr_postproc,5},
195: {"nd_weyl_gr",Pnd_weyl_gr,-4},
196: {"nd_weyl_gr_trace",Pnd_weyl_gr_trace,-5},
197: {"nd_nf",Pnd_nf,5},
198: {"nd_weyl_nf",Pnd_weyl_nf,5},
199:
200: /* F4 algorithm */
201: {"dp_f4_main",Pdp_f4_main,3},
202: {"dp_f4_mod_main",Pdp_f4_mod_main,4},
203:
204: /* weyl algebra */
205: /* multiplication */
206: {"dp_weyl_mul",Pdp_weyl_mul,2},
207: {"dp_weyl_mul_mod",Pdp_weyl_mul_mod,3},
208: {"dp_weyl_act",Pdp_weyl_act,2},
209:
210: /* s-poly */
211: {"dp_weyl_sp",Pdp_weyl_sp,2},
212:
213: /* m-reduction */
214: {"dp_weyl_red",Pdp_weyl_red,3},
215:
216: /* normal form */
217: {"dp_weyl_nf",Pdp_weyl_nf,4},
218: {"dpm_weyl_nf",Pdpm_weyl_nf,4},
219: {"dp_weyl_nf_mod",Pdp_weyl_nf_mod,5},
220: {"dp_weyl_nf_f",Pdp_weyl_nf_f,4},
221:
222: {"dp_weyl_true_nf_and_quotient",Pdp_weyl_true_nf_and_quotient,3},
223: {"dp_weyl_true_nf_and_quotient_mod",Pdp_weyl_true_nf_and_quotient_mod,4},
224: {"dp_weyl_true_nf_and_quotient_marked",Pdp_weyl_true_nf_and_quotient_marked,4},
225: {"dp_weyl_true_nf_and_quotient_marked_mod",Pdp_weyl_true_nf_and_quotient_marked_mod,5},
226:
227:
228: /* Buchberger algorithm */
229: {"dp_weyl_gr_main",Pdp_weyl_gr_main,-5},
230: {"dp_weyl_gr_mod_main",Pdp_weyl_gr_mod_main,5},
231: {"dp_weyl_gr_f_main",Pdp_weyl_gr_f_main,4},
232:
233: /* F4 algorithm */
234: {"dp_weyl_f4_main",Pdp_weyl_f4_main,3},
235: {"dp_weyl_f4_mod_main",Pdp_weyl_f4_mod_main,4},
236:
1.3 noro 237: /* Hilbert function */
238: {"dp_monomial_hilbert_poincare",Pdp_monomial_hilbert_poincare,2},
239:
1.1 noro 240: /* misc */
241: {"dp_inv_or_split",Pdp_inv_or_split,3},
242: {"dp_set_weight",Pdp_set_weight,-1},
243: {"dp_set_module_weight",Pdp_set_module_weight,-1},
244: {"dp_set_top_weight",Pdp_set_top_weight,-1},
245: {"dp_weyl_set_weight",Pdp_weyl_set_weight,-1},
246:
247: {"dp_get_denomlist",Pdp_get_denomlist,0},
248: {0,0,0},
249: };
250:
251: struct ftab dp_supp_tab[] = {
252: /* setting flags */
253: {"dp_sort",Pdp_sort,1},
254: {"dp_ord",Pdp_ord,-1},
255: {"dpm_ord",Pdpm_ord,-1},
256: {"dpv_ord",Pdpv_ord,-2},
257: {"dp_set_kara",Pdp_set_kara,-1},
258: {"dp_nelim",Pdp_nelim,-1},
259: {"dp_gr_flags",Pdp_gr_flags,-1},
260: {"dp_gr_print",Pdp_gr_print,-1},
261:
262: /* converters */
263: {"homogenize",Phomogenize,3},
264: {"dp_ptod",Pdp_ptod,-2},
265: {"dp_dtop",Pdp_dtop,2},
266: {"dp_homo",Pdp_homo,1},
267: {"dp_dehomo",Pdp_dehomo,1},
268: {"dp_etov",Pdp_etov,1},
269: {"dp_vtoe",Pdp_vtoe,1},
270: {"dp_dtov",Pdp_dtov,1},
271: {"dp_mdtod",Pdp_mdtod,1},
272: {"dp_mod",Pdp_mod,3},
273: {"dp_rat",Pdp_rat,1},
274: {"dp_ltod",Pdp_ltod,-2},
275:
276: {"dpm_ltod",Pdpm_ltod,2},
277: {"dpm_dtol",Pdpm_dtol,3},
278:
279: /* criteria */
280: {"dp_cri1",Pdp_cri1,2},
281: {"dp_cri2",Pdp_cri2,2},
282: {"dp_criB",Pdp_criB,3},
283:
284: /* simple operation */
285: {"dp_subd",Pdp_subd,2},
286: {"dp_lcm",Pdp_lcm,2},
287: {"dp_hm",Pdp_hm,1},
288: {"dp_ht",Pdp_ht,1},
289: {"dp_hc",Pdp_hc,1},
290: {"dpv_hm",Pdpv_hm,1},
291: {"dpv_ht",Pdpv_ht,1},
292: {"dpv_hc",Pdpv_hc,1},
293: {"dpm_hm",Pdpm_hm,1},
294: {"dpm_ht",Pdpm_ht,1},
295: {"dpm_hc",Pdpm_hc,1},
296: {"dp_rest",Pdp_rest,1},
297: {"dp_initial_term",Pdp_initial_term,1},
298: {"dp_order",Pdp_order,1},
299: {"dp_symb_add",Pdp_symb_add,2},
300:
301: /* degree and size */
302: {"dp_td",Pdp_td,1},
303: {"dp_mag",Pdp_mag,1},
304: {"dp_sugar",Pdp_sugar,1},
305: {"dp_set_sugar",Pdp_set_sugar,2},
306:
307: /* misc */
308: {"dp_mbase",Pdp_mbase,1},
309: {"dp_redble",Pdp_redble,2},
310: {"dp_sep",Pdp_sep,2},
311: {"dp_idiv",Pdp_idiv,2},
312: {"dp_tdiv",Pdp_tdiv,2},
313: {"dp_minp",Pdp_minp,2},
314: {"dp_compute_last_w",Pdp_compute_last_w,5},
315: {"dp_compute_last_t",Pdp_compute_last_t,5},
316: {"dp_compute_essential_df",Pdp_compute_essential_df,2},
317: {"dp_mono_raddec",Pdp_mono_raddec,2},
318: {"dp_mono_reduce",Pdp_mono_reduce,2},
319:
320: {"dp_rref2",Pdp_rref2,2},
321: {"sumi_updatepairs",Psumi_updatepairs,3},
322: {"sumi_symbolic",Psumi_symbolic,5},
323:
324: {0,0,0}
325: };
326:
327: NODE compute_last_w(NODE g,NODE gh,int n,int **v,int row1,int **m1,int row2,int **m2);
328: Q compute_last_t(NODE g,NODE gh,Q t,VECT w1,VECT w2,NODE *homo,VECT *wp);
329:
1.3 noro 330: int comp_by_tdeg(DP *a,DP *b)
331: {
332: int da,db;
333:
334: da = BDY(*a)->dl->td;
335: db = BDY(*b)->dl->td;
336: if ( da>db ) return 1;
337: else if ( da<db ) return -1;
338: else return 0;
339: }
340:
341: void dl_print(DL d,int n)
342: {
343: int i;
344:
345: printf("<<");
346: for ( i = 0; i < n; i++ )
347: printf("%d ",d->d[i]);
348: printf(">>\n");
349: }
350:
351: int simple_check(VECT b,int nv)
352: {
353: int n,i,j;
354: DL *p;
355:
356: n = b->len; p = (DL *)b->body;
357: for ( i = 0; i < n; i++ ) {
358: for ( j = 0; j < nv; j++ ) {
359: if ( p[i]->d[j] ) break;
360: }
361: if ( p[i]->d[j] != p[i]->td ) return 0;
362: }
363: return 1;
364: }
365:
366: void make_reduced(VECT b,int nv)
367: {
368: int n,i,j;
369: DL *p;
370: DL pi;
371:
372: n = b->len;
373: p = (DL *)BDY(b);
374: for ( i = 0; i < n; i++ ) {
375: pi = p[i];
376: if ( !pi ) continue;
377: for ( j = 0; j < n; j++ )
378: if ( i != j && p[j] && _dl_redble(pi,p[j],nv) ) p[j] = 0;
379: }
380: for ( i = j = 0; i < n; i++ )
381: if ( p[i] ) p[j++] = p[i];
382: b->len = j;
383: }
384:
385: void make_reduced2(VECT b,int k,int nv)
386: {
387: int n,i,j,l;
388: DL *p;
389: DL pi;
390:
391: n = b->len;
392: p = (DL *)BDY(b);
393: for ( i = l = k; i < n; i++ ) {
394: pi = p[i];
395: for ( j = 0; j < k; j++ )
396: if ( _dl_redble(p[j],pi,nv) ) break;
397: if ( j == k )
398: p[l++] = pi;
399: }
400: b->len = l;
401: }
402:
403: int i_all,i_simple;
404:
405: P mhp_simple(VECT b,VECT x,P t)
406: {
407: int n,i,j,nv;
408: DL *p;
409: P hp,mt,s,w;
410: Z z;
411:
412: n = b->len; nv = x->len; p = (DL *)BDY(b);
413: hp = (P)ONE;
414: for ( i = 0; i < n; i++ ) {
415: for ( j = 0; j < nv; j++ )
416: if ( p[i]->d[j] ) break;
417: STOZ(p[i]->d[j],z);
418: chsgnp(t,&mt); mt->dc->d =z;
419: addp(CO,mt,(P)ONE,&s); mulp(CO,hp,s,&w); hp = w;
420: }
421: return hp;
422: }
423:
424: struct oEGT eg_comp;
425:
426: void mhp_rec(VECT b,VECT x,P t,P *r)
427: {
428: int n,i,j,k,l,i2,nv,len;
429: int *d;
430: Z mone,z;
431: DCP dc,dc1;
432: P s;
433: P *r2;
434: DL *p,*q;
435: DL pi,xj,d1;
436: VECT c;
437: struct oEGT eg0,eg1;
438:
439: i_all++;
440: n = b->len; nv = x->len; p = (DL *)BDY(b);
441: if ( !n ) {
442: r[0] = (P)ONE;
443: return;
444: }
445: if ( n == 1 && p[0]->td == 0 )
446: return;
447: for ( i = 0; i < n; i++ )
448: if ( p[i]->td > 1 ) break;
449: if ( i == n ) {
450: r[n] = (P)ONE;
451: return;
452: }
453: #if 0
454: if ( simple_check(b,nv) ) {
455: i_simple++;
456: r[0] = mhp_simple(b,x,t);
457: return;
458: }
459: #endif
460: for ( j = 0, d = p[i]->d; j < nv; j++ )
461: if ( d[j] ) break;
462: xj = BDY(x)[j];
463: MKVECT(c,n); q = (DL *)BDY(c);
464: for ( i = k = l = 0; i < n; i++ )
465: if ( p[i]->d[j] ) {
466: pi = p[i];
467: NEWDL(d1,nv); d1->td =pi->td - 1;
468: memcpy(d1->d,pi->d,nv*sizeof(int));
469: d1->d[j]--;
470: p[k++] = d1;
471: } else
472: q[l++] = p[i];
473: for ( i = k, i2 = 0; i2 < l; i++, i2++ )
474: p[i] = q[i2];
475: /* b=(b[0]/xj,...,b[k-1]/xj,b[k],...b[n-1]) where
476: b[0],...,b[k-1] are divisible by k */
477: make_reduced2(b,k,nv);
478: mhp_rec(b,x,t,r);
479: /* c = (b[0],...,b[l-1],xj) */
480: q[l] = xj; c->len = l+1;
481: r2 = (P *)CALLOC(nv+1,sizeof(P));
482: mhp_rec(c,x,t,r2);
483: // get_eg(&eg0);
484: for ( i = 0; i <= nv; i++ ) {
485: mulp(CO,r[i],t,&s); addp(CO,s,r2[i],&r[i]);
486: }
487: // get_eg(&eg1); add_eg(&eg_comp,&eg0,&eg1);
488: }
489:
1.4 noro 490: /* (n+a)Cb as a polynomial of n; return (n+a)*...*(n+a-b+1) */
491:
492: P binpoly(P n,int a,int b)
493: {
494: Z z;
495: P s,r,t;
496: int i;
497:
498: STOZ(a,z); addp(CO,n,(P)z,&s); r = (P)ONE;
499: for ( i = 0; i < b; i++ ) {
500: mulp(CO,r,s,&t); r = t;
501: subp(CO,s,(P)ONE,&t); s = t;
502: }
503: return r;
504: }
505:
1.8 ! noro 506: void mhp_to_hf(VL vl,P hp,int n,P *plist,VECT *head,P *hf)
1.5 noro 507: {
508: P tv,gcd,q,h,hphead,tt,ai,hpoly,nv,bp,w;
1.8 ! noro 509: Z d,z;
1.5 noro 510: DCP dc,topdc;
511: VECT hfhead;
512: int i,s,qd;
513:
514: if ( !hp ) {
515: MKVECT(hfhead,0); *head = hfhead;
1.8 ! noro 516: *hf = 0;
1.5 noro 517: } else {
518: makevar("t",&tv);
519: ezgcdp(CO,hp,plist[n],&gcd);
520: if ( NUM(gcd) ) {
521: s = n;
522: q = hp;
523: } else {
524: s = n-ZTOS(DEG(DC(gcd)));
525: divsp(CO,hp,plist[n-s],&q);
526: }
527: if ( NUM(q) ) qd = 0;
528: else qd = ZTOS(DEG(DC(q)));
1.6 noro 529: if ( s == 0 ) {
530: MKVECT(hfhead,qd+1);
531: for ( i = 0; i <= qd; i++ ) {
532: coefp(q,i,(P *)&BDY(hfhead)[i]);
1.5 noro 533: }
1.6 noro 534: *head = hfhead;
535: *hf = 0;
536: } else {
537: if ( qd ) {
538: topdc = 0;
539: for ( i = 0; i < qd; i++ ) {
540: NEWDC(dc); NEXT(dc) = topdc;
541: ibin(i+s-1,s-1,&COEF(dc));
542: STOZ(i,d); DEG(dc) = d;
543: topdc = dc;
544: }
545: MKP(VR(tv),topdc,h);
546: mulp(CO,h,q,&hphead);
547: }
548: MKVECT(hfhead,qd);
549: for ( i = 0; i < qd; i++ )
550: coefp(hphead,i,(P *)&BDY(hfhead)[i]);
551: *head = hfhead;
552: hpoly = 0;
553: makevar("n",&nv);
554: for ( i = 0; i <= qd; i++ ) {
555: coefp(q,i,&ai);
556: bp = binpoly(nv,s-i-1,s-1);
557: mulp(CO,ai,bp,&tt);
558: addp(CO,hpoly,tt,&w);
559: hpoly = w;
560: }
1.8 ! noro 561: if ( s > 2 ) {
! 562: factorialz(s-1,&z);
! 563: divsp(CO,hpoly,(P)z,&tt); hpoly = tt;
! 564: }
1.6 noro 565: *hf = hpoly;
1.8 ! noro 566: for ( i = qd-1; i >= 0; i-- ) {
! 567: UTOZ(i,z);
! 568: substp(CO,hpoly,VR(nv),(P)z,&tt);
! 569: if ( cmpz((Z)tt,(Z)BDY(hfhead)[i]) ) break;
! 570: }
! 571: hfhead->len = i+1;
1.5 noro 572: }
573: }
574: }
575:
576: /* create (1,1-t,...,(1-t)^n) */
577:
578: P *mhp_prep(int n,P *tv) {
579: P *plist;
580: P mt,t1;
581: int i;
582:
583: plist = (P *)MALLOC((n+1)*sizeof(P));
584: /* t1 = 1-t */
585: makevar("t",tv); chsgnp(*tv,&mt); addp(CO,mt,(P)ONE,&t1);
586: for ( plist[0] = (P)ONE, i = 1; i <= n; i++ )
587: mulp(CO,plist[i-1],t1,&plist[i]);
588: return plist;
589: }
590:
591: P mhp_ctop(P *r,P *plist,int n)
592: {
593: int i;
594: P hp,u,w;
595:
596: for ( hp = 0, i = 0; i <= n; i++ ) {
597: mulp(CO,plist[i],r[i],&u); addp(CO,u,hp,&w); hp = w;
598: }
599: return hp;
600: }
601:
1.3 noro 602: void Pdp_monomial_hilbert_poincare(NODE arg,LIST *rp)
603: {
604: LIST g,v;
605: VL vl;
1.5 noro 606: int m,n,i;
607: VECT b,x,hfhead;
1.3 noro 608: NODE t,nd;
1.5 noro 609: Z z,den;
610: P hp,tv,mt,t1,u,w,hpoly;
1.3 noro 611: DP a;
612: DL *p;
613: P *plist,*r;
1.4 noro 614: Obj val;
1.3 noro 615:
616: i_simple = i_all = 0;
617: g = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
618: pltovl(v,&vl);
619: m = length(BDY(g)); MKVECT(b,m); p = (DL *)BDY(b);
620: for ( t = BDY(g), i = 0; t; t = NEXT(t), i++ ) {
1.5 noro 621: if ( !BDY(t) )
622: p[i] = 0;
623: else {
624: ptod(CO,vl,(P)BDY(t),&a); p[i] = BDY(a)->dl;
625: }
1.3 noro 626: }
627: n = length(BDY(v)); MKVECT(x,n); p = (DL *)BDY(x);
628: for ( t = BDY(v), i = 0; t; t = NEXT(t), i++ ) {
629: ptod(CO,vl,(P)BDY(t),&a); p[i] = BDY(a)->dl;
630: }
1.5 noro 631:
1.3 noro 632: r = (P *)CALLOC(n+1,sizeof(P));
1.5 noro 633: plist = mhp_prep(n,&tv);
1.3 noro 634: make_reduced(b,n);
635: mhp_rec(b,x,tv,r);
1.5 noro 636: hp = mhp_ctop(r,plist,n);
1.8 ! noro 637: mhp_to_hf(CO,hp,n,plist,&hfhead,&hpoly);
1.4 noro 638: UTOZ(n,z);
1.8 ! noro 639: nd = mknode(4,hp,z,hfhead,hpoly);
1.5 noro 640: MKLIST(*rp,nd);
1.3 noro 641: }
1.5 noro 642:
1.1 noro 643: void Pdp_compute_last_t(NODE arg,LIST *rp)
644: {
645: NODE g,gh,homo,n;
646: LIST hlist;
647: VECT v1,v2,w;
648: Q t;
649:
650: g = (NODE)BDY((LIST)ARG0(arg));
651: gh = (NODE)BDY((LIST)ARG1(arg));
652: t = (Q)ARG2(arg);
653: v1 = (VECT)ARG3(arg);
654: v2 = (VECT)ARG4(arg);
655: t = compute_last_t(g,gh,t,v1,v2,&homo,&w);
656: MKLIST(hlist,homo);
657: n = mknode(3,t,w,hlist);
658: MKLIST(*rp,n);
659: }
660:
661: void Pdp_compute_last_w(NODE arg,LIST *rp)
662: {
663: NODE g,gh,r;
664: VECT w,rv;
665: LIST l;
666: MAT w1,w2;
667: int row1,row2,i,j,n;
668: int *v;
669: int **m1,**m2;
670: Z q;
671:
672: g = (NODE)BDY((LIST)ARG0(arg));
673: gh = (NODE)BDY((LIST)ARG1(arg));
674: w = (VECT)ARG2(arg);
675: w1 = (MAT)ARG3(arg);
676: w2 = (MAT)ARG4(arg);
677: n = w1->col;
678: row1 = w1->row;
679: row2 = w2->row;
680: if ( w ) {
681: v = W_ALLOC(n);
1.2 noro 682: for ( i = 0; i < n; i++ ) v[i] = ZTOS((Q)w->body[i]);
1.1 noro 683: } else v = 0;
684: m1 = almat(row1,n);
685: for ( i = 0; i < row1; i++ )
1.2 noro 686: for ( j = 0; j < n; j++ ) m1[i][j] = ZTOS((Q)w1->body[i][j]);
1.1 noro 687: m2 = almat(row2,n);
688: for ( i = 0; i < row2; i++ )
1.2 noro 689: for ( j = 0; j < n; j++ ) m2[i][j] = ZTOS((Q)w2->body[i][j]);
1.1 noro 690: r = compute_last_w(g,gh,n,&v,row1,m1,row2,m2);
691: if ( !r ) *rp = 0;
692: else {
693: MKVECT(rv,n);
694: for ( i = 0; i < n; i++ ) {
1.2 noro 695: STOZ(v[i],q); rv->body[i] = (pointer)q;
1.1 noro 696: }
697: MKLIST(l,r);
698: r = mknode(2,rv,l);
699: MKLIST(*rp,r);
700: }
701: }
702:
703: NODE compute_essential_df(DP *g,DP *gh,int n);
704:
705: void Pdp_compute_essential_df(NODE arg,LIST *rp)
706: {
707: VECT g,gh;
708: NODE r;
709:
710: g = (VECT)ARG0(arg);
711: gh = (VECT)ARG1(arg);
712: r = (NODE)compute_essential_df((DP *)BDY(g),(DP *)BDY(gh),g->len);
713: MKLIST(*rp,r);
714: }
715:
716: void Pdp_inv_or_split(NODE arg,Obj *rp)
717: {
718: NODE gb,newgb;
719: DP f,inv;
720: struct order_spec *spec;
721: LIST list;
722:
723: do_weyl = 0; dp_fcoeffs = 0;
724: asir_assert(ARG0(arg),O_LIST,"dp_inv_or_split");
725: asir_assert(ARG1(arg),O_DP,"dp_inv_or_split");
726: if ( !create_order_spec(0,(Obj)ARG2(arg),&spec) )
727: error("dp_inv_or_split : invalid order specification");
728: gb = BDY((LIST)ARG0(arg));
729: f = (DP)ARG1(arg);
730: newgb = (NODE)dp_inv_or_split(gb,f,spec,&inv);
731: if ( !newgb ) {
732: /* invertible */
733: *rp = (Obj)inv;
734: } else {
735: MKLIST(list,newgb);
736: *rp = (Obj)list;
737: }
738: }
739:
740: void Pdp_sort(NODE arg,DP *rp)
741: {
742: dp_sort((DP)ARG0(arg),rp);
743: }
744:
745: void Pdp_mdtod(NODE arg,DP *rp)
746: {
747: MP m,mr,mr0;
748: DP p;
749: P t;
750:
751: p = (DP)ARG0(arg);
752: if ( !p )
753: *rp = 0;
754: else {
755: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
756: mptop((P)m->c,&t); NEXTMP(mr0,mr); mr->c = (Obj)t; mr->dl = m->dl;
757: }
758: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
759: }
760: }
761:
762: void Pdp_sep(NODE arg,VECT *rp)
763: {
764: DP p,r;
765: MP m,t;
766: MP *w0,*w;
767: int i,n,d,nv,sugar;
768: VECT v;
769: pointer *pv;
770:
771: p = (DP)ARG0(arg); m = BDY(p);
1.2 noro 772: d = ZTOS((Q)ARG1(arg));
1.1 noro 773: for ( t = m, n = 0; t; t = NEXT(t), n++ );
774: if ( d > n )
775: d = n;
776: MKVECT(v,d); *rp = v;
777: pv = BDY(v); nv = p->nv; sugar = p->sugar;
778: w0 = (MP *)MALLOC(d*sizeof(MP)); bzero(w0,d*sizeof(MP));
779: w = (MP *)MALLOC(d*sizeof(MP)); bzero(w,d*sizeof(MP));
780: for ( t = BDY(p), i = 0; t; t = NEXT(t), i++, i %= d ) {
781: NEXTMP(w0[i],w[i]); w[i]->c = t->c; w[i]->dl = t->dl;
782: }
783: for ( i = 0; i < d; i++ ) {
784: NEXT(w[i]) = 0; MKDP(nv,w0[i],r); r->sugar = sugar;
785: pv[i] = (pointer)r;
786: }
787: }
788:
789: void Pdp_idiv(NODE arg,DP *rp)
790: {
791: dp_idiv((DP)ARG0(arg),(Z)ARG1(arg),rp);
792: }
793:
794: void Pdp_cont(NODE arg,Z *rp)
795: {
796: dp_cont((DP)ARG0(arg),rp);
797: }
798:
799: void Pdp_dtov(NODE arg,VECT *rp)
800: {
801: dp_dtov((DP)ARG0(arg),rp);
802: }
803:
804: void Pdp_mbase(NODE arg,LIST *rp)
805: {
806: NODE mb;
807:
808: asir_assert(ARG0(arg),O_LIST,"dp_mbase");
809: dp_mbase(BDY((LIST)ARG0(arg)),&mb);
810: MKLIST(*rp,mb);
811: }
812:
813: void Pdp_etov(NODE arg,VECT *rp)
814: {
815: DP dp;
816: int n,i;
817: int *d;
818: VECT v;
819: Z t;
820:
821: dp = (DP)ARG0(arg);
822: asir_assert(dp,O_DP,"dp_etov");
823: n = dp->nv; d = BDY(dp)->dl->d;
824: MKVECT(v,n);
825: for ( i = 0; i < n; i++ ) {
1.2 noro 826: STOZ(d[i],t); v->body[i] = (pointer)t;
1.1 noro 827: }
828: *rp = v;
829: }
830:
831: void Pdp_vtoe(NODE arg,DP *rp)
832: {
833: DP dp;
834: DL dl;
835: MP m;
836: int n,i,td;
837: int *d;
838: VECT v;
839:
840: v = (VECT)ARG0(arg);
841: asir_assert(v,O_VECT,"dp_vtoe");
842: n = v->len;
843: NEWDL(dl,n); d = dl->d;
844: for ( i = 0, td = 0; i < n; i++ ) {
1.2 noro 845: d[i] = ZTOS((Q)(v->body[i])); td += MUL_WEIGHT(d[i],i);
1.1 noro 846: }
847: dl->td = td;
848: NEWMP(m); m->dl = dl; m->c = (Obj)ONE; NEXT(m) = 0;
849: MKDP(n,m,dp); dp->sugar = td;
850: *rp = dp;
851: }
852:
853: void Pdp_lnf_mod(NODE arg,LIST *rp)
854: {
855: DP r1,r2;
856: NODE b,g,n;
857: int mod;
858:
859: asir_assert(ARG0(arg),O_LIST,"dp_lnf_mod");
860: asir_assert(ARG1(arg),O_LIST,"dp_lnf_mod");
861: asir_assert(ARG2(arg),O_N,"dp_lnf_mod");
862: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
1.2 noro 863: mod = ZTOS((Q)ARG2(arg));
1.1 noro 864: dp_lnf_mod((DP)BDY(b),(DP)BDY(NEXT(b)),g,mod,&r1,&r2);
865: NEWNODE(n); BDY(n) = (pointer)r1;
866: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
867: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
868: }
869:
870: void Pdp_lnf_f(NODE arg,LIST *rp)
871: {
872: DP r1,r2;
873: NODE b,g,n;
874:
875: asir_assert(ARG0(arg),O_LIST,"dp_lnf_f");
876: asir_assert(ARG1(arg),O_LIST,"dp_lnf_f");
877: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
878: dp_lnf_f((DP)BDY(b),(DP)BDY(NEXT(b)),g,&r1,&r2);
879: NEWNODE(n); BDY(n) = (pointer)r1;
880: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
881: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
882: }
883:
884: void Pdp_nf_tab_mod(NODE arg,DP *rp)
885: {
886: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_mod");
887: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_mod");
888: asir_assert(ARG2(arg),O_N,"dp_nf_tab_mod");
889: dp_nf_tab_mod((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),
1.2 noro 890: ZTOS((Q)ARG2(arg)),rp);
1.1 noro 891: }
892:
893: void Pdp_nf_tab_f(NODE arg,DP *rp)
894: {
895: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_f");
896: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_f");
897: dp_nf_tab_f((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),rp);
898: }
899:
900: void Pdp_ord(NODE arg,Obj *rp)
901: {
902: struct order_spec *spec;
903: LIST v;
904: struct oLIST f;
905: Num homo;
906: int modular;
907:
908: f.id = O_LIST; f.body = 0;
909: if ( !arg && !current_option )
910: *rp = dp_current_spec->obj;
911: else {
912: if ( current_option )
913: parse_gr_option(&f,current_option,&v,&homo,&modular,&spec);
914: else if ( !create_order_spec(0,(Obj)ARG0(arg),&spec) )
915: error("dp_ord : invalid order specification");
916: initd(spec); *rp = spec->obj;
917: }
918: }
919:
920: void Pdp_ptod(NODE arg,DP *rp)
921: {
922: P p;
923: NODE n;
924: VL vl,tvl;
925: struct oLIST f;
926: int ac;
927: LIST v;
928: Num homo;
929: int modular;
930: struct order_spec *ord;
931:
932: asir_assert(ARG0(arg),O_P,"dp_ptod");
933: p = (P)ARG0(arg);
934: ac = argc(arg);
935: if ( ac == 1 ) {
936: if ( current_option ) {
937: f.id = O_LIST; f.body = mknode(1,p);
938: parse_gr_option(&f,current_option,&v,&homo,&modular,&ord);
939: initd(ord);
940: } else
941: error("dp_ptod : invalid argument");
942: } else {
943: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
944: v = (LIST)ARG1(arg);
945: }
946: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
947: if ( !vl ) {
948: NEWVL(vl); tvl = vl;
949: } else {
950: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
951: }
952: VR(tvl) = VR((P)BDY(n));
953: }
954: if ( vl )
955: NEXT(tvl) = 0;
956: ptod(CO,vl,p,rp);
957: }
958:
959: void Phomogenize(NODE arg,Obj *rp)
960: {
961: P p;
962: DP d,h;
963: NODE n;
964: V hv;
965: VL vl,tvl,last;
966: struct oLIST f;
967: LIST v;
968:
969: asir_assert(ARG0(arg),O_P,"homogenize");
970: p = (P)ARG0(arg);
971: asir_assert(ARG1(arg),O_LIST,"homogenize");
972: v = (LIST)ARG1(arg);
973: asir_assert(ARG2(arg),O_P,"homogenize");
974: hv = VR((P)ARG2(arg));
975: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
976: if ( !vl ) {
977: NEWVL(vl); tvl = vl;
978: } else {
979: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
980: }
981: VR(tvl) = VR((P)BDY(n));
982: }
983: if ( vl ) {
984: last = tvl;
985: NEXT(tvl) = 0;
986: }
987: ptod(CO,vl,p,&d);
988: dp_homo(d,&h);
989: NEWVL(NEXT(last)); last = NEXT(last);
990: VR(last) = hv; NEXT(last) = 0;
991: dtop(CO,vl,h,rp);
992: }
993:
994: void Pdp_ltod(NODE arg,DPV *rp)
995: {
996: NODE n;
997: VL vl,tvl;
998: LIST f,v;
999: int sugar,i,len,ac,modular;
1000: Num homo;
1001: struct order_spec *ord;
1002: DP *e;
1003: NODE nd,t;
1004:
1005: ac = argc(arg);
1006: asir_assert(ARG0(arg),O_LIST,"dp_ptod");
1007: f = (LIST)ARG0(arg);
1008: if ( ac == 1 ) {
1009: if ( current_option ) {
1010: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1011: initd(ord);
1012: } else
1013: error("dp_ltod : invalid argument");
1014: } else {
1015: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
1016: v = (LIST)ARG1(arg);
1017: }
1018: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
1019: if ( !vl ) {
1020: NEWVL(vl); tvl = vl;
1021: } else {
1022: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
1023: }
1024: VR(tvl) = VR((P)BDY(n));
1025: }
1026: if ( vl )
1027: NEXT(tvl) = 0;
1028:
1029: nd = BDY(f);
1030: len = length(nd);
1031: e = (DP *)MALLOC(len*sizeof(DP));
1032: sugar = 0;
1033: for ( i = 0, t = nd; i < len; i++, t = NEXT(t) ) {
1034: ptod(CO,vl,(P)BDY(t),&e[i]);
1035: if ( e[i] )
1036: sugar = MAX(sugar,e[i]->sugar);
1037: }
1038: MKDPV(len,e,*rp);
1039: }
1040:
1041: void Pdpm_ltod(NODE arg,DPM *rp)
1042: {
1043: NODE n;
1044: VL vl,tvl;
1045: LIST f,v;
1046: int i,len;
1047: NODE nd;
1048: NODE t;
1049: DP d;
1050: DPM s,u,w;
1051:
1052: f = (LIST)ARG0(arg);
1053: v = (LIST)ARG1(arg);
1054: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
1055: if ( !vl ) {
1056: NEWVL(vl); tvl = vl;
1057: } else {
1058: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
1059: }
1060: VR(tvl) = VR((P)BDY(n));
1061: }
1062: if ( vl )
1063: NEXT(tvl) = 0;
1064:
1065: nd = BDY(f);
1066: len = length(nd);
1067: for ( i = 0, t = nd, s = 0; i < len; i++, t = NEXT(t) ) {
1068: ptod(CO,vl,(P)BDY(t),&d);
1069: dtodpm(d,i,&u);
1070: adddpm(CO,s,u,&w); s = w;
1071: }
1072: *rp = s;
1073: }
1074:
1075: void Pdpm_dtol(NODE arg,LIST *rp)
1076: {
1077: DPM a;
1078: NODE nd,nd1;
1079: VL vl,tvl;
1080: int n,len,i,pos,nv;
1081: MP *w;
1082: DMM t;
1083: DMM *wa;
1084: MP m;
1085: DP u;
1086: Obj s;
1087:
1088: a = (DPM)ARG0(arg);
1089: for ( vl = 0, nd = BDY((LIST)ARG1(arg)), nv = 0; nd; nd = NEXT(nd), nv++ ) {
1090: if ( !vl ) {
1091: NEWVL(vl); tvl = vl;
1092: } else {
1093: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
1094: }
1095: VR(tvl) = VR((P)BDY(nd));
1096: }
1097: if ( vl )
1098: NEXT(tvl) = 0;
1.2 noro 1099: n = ZTOS((Q)ARG2(arg));
1.1 noro 1100: w = (MP *)CALLOC(n,sizeof(MP));
1101: for ( t = BDY(a), len = 0; t; t = NEXT(t) ) len++;
1102: wa = (DMM *)MALLOC(len*sizeof(DMM));
1103: for ( t = BDY(a), i = 0; t; t = NEXT(t), i++ ) wa[i] = t;
1104: for ( i = len-1; i >= 0; i-- ) {
1105: NEWMP(m); m->dl = wa[i]->dl; C(m) = C(wa[i]);
1106: pos = wa[i]->pos;
1107: NEXT(m) = w[pos];
1108: w[pos] = m;
1109: }
1110: nd = 0;
1111: for ( i = n-1; i >= 0; i-- ) {
1112: MKDP(nv,w[i],u); u->sugar = a->sugar; /* XXX */
1113: dtop(CO,vl,u,&s);
1114: MKNODE(nd1,s,nd); nd = nd1;
1115: }
1116: MKLIST(*rp,nd);
1117: }
1118:
1119: void Pdp_dtop(NODE arg,Obj *rp)
1120: {
1121: NODE n;
1122: VL vl,tvl;
1123:
1124: asir_assert(ARG0(arg),O_DP,"dp_dtop");
1125: asir_assert(ARG1(arg),O_LIST,"dp_dtop");
1126: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
1127: if ( !vl ) {
1128: NEWVL(vl); tvl = vl;
1129: } else {
1130: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
1131: }
1132: VR(tvl) = VR((P)BDY(n));
1133: }
1134: if ( vl )
1135: NEXT(tvl) = 0;
1136: dtop(CO,vl,(DP)ARG0(arg),rp);
1137: }
1138:
1139: extern LIST Dist;
1140:
1141: void Pdp_ptozp(NODE arg,Obj *rp)
1142: {
1143: Z t;
1144: NODE tt,p;
1145: NODE n,n0;
1146: char *key;
1147: DP pp;
1148: LIST list;
1149: int get_factor=0;
1150:
1151: asir_assert(ARG0(arg),O_DP,"dp_ptozp");
1152:
1153: /* analyze the option */
1154: if ( current_option ) {
1155: for ( tt = current_option; tt; tt = NEXT(tt) ) {
1156: p = BDY((LIST)BDY(tt));
1157: key = BDY((STRING)BDY(p));
1158: /* value = (Obj)BDY(NEXT(p)); */
1159: if ( !strcmp(key,"factor") ) get_factor=1;
1160: else {
1161: error("ptozp: unknown option.");
1162: }
1163: }
1164: }
1165:
1166: dp_ptozp3((DP)ARG0(arg),&t,&pp);
1167:
1168: /* printexpr(NULL,t); */
1169: /* if the option factor is given, then it returns the answer
1170: in the format [zpoly, num] where num*zpoly is equal to the argument.*/
1171: if (get_factor) {
1172: n0 = mknode(2,pp,t);
1173: MKLIST(list,n0);
1174: *rp = (Obj)list;
1175: } else
1176: *rp = (Obj)pp;
1177: }
1178:
1179: void Pdp_ptozp2(NODE arg,LIST *rp)
1180: {
1181: DP p0,p1,h,r;
1182: NODE n0;
1183:
1184: p0 = (DP)ARG0(arg); p1 = (DP)ARG1(arg);
1185: asir_assert(p0,O_DP,"dp_ptozp2");
1186: asir_assert(p1,O_DP,"dp_ptozp2");
1187: dp_ptozp2(p0,p1,&h,&r);
1188: NEWNODE(n0); BDY(n0) = (pointer)h;
1189: NEWNODE(NEXT(n0)); BDY(NEXT(n0)) = (pointer)r;
1190: NEXT(NEXT(n0)) = 0;
1191: MKLIST(*rp,n0);
1192: }
1193:
1194: void Pdp_prim(NODE arg,DP *rp)
1195: {
1196: DP t;
1197:
1198: asir_assert(ARG0(arg),O_DP,"dp_prim");
1199: dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
1200: }
1201:
1202: void Pdp_mod(NODE arg,DP *rp)
1203: {
1204: DP p;
1205: int mod;
1206: NODE subst;
1207:
1208: asir_assert(ARG0(arg),O_DP,"dp_mod");
1209: asir_assert(ARG1(arg),O_N,"dp_mod");
1210: asir_assert(ARG2(arg),O_LIST,"dp_mod");
1.2 noro 1211: p = (DP)ARG0(arg); mod = ZTOS((Q)ARG1(arg));
1.1 noro 1212: subst = BDY((LIST)ARG2(arg));
1213: dp_mod(p,mod,subst,rp);
1214: }
1215:
1216: void Pdp_rat(NODE arg,DP *rp)
1217: {
1218: asir_assert(ARG0(arg),O_DP,"dp_rat");
1219: dp_rat((DP)ARG0(arg),rp);
1220: }
1221:
1222: extern int DP_Multiple;
1223:
1224: void Pdp_nf(NODE arg,DP *rp)
1225: {
1226: NODE b;
1227: DP *ps;
1228: DP g;
1229: int full;
1230:
1231: do_weyl = 0; dp_fcoeffs = 0;
1232: asir_assert(ARG0(arg),O_LIST,"dp_nf");
1233: asir_assert(ARG1(arg),O_DP,"dp_nf");
1234: asir_assert(ARG2(arg),O_VECT,"dp_nf");
1235: asir_assert(ARG3(arg),O_N,"dp_nf");
1236: if ( !(g = (DP)ARG1(arg)) ) {
1237: *rp = 0; return;
1238: }
1239: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
1240: full = (Q)ARG3(arg) ? 1 : 0;
1241: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
1242: }
1243:
1244: void Pdp_weyl_nf(NODE arg,DP *rp)
1245: {
1246: NODE b;
1247: DP *ps;
1248: DP g;
1249: int full;
1250:
1251: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf");
1252: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf");
1253: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf");
1254: asir_assert(ARG3(arg),O_N,"dp_weyl_nf");
1255: if ( !(g = (DP)ARG1(arg)) ) {
1256: *rp = 0; return;
1257: }
1258: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
1259: full = (Q)ARG3(arg) ? 1 : 0;
1260: do_weyl = 1;
1261: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
1262: do_weyl = 0;
1263: }
1264:
1265: void Pdpm_nf(NODE arg,DPM *rp)
1266: {
1267: NODE b;
1268: DPM *ps;
1269: DPM g;
1270: int full;
1271:
1272: if ( !(g = (DPM)ARG1(arg)) ) {
1273: *rp = 0; return;
1274: }
1275: do_weyl = 0; dp_fcoeffs = 0;
1276: asir_assert(ARG0(arg),O_LIST,"dpm_nf");
1277: asir_assert(ARG1(arg),O_DPM,"dpm_nf");
1278: asir_assert(ARG2(arg),O_VECT,"dpm_nf");
1279: asir_assert(ARG3(arg),O_N,"dpm_nf");
1280: b = BDY((LIST)ARG0(arg)); ps = (DPM *)BDY((VECT)ARG2(arg));
1281: full = (Q)ARG3(arg) ? 1 : 0;
1282: dpm_nf_z(b,g,ps,full,DP_Multiple,rp);
1283: }
1284:
1285: void Pdpm_weyl_nf(NODE arg,DPM *rp)
1286: {
1287: NODE b;
1288: DPM *ps;
1289: DPM g;
1290: int full;
1291:
1292: if ( !(g = (DPM)ARG1(arg)) ) {
1293: *rp = 0; return;
1294: }
1295: asir_assert(ARG0(arg),O_LIST,"dpm_weyl_nf");
1296: asir_assert(ARG1(arg),O_DPM,"dpm_weyl_nf");
1297: asir_assert(ARG2(arg),O_VECT,"dpm_weyl_nf");
1298: asir_assert(ARG3(arg),O_N,"dpm_weyl_nf");
1299: b = BDY((LIST)ARG0(arg)); ps = (DPM *)BDY((VECT)ARG2(arg));
1300: full = (Q)ARG3(arg) ? 1 : 0;
1301: do_weyl = 1;
1302: dpm_nf_z(b,g,ps,full,DP_Multiple,rp);
1303: do_weyl = 0;
1304: }
1305:
1306: /* nf computation using field operations */
1307:
1308: void Pdp_nf_f(NODE arg,DP *rp)
1309: {
1310: NODE b;
1311: DP *ps;
1312: DP g;
1313: int full;
1314:
1315: do_weyl = 0;
1316: asir_assert(ARG0(arg),O_LIST,"dp_nf_f");
1317: asir_assert(ARG1(arg),O_DP,"dp_nf_f");
1318: asir_assert(ARG2(arg),O_VECT,"dp_nf_f");
1319: asir_assert(ARG3(arg),O_N,"dp_nf_f");
1320: if ( !(g = (DP)ARG1(arg)) ) {
1321: *rp = 0; return;
1322: }
1323: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
1324: full = (Q)ARG3(arg) ? 1 : 0;
1325: dp_nf_f(b,g,ps,full,rp);
1326: }
1327:
1328: void Pdp_weyl_nf_f(NODE arg,DP *rp)
1329: {
1330: NODE b;
1331: DP *ps;
1332: DP g;
1333: int full;
1334:
1335: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_f");
1336: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_f");
1337: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_f");
1338: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_f");
1339: if ( !(g = (DP)ARG1(arg)) ) {
1340: *rp = 0; return;
1341: }
1342: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
1343: full = (Q)ARG3(arg) ? 1 : 0;
1344: do_weyl = 1;
1345: dp_nf_f(b,g,ps,full,rp);
1346: do_weyl = 0;
1347: }
1348:
1349: void Pdpm_nf_f(NODE arg,DPM *rp)
1350: {
1351: NODE b;
1352: DPM *ps;
1353: DPM g;
1354: int full;
1355:
1356: if ( !(g = (DPM)ARG1(arg)) ) {
1357: *rp = 0; return;
1358: }
1359: asir_assert(ARG0(arg),O_LIST,"dpm_nf_f");
1360: asir_assert(ARG1(arg),O_DPM,"dpm_nf_f");
1361: asir_assert(ARG2(arg),O_VECT,"dpm_nf_f");
1362: asir_assert(ARG3(arg),O_N,"dpm_nf_f");
1363: b = BDY((LIST)ARG0(arg)); ps = (DPM *)BDY((VECT)ARG2(arg));
1364: full = (Q)ARG3(arg) ? 1 : 0;
1365: dpm_nf_f(b,g,ps,full,rp);
1366: }
1367:
1368: void Pdpm_weyl_nf_f(NODE arg,DPM *rp)
1369: {
1370: NODE b;
1371: DPM *ps;
1372: DPM g;
1373: int full;
1374:
1375: if ( !(g = (DPM)ARG1(arg)) ) {
1376: *rp = 0; return;
1377: }
1378: asir_assert(ARG0(arg),O_LIST,"dpm_weyl_nf_f");
1379: asir_assert(ARG1(arg),O_DP,"dpm_weyl_nf_f");
1380: asir_assert(ARG2(arg),O_VECT,"dpm_weyl_nf_f");
1381: asir_assert(ARG3(arg),O_N,"dpm_weyl_nf_f");
1382: b = BDY((LIST)ARG0(arg)); ps = (DPM *)BDY((VECT)ARG2(arg));
1383: full = (Q)ARG3(arg) ? 1 : 0;
1384: do_weyl = 1;
1385: dpm_nf_f(b,g,ps,full,rp);
1386: do_weyl = 0;
1387: }
1388:
1389:
1390: void Pdp_nf_mod(NODE arg,DP *rp)
1391: {
1392: NODE b;
1393: DP g;
1394: DP *ps;
1395: int mod,full,ac;
1396: NODE n,n0;
1397:
1398: do_weyl = 0;
1399: ac = argc(arg);
1400: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
1401: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
1402: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
1403: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
1404: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
1405: if ( !(g = (DP)ARG1(arg)) ) {
1406: *rp = 0; return;
1407: }
1408: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
1.2 noro 1409: full = ZTOS((Q)ARG3(arg)); mod = ZTOS((Q)ARG4(arg));
1.1 noro 1410: for ( n0 = n = 0; b; b = NEXT(b) ) {
1411: NEXTNODE(n0,n);
1.2 noro 1412: BDY(n) = (pointer)ZTOS((Q)BDY(b));
1.1 noro 1413: }
1414: if ( n0 )
1415: NEXT(n) = 0;
1416: dp_nf_mod(n0,g,ps,mod,full,rp);
1417: }
1418:
1419: void Pdp_true_nf(NODE arg,LIST *rp)
1420: {
1421: NODE b,n;
1422: DP *ps;
1423: DP g;
1424: DP nm;
1425: P dn;
1426: int full;
1427:
1428: do_weyl = 0; dp_fcoeffs = 0;
1429: asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
1430: asir_assert(ARG1(arg),O_DP,"dp_true_nf");
1431: asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
1432: asir_assert(ARG3(arg),O_N,"dp_nf");
1433: if ( !(g = (DP)ARG1(arg)) ) {
1434: nm = 0; dn = (P)ONE;
1435: } else {
1436: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
1437: full = (Q)ARG3(arg) ? 1 : 0;
1438: dp_true_nf(b,g,ps,full,&nm,&dn);
1439: }
1440: NEWNODE(n); BDY(n) = (pointer)nm;
1441: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
1442: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1443: }
1444:
1445: DP *dp_true_nf_and_quotient_marked(NODE b,DP g,DP *ps,DP *hps,DP *rp,P *dnp);
1446:
1447: void Pdp_true_nf_and_quotient_marked(NODE arg,LIST *rp)
1448: {
1449: NODE b,n;
1450: DP *ps,*hps;
1451: DP g;
1452: DP nm;
1453: VECT quo;
1454: P dn;
1455: int full;
1456:
1457: do_weyl = 0; dp_fcoeffs = 0;
1458: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_and_quotient_marked");
1459: asir_assert(ARG1(arg),O_DP,"dp_true_nf_and_quotient_marked");
1460: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_and_quotient_marked");
1461: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_and_quotient_marked");
1462: if ( !(g = (DP)ARG1(arg)) ) {
1463: nm = 0; dn = (P)ONE;
1464: } else {
1465: b = BDY((LIST)ARG0(arg));
1466: ps = (DP *)BDY((VECT)ARG2(arg));
1467: hps = (DP *)BDY((VECT)ARG3(arg));
1468: NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
1469: quo->body = (pointer *)dp_true_nf_and_quotient_marked(b,g,ps,hps,&nm,&dn);
1470: }
1471: n = mknode(3,nm,dn,quo);
1472: MKLIST(*rp,n);
1473: }
1474:
1475: void Pdp_true_nf_and_quotient(NODE arg,LIST *rp)
1476: {
1477: NODE narg = mknode(4,ARG0(arg),ARG1(arg),ARG2(arg),ARG2(arg));
1478: Pdp_true_nf_and_quotient_marked(narg,rp);
1479: }
1480:
1481:
1482: DP *dp_true_nf_and_quotient_marked_mod (NODE b,DP g,DP *ps,DP *hps,int mod,DP *rp,P *dnp);
1483:
1484: void Pdp_true_nf_and_quotient_marked_mod(NODE arg,LIST *rp)
1485: {
1486: NODE b,n;
1487: DP *ps,*hps;
1488: DP g;
1489: DP nm;
1490: VECT quo;
1491: P dn;
1492: int full,mod;
1493:
1494: do_weyl = 0; dp_fcoeffs = 0;
1495: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_and_quotient_marked_mod");
1496: asir_assert(ARG1(arg),O_DP,"dp_true_nf_and_quotient_marked_mod");
1497: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_and_quotient_marked_mod");
1498: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_and_quotient_marked_mod");
1499: asir_assert(ARG4(arg),O_N,"dp_true_nf_and_quotient_marked_mod");
1500: if ( !(g = (DP)ARG1(arg)) ) {
1501: nm = 0; dn = (P)ONE;
1502: } else {
1503: b = BDY((LIST)ARG0(arg));
1504: ps = (DP *)BDY((VECT)ARG2(arg));
1505: hps = (DP *)BDY((VECT)ARG3(arg));
1.2 noro 1506: mod = ZTOS((Q)ARG4(arg));
1.1 noro 1507: NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
1508: quo->body = (pointer *)dp_true_nf_and_quotient_marked_mod(b,g,ps,hps,mod,&nm,&dn);
1509: }
1510: n = mknode(3,nm,dn,quo);
1511: MKLIST(*rp,n);
1512: }
1513:
1514: void Pdp_true_nf_and_quotient_mod(NODE arg,LIST *rp)
1515: {
1516: NODE narg = mknode(5,ARG0(arg),ARG1(arg),ARG2(arg),ARG2(arg),ARG3(arg));
1517: Pdp_true_nf_and_quotient_marked_mod(narg,rp);
1518: }
1519:
1520: void Pdp_true_nf_marked(NODE arg,LIST *rp)
1521: {
1522: NODE b,n;
1523: DP *ps,*hps;
1524: DP g;
1525: DP nm;
1526: Q cont;
1527: P dn;
1528: int full;
1529:
1530: do_weyl = 0; dp_fcoeffs = 0;
1531: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_marked");
1532: asir_assert(ARG1(arg),O_DP,"dp_true_nf_marked");
1533: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_marked");
1534: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_marked");
1535: if ( !(g = (DP)ARG1(arg)) ) {
1536: nm = 0; dn = (P)ONE;
1537: } else {
1538: b = BDY((LIST)ARG0(arg));
1539: ps = (DP *)BDY((VECT)ARG2(arg));
1540: hps = (DP *)BDY((VECT)ARG3(arg));
1541: dp_true_nf_marked(b,g,ps,hps,&nm,(P *)&cont,(P *)&dn);
1542: }
1543: n = mknode(3,nm,cont,dn);
1544: MKLIST(*rp,n);
1545: }
1546:
1547: void Pdp_true_nf_marked_mod(NODE arg,LIST *rp)
1548: {
1549: NODE b,n;
1550: DP *ps,*hps;
1551: DP g;
1552: DP nm;
1553: P dn;
1554: int mod;
1555:
1556: do_weyl = 0; dp_fcoeffs = 0;
1557: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_marked_mod");
1558: asir_assert(ARG1(arg),O_DP,"dp_true_nf_marked_mod");
1559: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_marked_mod");
1560: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_marked_mod");
1561: asir_assert(ARG4(arg),O_N,"dp_true_nf_marked_mod");
1562: if ( !(g = (DP)ARG1(arg)) ) {
1563: nm = 0; dn = (P)ONE;
1564: } else {
1565: b = BDY((LIST)ARG0(arg));
1566: ps = (DP *)BDY((VECT)ARG2(arg));
1567: hps = (DP *)BDY((VECT)ARG3(arg));
1.2 noro 1568: mod = ZTOS((Q)ARG4(arg));
1.1 noro 1569: dp_true_nf_marked_mod(b,g,ps,hps,mod,&nm,&dn);
1570: }
1571: n = mknode(2,nm,dn);
1572: MKLIST(*rp,n);
1573: }
1574:
1575: void Pdp_weyl_nf_mod(NODE arg,DP *rp)
1576: {
1577: NODE b;
1578: DP g;
1579: DP *ps;
1580: int mod,full,ac;
1581: NODE n,n0;
1582:
1583: ac = argc(arg);
1584: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_mod");
1585: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_mod");
1586: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_mod");
1587: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_mod");
1588: asir_assert(ARG4(arg),O_N,"dp_weyl_nf_mod");
1589: if ( !(g = (DP)ARG1(arg)) ) {
1590: *rp = 0; return;
1591: }
1592: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
1.2 noro 1593: full = ZTOS((Q)ARG3(arg)); mod = ZTOS((Q)ARG4(arg));
1.1 noro 1594: for ( n0 = n = 0; b; b = NEXT(b) ) {
1595: NEXTNODE(n0,n);
1.2 noro 1596: BDY(n) = (pointer)ZTOS((Q)BDY(b));
1.1 noro 1597: }
1598: if ( n0 )
1599: NEXT(n) = 0;
1600: do_weyl = 1;
1601: dp_nf_mod(n0,g,ps,mod,full,rp);
1602: do_weyl = 0;
1603: }
1604:
1605: void Pdp_true_nf_mod(NODE arg,LIST *rp)
1606: {
1607: NODE b;
1608: DP g,nm;
1609: P dn;
1610: DP *ps;
1611: int mod,full;
1612: NODE n;
1613:
1614: do_weyl = 0;
1615: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
1616: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
1617: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
1618: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
1619: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
1620: if ( !(g = (DP)ARG1(arg)) ) {
1621: nm = 0; dn = (P)ONEM;
1622: } else {
1623: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
1.2 noro 1624: full = ZTOS((Q)ARG3(arg)); mod = ZTOS((Q)ARG4(arg));
1.1 noro 1625: dp_true_nf_mod(b,g,ps,mod,full,&nm,&dn);
1626: }
1627: NEWNODE(n); BDY(n) = (pointer)nm;
1628: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
1629: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1630: }
1631:
1632: void Pdp_weyl_true_nf_and_quotient_marked(NODE arg,LIST *rp)
1633: {
1634: NODE b,n;
1635: DP *ps,*hps;
1636: DP g;
1637: DP nm;
1638: VECT quo;
1639: P dn;
1640: int full;
1641:
1642: do_weyl = 1; dp_fcoeffs = 0;
1643: asir_assert(ARG0(arg),O_LIST,"dp_weyl_true_nf_and_quotient_marked");
1644: asir_assert(ARG1(arg),O_DP,"dp_weyl_true_nf_and_quotient_marked");
1645: asir_assert(ARG2(arg),O_VECT,"dp_weyl_true_nf_and_quotient_marked");
1646: asir_assert(ARG3(arg),O_VECT,"dp_weyl_true_nf_and_quotient_marked");
1647: if ( !(g = (DP)ARG1(arg)) ) {
1648: nm = 0; dn = (P)ONE;
1649: } else {
1650: b = BDY((LIST)ARG0(arg));
1651: ps = (DP *)BDY((VECT)ARG2(arg));
1652: hps = (DP *)BDY((VECT)ARG3(arg));
1653: NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
1654: quo->body = (pointer *)dp_true_nf_and_quotient_marked(b,g,ps,hps,&nm,&dn);
1655: }
1656: n = mknode(3,nm,dn,quo);
1657: MKLIST(*rp,n);
1658: }
1659:
1660: void Pdp_weyl_true_nf_and_quotient(NODE arg,LIST *rp)
1661: {
1662: NODE narg = mknode(4,ARG0(arg),ARG1(arg),ARG2(arg),ARG2(arg));
1663: Pdp_weyl_true_nf_and_quotient_marked(narg,rp);
1664: }
1665:
1666:
1667: void Pdp_weyl_true_nf_and_quotient_marked_mod(NODE arg,LIST *rp)
1668: {
1669: NODE b,n;
1670: DP *ps,*hps;
1671: DP g;
1672: DP nm;
1673: VECT quo;
1674: P dn;
1675: int full,mod;
1676:
1677: do_weyl = 1; dp_fcoeffs = 0;
1678: asir_assert(ARG0(arg),O_LIST,"dp_weyl_true_nf_and_quotient_marked_mod");
1679: asir_assert(ARG1(arg),O_DP,"dp_weyl_true_nf_and_quotient_marked_mod");
1680: asir_assert(ARG2(arg),O_VECT,"dp_weyl_true_nf_and_quotient_marked_mod");
1681: asir_assert(ARG3(arg),O_VECT,"dp_weyl_true_nf_and_quotient_marked_mod");
1682: asir_assert(ARG4(arg),O_N,"dp_weyl_true_nf_and_quotient_marked_mod");
1683: if ( !(g = (DP)ARG1(arg)) ) {
1684: nm = 0; dn = (P)ONE;
1685: } else {
1686: b = BDY((LIST)ARG0(arg));
1687: ps = (DP *)BDY((VECT)ARG2(arg));
1688: hps = (DP *)BDY((VECT)ARG3(arg));
1.2 noro 1689: mod = ZTOS((Q)ARG4(arg));
1.1 noro 1690: NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
1691: quo->body = (pointer *)dp_true_nf_and_quotient_marked_mod(b,g,ps,hps,mod,&nm,&dn);
1692: }
1693: n = mknode(3,nm,dn,quo);
1694: MKLIST(*rp,n);
1695: }
1696:
1697: void Pdp_weyl_true_nf_and_quotient_mod(NODE arg,LIST *rp)
1698: {
1699: NODE narg = mknode(5,ARG0(arg),ARG1(arg),ARG2(arg),ARG2(arg),ARG3(arg));
1700: Pdp_weyl_true_nf_and_quotient_marked_mod(narg,rp);
1701: }
1702:
1703:
1704: void Pdp_tdiv(NODE arg,DP *rp)
1705: {
1706: MP m,mr,mr0;
1707: DP p;
1708: Z d,q,r;
1709: int sgn;
1710:
1711: asir_assert(ARG0(arg),O_DP,"dp_tdiv");
1712: asir_assert(ARG1(arg),O_N,"dp_tdiv");
1713: p = (DP)ARG0(arg); d = (Z)ARG1(arg);
1714: if ( !p )
1715: *rp = 0;
1716: else {
1717: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
1718: divqrz((Z)m->c,d,&q,&r);
1719: if ( r ) {
1720: *rp = 0; return;
1721: } else {
1722: NEXTMP(mr0,mr);
1723: mr->c = (Obj)q; mr->dl = m->dl;
1724: }
1725: }
1726: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
1727: }
1728: }
1729:
1730: void Pdp_red_coef(NODE arg,DP *rp)
1731: {
1732: MP m,mr,mr0;
1733: P q,r;
1734: DP p;
1735: P mod;
1736:
1737: p = (DP)ARG0(arg); mod = (P)ARG1(arg);
1738: asir_assert(p,O_DP,"dp_red_coef");
1739: asir_assert(mod,O_P,"dp_red_coef");
1740: if ( !p )
1741: *rp = 0;
1742: else {
1743: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
1744: divsrp(CO,(P)m->c,mod,&q,&r);
1745: if ( r ) {
1746: NEXTMP(mr0,mr); mr->c = (Obj)r; mr->dl = m->dl;
1747: }
1748: }
1749: if ( mr0 ) {
1750: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
1751: } else
1752: *rp = 0;
1753: }
1754: }
1755:
1756: void Pdp_redble(NODE arg,Z *rp)
1757: {
1758: asir_assert(ARG0(arg),O_DP,"dp_redble");
1759: asir_assert(ARG1(arg),O_DP,"dp_redble");
1760: if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
1761: *rp = ONE;
1762: else
1763: *rp = 0;
1764: }
1765:
1766: void Pdp_red_mod(NODE arg,LIST *rp)
1767: {
1768: DP h,r;
1769: P dmy;
1770: NODE n;
1771:
1772: do_weyl = 0;
1773: asir_assert(ARG0(arg),O_DP,"dp_red_mod");
1774: asir_assert(ARG1(arg),O_DP,"dp_red_mod");
1775: asir_assert(ARG2(arg),O_DP,"dp_red_mod");
1776: asir_assert(ARG3(arg),O_N,"dp_red_mod");
1.2 noro 1777: dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),ZTOS((Q)ARG3(arg)),
1.1 noro 1778: &h,&r,&dmy);
1779: NEWNODE(n); BDY(n) = (pointer)h;
1780: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
1781: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1782: }
1783:
1784: void Pdp_subd(NODE arg,DP *rp)
1785: {
1786: DP p1,p2;
1787:
1788: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1789: asir_assert(p1,O_DP,"dp_subd");
1790: asir_assert(p2,O_DP,"dp_subd");
1791: dp_subd(p1,p2,rp);
1792: }
1793:
1794: void Pdp_symb_add(NODE arg,DP *rp)
1795: {
1796: DP p1,p2,r;
1797: NODE s0;
1798: MP mp0,mp;
1799: int nv;
1800:
1801: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1802: asir_assert(p1,O_DP,"dp_symb_add");
1803: asir_assert(p2,O_DP,"dp_symb_add");
1804: if ( !p1 ) { *rp = p2; return; }
1805: else if ( !p2 ) { *rp = p1; return; }
1806: if ( p1->nv != p2->nv )
1807: error("dp_sumb_add : invalid input");
1808: nv = p1->nv;
1809: s0 = symb_merge(dp_dllist(p1),dp_dllist(p2),nv);
1810: for ( mp0 = 0; s0; s0 = NEXT(s0) ) {
1811: NEXTMP(mp0,mp); mp->dl = (DL)BDY(s0); mp->c = (Obj)ONE;
1812: }
1813: NEXT(mp) = 0;
1814: MKDP(nv,mp0,r); r->sugar = MAX(p1->sugar,p2->sugar);
1815: *rp = r;
1816: }
1817:
1818: void Pdp_mul_trunc(NODE arg,DP *rp)
1819: {
1820: DP p1,p2,p;
1821:
1822: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); p = (DP)ARG2(arg);
1823: asir_assert(p1,O_DP,"dp_mul_trunc");
1824: asir_assert(p2,O_DP,"dp_mul_trunc");
1825: asir_assert(p,O_DP,"dp_mul_trunc");
1826: comm_muld_trunc(CO,p1,p2,BDY(p)->dl,rp);
1827: }
1828:
1829: void Pdp_quo(NODE arg,DP *rp)
1830: {
1831: DP p1,p2;
1832:
1833: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1834: asir_assert(p1,O_DP,"dp_quo");
1835: asir_assert(p2,O_DP,"dp_quo");
1836: comm_quod(CO,p1,p2,rp);
1837: }
1838:
1839: void Pdp_weyl_mul(NODE arg,DP *rp)
1840: {
1841: DP p1,p2;
1842:
1843: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1844: asir_assert(p1,O_DP,"dp_weyl_mul"); asir_assert(p2,O_DP,"dp_weyl_mul");
1845: do_weyl = 1;
1846: muld(CO,p1,p2,rp);
1847: do_weyl = 0;
1848: }
1849:
1850: void Pdp_weyl_act(NODE arg,DP *rp)
1851: {
1852: DP p1,p2;
1853:
1854: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1855: asir_assert(p1,O_DP,"dp_weyl_act"); asir_assert(p2,O_DP,"dp_weyl_act");
1856: weyl_actd(CO,p1,p2,rp);
1857: }
1858:
1859:
1860: void Pdp_weyl_mul_mod(NODE arg,DP *rp)
1861: {
1862: DP p1,p2;
1863: Q m;
1864:
1865: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); m = (Q)ARG2(arg);
1866: asir_assert(p1,O_DP,"dp_weyl_mul_mod");
1867: asir_assert(p2,O_DP,"dp_mul_mod");
1868: asir_assert(m,O_N,"dp_mul_mod");
1869: do_weyl = 1;
1.2 noro 1870: mulmd(CO,ZTOS(m),p1,p2,rp);
1.1 noro 1871: do_weyl = 0;
1872: }
1873:
1874: void Pdp_red(NODE arg,LIST *rp)
1875: {
1876: NODE n;
1877: DP head,rest,dmy1;
1878: P dmy;
1879:
1880: do_weyl = 0;
1881: asir_assert(ARG0(arg),O_DP,"dp_red");
1882: asir_assert(ARG1(arg),O_DP,"dp_red");
1883: asir_assert(ARG2(arg),O_DP,"dp_red");
1884: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1885: NEWNODE(n); BDY(n) = (pointer)head;
1886: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
1887: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1888: }
1889:
1890: void Pdp_weyl_red(NODE arg,LIST *rp)
1891: {
1892: NODE n;
1893: DP head,rest,dmy1;
1894: P dmy;
1895:
1896: asir_assert(ARG0(arg),O_DP,"dp_weyl_red");
1897: asir_assert(ARG1(arg),O_DP,"dp_weyl_red");
1898: asir_assert(ARG2(arg),O_DP,"dp_weyl_red");
1899: do_weyl = 1;
1900: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1901: do_weyl = 0;
1902: NEWNODE(n); BDY(n) = (pointer)head;
1903: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
1904: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1905: }
1906:
1907: void Pdp_sp(NODE arg,DP *rp)
1908: {
1909: DP p1,p2;
1910:
1911: do_weyl = 0;
1912: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1913: asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
1914: dp_sp(p1,p2,rp);
1915: }
1916:
1917: void Pdp_weyl_sp(NODE arg,DP *rp)
1918: {
1919: DP p1,p2;
1920:
1921: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1922: asir_assert(p1,O_DP,"dp_weyl_sp"); asir_assert(p2,O_DP,"dp_weyl_sp");
1923: do_weyl = 1;
1924: dp_sp(p1,p2,rp);
1925: do_weyl = 0;
1926: }
1927:
1928: void Pdpm_sp(NODE arg,DPM *rp)
1929: {
1930: DPM p1,p2;
1931:
1932: do_weyl = 0;
1933: p1 = (DPM)ARG0(arg); p2 = (DPM)ARG1(arg);
1934: asir_assert(p1,O_DPM,"dpm_sp"); asir_assert(p2,O_DPM,"dpm_sp");
1935: dpm_sp(p1,p2,rp);
1936: }
1937:
1938: void Pdpm_weyl_sp(NODE arg,DPM *rp)
1939: {
1940: DPM p1,p2;
1941:
1942: p1 = (DPM)ARG0(arg); p2 = (DPM)ARG1(arg);
1943: asir_assert(p1,O_DPM,"dpm_weyl_sp"); asir_assert(p2,O_DPM,"dpm_weyl_sp");
1944: do_weyl = 1;
1945: dpm_sp(p1,p2,rp);
1946: do_weyl = 0;
1947: }
1948:
1949: void Pdp_sp_mod(NODE arg,DP *rp)
1950: {
1951: DP p1,p2;
1952: int mod;
1953:
1954: do_weyl = 0;
1955: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1956: asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
1957: asir_assert(ARG2(arg),O_N,"dp_sp_mod");
1.2 noro 1958: mod = ZTOS((Q)ARG2(arg));
1.1 noro 1959: dp_sp_mod(p1,p2,mod,rp);
1960: }
1961:
1962: void Pdp_lcm(NODE arg,DP *rp)
1963: {
1964: int i,n,td;
1965: DL d1,d2,d;
1966: MP m;
1967: DP p1,p2;
1968:
1969: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1970: asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
1971: n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
1972: NEWDL(d,n);
1973: for ( i = 0, td = 0; i < n; i++ ) {
1974: d->d[i] = MAX(d1->d[i],d2->d[i]); td += MUL_WEIGHT(d->d[i],i);
1975: }
1976: d->td = td;
1977: NEWMP(m); m->dl = d; m->c = (Obj)ONE; NEXT(m) = 0;
1978: MKDP(n,m,*rp); (*rp)->sugar = td; /* XXX */
1979: }
1980:
1981: void Pdp_hm(NODE arg,DP *rp)
1982: {
1983: DP p;
1984:
1985: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
1986: dp_hm(p,rp);
1987: }
1988:
1989: void Pdp_ht(NODE arg,DP *rp)
1990: {
1991: DP p;
1992: MP m,mr;
1993:
1994: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
1995: dp_ht(p,rp);
1996: }
1997:
1998: void Pdp_hc(NODE arg,Obj *rp)
1999: {
2000: asir_assert(ARG0(arg),O_DP,"dp_hc");
2001: if ( !ARG0(arg) )
2002: *rp = 0;
2003: else
2004: *rp = BDY((DP)ARG0(arg))->c;
2005: }
2006:
2007: void Pdp_rest(NODE arg,DP *rp)
2008: {
2009: asir_assert(ARG0(arg),O_DP,"dp_rest");
2010: if ( !ARG0(arg) )
2011: *rp = 0;
2012: else
2013: dp_rest((DP)ARG0(arg),rp);
2014: }
2015:
2016: void Pdp_td(NODE arg,Z *rp)
2017: {
2018: DP p;
2019:
2020: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
2021: if ( !p )
2022: *rp = 0;
2023: else
1.2 noro 2024: STOZ(BDY(p)->dl->td,*rp);
1.1 noro 2025: }
2026:
2027: void Pdp_sugar(NODE arg,Z *rp)
2028: {
2029: DP p;
2030:
2031: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
2032: if ( !p )
2033: *rp = 0;
2034: else
1.2 noro 2035: STOZ(p->sugar,*rp);
1.1 noro 2036: }
2037:
2038: void Pdp_initial_term(NODE arg,Obj *rp)
2039: {
2040: struct order_spec *ord;
2041: Num homo;
2042: int modular,is_list;
2043: LIST v,f,l,initiallist;
2044: NODE n;
2045:
2046: f = (LIST)ARG0(arg);
2047: if ( f && OID(f) == O_LIST )
2048: is_list = 1;
2049: else {
2050: n = mknode(1,f); MKLIST(l,n); f = l;
2051: is_list = 0;
2052: }
2053: if ( current_option ) {
2054: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
2055: initd(ord);
2056: } else
2057: ord = dp_current_spec;
2058: initiallist = dp_initial_term(f,ord);
2059: if ( !is_list )
2060: *rp = (Obj)BDY(BDY(initiallist));
2061: else
2062: *rp = (Obj)initiallist;
2063: }
2064:
2065: void Pdp_order(NODE arg,Obj *rp)
2066: {
2067: struct order_spec *ord;
2068: Num homo;
2069: int modular,is_list;
2070: LIST v,f,l,ordlist;
2071: NODE n;
2072:
2073: f = (LIST)ARG0(arg);
2074: if ( f && OID(f) == O_LIST )
2075: is_list = 1;
2076: else {
2077: n = mknode(1,f); MKLIST(l,n); f = l;
2078: is_list = 0;
2079: }
2080: if ( current_option ) {
2081: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
2082: initd(ord);
2083: } else
2084: ord = dp_current_spec;
2085: ordlist = dp_order(f,ord);
2086: if ( !is_list )
2087: *rp = (Obj)BDY(BDY(ordlist));
2088: else
2089: *rp = (Obj)ordlist;
2090: }
2091:
2092: void Pdp_set_sugar(NODE arg,Q *rp)
2093: {
2094: DP p;
2095: Q q;
2096: int i;
2097:
2098: p = (DP)ARG0(arg);
2099: q = (Q)ARG1(arg);
2100: if ( p && q) {
2101: asir_assert(p,O_DP,"dp_set_sugar");
2102: asir_assert(q,O_N, "dp_set_sugar");
1.2 noro 2103: i = ZTOS(q);
1.1 noro 2104: if (p->sugar < i) {
2105: p->sugar = i;
2106: }
2107: }
2108: *rp = 0;
2109: }
2110:
2111: void Pdp_cri1(NODE arg,Z *rp)
2112: {
2113: DP p1,p2;
2114: int *d1,*d2;
2115: int i,n;
2116:
2117: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
2118: asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
2119: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
2120: for ( i = 0; i < n; i++ )
2121: if ( d1[i] > d2[i] )
2122: break;
2123: *rp = i == n ? ONE : 0;
2124: }
2125:
2126: void Pdp_cri2(NODE arg,Z *rp)
2127: {
2128: DP p1,p2;
2129: int *d1,*d2;
2130: int i,n;
2131:
2132: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
2133: asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
2134: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
2135: for ( i = 0; i < n; i++ )
2136: if ( MIN(d1[i],d2[i]) >= 1 )
2137: break;
2138: *rp = i == n ? ONE : 0;
2139: }
2140:
2141: void Pdp_minp(NODE arg,LIST *rp)
2142: {
2143: NODE tn,tn1,d,dd,dd0,p,tp;
2144: LIST l,minp;
2145: DP lcm,tlcm;
2146: int s,ts;
2147:
2148: asir_assert(ARG0(arg),O_LIST,"dp_minp");
2149: d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
2150: p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
2151: if ( !ARG1(arg) ) {
1.2 noro 2152: s = ZTOS((Q)BDY(p)); p = NEXT(p);
1.1 noro 2153: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
2154: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
2155: tlcm = (DP)BDY(tp); tp = NEXT(tp);
1.2 noro 2156: ts = ZTOS((Q)BDY(tp)); tp = NEXT(tp);
1.1 noro 2157: NEXTNODE(dd0,dd);
2158: if ( ts < s ) {
2159: BDY(dd) = (pointer)minp;
2160: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
2161: } else if ( ts == s ) {
2162: if ( compd(CO,lcm,tlcm) > 0 ) {
2163: BDY(dd) = (pointer)minp;
2164: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
2165: } else
2166: BDY(dd) = BDY(d);
2167: } else
2168: BDY(dd) = BDY(d);
2169: }
2170: } else {
2171: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
2172: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
2173: tlcm = (DP)BDY(tp);
2174: NEXTNODE(dd0,dd);
2175: if ( compd(CO,lcm,tlcm) > 0 ) {
2176: BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
2177: } else
2178: BDY(dd) = BDY(d);
2179: }
2180: }
2181: if ( dd0 )
2182: NEXT(dd) = 0;
2183: MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
2184: }
2185:
2186: void Pdp_criB(NODE arg,LIST *rp)
2187: {
2188: NODE d,ij,dd,ddd;
2189: int i,j,s,n;
2190: DP *ps;
2191: DL ts,ti,tj,lij,tdl;
2192:
2193: asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
1.2 noro 2194: asir_assert(ARG1(arg),O_N,"dp_criB"); s = ZTOS((Q)ARG1(arg));
1.1 noro 2195: asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
2196: if ( !d )
2197: *rp = (LIST)ARG0(arg);
2198: else {
2199: ts = BDY(ps[s])->dl;
2200: n = ps[s]->nv;
2201: NEWDL(tdl,n);
2202: for ( dd = 0; d; d = NEXT(d) ) {
2203: ij = BDY((LIST)BDY(d));
1.2 noro 2204: i = ZTOS((Q)BDY(ij)); ij = NEXT(ij);
2205: j = ZTOS((Q)BDY(ij)); ij = NEXT(ij);
1.1 noro 2206: lij = BDY((DP)BDY(ij))->dl;
2207: ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
2208: if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
2209: || !dl_equal(n,lij,tdl)
2210: || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
2211: && dl_equal(n,tdl,lij))
2212: || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
2213: && dl_equal(n,tdl,lij)) ) {
2214: MKNODE(ddd,BDY(d),dd);
2215: dd = ddd;
2216: }
2217: }
2218: MKLIST(*rp,dd);
2219: }
2220: }
2221:
2222: void Pdp_nelim(NODE arg,Z *rp)
2223: {
2224: if ( arg ) {
2225: asir_assert(ARG0(arg),O_N,"dp_nelim");
1.2 noro 2226: dp_nelim = ZTOS((Q)ARG0(arg));
1.1 noro 2227: }
1.2 noro 2228: STOZ(dp_nelim,*rp);
1.1 noro 2229: }
2230:
2231: void Pdp_mag(NODE arg,Z *rp)
2232: {
2233: DP p;
2234: int s;
2235: MP m;
2236:
2237: p = (DP)ARG0(arg);
2238: asir_assert(p,O_DP,"dp_mag");
2239: if ( !p )
2240: *rp = 0;
2241: else {
2242: for ( s = 0, m = BDY(p); m; m = NEXT(m) )
2243: s += p_mag((P)m->c);
1.2 noro 2244: STOZ(s,*rp);
1.1 noro 2245: }
2246: }
2247:
2248: /* kara_mag is no longer used. */
2249:
2250: void Pdp_set_kara(NODE arg,Z *rp)
2251: {
2252: *rp = 0;
2253: }
2254:
2255: void Pdp_homo(NODE arg,DP *rp)
2256: {
2257: asir_assert(ARG0(arg),O_DP,"dp_homo");
2258: dp_homo((DP)ARG0(arg),rp);
2259: }
2260:
2261: void Pdp_dehomo(NODE arg,DP *rp)
2262: {
2263: asir_assert(ARG0(arg),O_DP,"dp_dehomo");
2264: dp_dehomo((DP)ARG0(arg),rp);
2265: }
2266:
2267: void Pdp_gr_flags(NODE arg,LIST *rp)
2268: {
2269: Obj name,value;
2270: NODE n;
2271:
2272: if ( arg ) {
2273: asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
2274: n = BDY((LIST)ARG0(arg));
2275: while ( n ) {
2276: name = (Obj)BDY(n); n = NEXT(n);
2277: if ( !n )
2278: break;
2279: else {
2280: value = (Obj)BDY(n); n = NEXT(n);
2281: }
2282: dp_set_flag(name,value);
2283: }
2284: }
2285: dp_make_flaglist(rp);
2286: }
2287:
2288: extern int DP_Print, DP_PrintShort;
2289:
2290: void Pdp_gr_print(NODE arg,Z *rp)
2291: {
2292: Z q;
2293: int s;
2294:
2295: if ( arg ) {
2296: asir_assert(ARG0(arg),O_N,"dp_gr_print");
2297: q = (Z)ARG0(arg);
1.2 noro 2298: s = ZTOS(q);
1.1 noro 2299: switch ( s ) {
2300: case 0:
2301: DP_Print = 0; DP_PrintShort = 0;
2302: break;
2303: case 1:
2304: DP_Print = 1;
2305: break;
2306: case 2:
2307: DP_Print = 0; DP_PrintShort = 1;
2308: break;
2309: default:
2310: DP_Print = s; DP_PrintShort = 0;
2311: break;
2312: }
2313: } else {
2314: if ( DP_Print ) {
1.2 noro 2315: STOZ(1,q);
1.1 noro 2316: } else if ( DP_PrintShort ) {
1.2 noro 2317: STOZ(2,q);
1.1 noro 2318: } else
2319: q = 0;
2320: }
2321: *rp = q;
2322: }
2323:
2324: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
2325: int *modular,struct order_spec **ord)
2326: {
2327: NODE t,p;
2328: Z m,z;
2329: char *key;
2330: Obj value,dmy;
2331: int ord_is_set = 0;
2332: int modular_is_set = 0;
2333: int homo_is_set = 0;
2334: VL vl,vl0;
2335: LIST vars;
2336: char xiname[BUFSIZ];
2337: NODE x0,x;
2338: DP d;
2339: P xi;
2340: int nv,i;
2341:
2342: /* extract vars */
2343: vars = 0;
2344: for ( t = opt; t; t = NEXT(t) ) {
2345: p = BDY((LIST)BDY(t));
2346: key = BDY((STRING)BDY(p));
2347: value = (Obj)BDY(NEXT(p));
2348: if ( !strcmp(key,"v") ) {
2349: /* variable list */
2350: vars = (LIST)value;
2351: break;
2352: }
2353: }
2354: if ( vars ) {
2355: *v = vars; pltovl(vars,&vl);
2356: } else {
2357: for ( t = BDY(f); t; t = NEXT(t) )
2358: if ( BDY(t) && OID((Obj)BDY(t))==O_DP )
2359: break;
2360: if ( t ) {
2361: /* f is DP list */
2362: /* create dummy var list */
2363: d = (DP)BDY(t);
2364: nv = NV(d);
2365: for ( i = 0, vl0 = 0, x0 = 0; i < nv; i++ ) {
2366: NEXTVL(vl0,vl);
2367: NEXTNODE(x0,x);
2368: sprintf(xiname,"x%d",i);
2369: makevar(xiname,&xi);
2370: x->body = (pointer)xi;
2371: vl->v = VR((P)xi);
2372: }
2373: if ( vl0 ) {
2374: NEXT(vl) = 0;
2375: NEXT(x) = 0;
2376: }
2377: MKLIST(vars,x0);
2378: *v = vars;
2379: vl = vl0;
2380: } else {
2381: get_vars((Obj)f,&vl); vltopl(vl,v);
2382: }
2383: }
2384:
2385: for ( t = opt; t; t = NEXT(t) ) {
2386: p = BDY((LIST)BDY(t));
2387: key = BDY((STRING)BDY(p));
2388: value = (Obj)BDY(NEXT(p));
2389: if ( !strcmp(key,"v") ) {
2390: /* variable list; ignore */
2391: } else if ( !strcmp(key,"order") ) {
2392: /* order spec */
2393: if ( !vl )
2394: error("parse_gr_option : variables must be specified");
2395: create_order_spec(vl,value,ord);
2396: ord_is_set = 1;
2397: } else if ( !strcmp(key,"block") ) {
2398: create_order_spec(0,value,ord);
2399: ord_is_set = 1;
2400: } else if ( !strcmp(key,"matrix") ) {
2401: create_order_spec(0,value,ord);
2402: ord_is_set = 1;
2403: } else if ( !strcmp(key,"sugarweight") ) {
2404: /* weight */
2405: Pdp_set_weight(NEXT(p),&dmy);
2406: } else if ( !strcmp(key,"homo") ) {
2407: *homo = (Num)value;
2408: homo_is_set = 1;
2409: } else if ( !strcmp(key,"trace") ) {
2410: m = (Z)value;
1.2 noro 2411: STOZ(0x80000000,z);
1.1 noro 2412: if ( !m )
2413: *modular = 0;
2414: else if ( cmpz(m,z) >= 0 )
2415: error("parse_gr_option : too large modulus");
2416: else
1.2 noro 2417: *modular = ZTOS(m);
1.1 noro 2418: modular_is_set = 1;
2419: } else if ( !strcmp(key,"dp") ) {
2420: /* XXX : ignore */
2421: } else
2422: error("parse_gr_option : not implemented");
2423: }
2424: if ( !ord_is_set ) create_order_spec(0,0,ord);
2425: if ( !modular_is_set ) *modular = 0;
2426: if ( !homo_is_set ) *homo = 0;
2427: }
2428:
2429: void Pdp_gr_main(NODE arg,LIST *rp)
2430: {
2431: LIST f,v;
2432: VL vl;
2433: Num homo;
2434: Z m,z;
2435: int modular,ac;
2436: struct order_spec *ord;
2437:
2438: do_weyl = 0;
2439: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
2440: f = (LIST)ARG0(arg);
2441: f = remove_zero_from_list(f);
2442: if ( !BDY(f) ) {
2443: *rp = f; return;
2444: }
2445: if ( (ac = argc(arg)) == 5 ) {
2446: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
2447: asir_assert(ARG2(arg),O_N,"dp_gr_main");
2448: asir_assert(ARG3(arg),O_N,"dp_gr_main");
2449: v = (LIST)ARG1(arg);
2450: homo = (Num)ARG2(arg);
2451: m = (Z)ARG3(arg);
1.2 noro 2452: STOZ(0x80000000,z);
1.1 noro 2453: if ( !m )
2454: modular = 0;
2455: else if ( cmpz(m,z) >= 0 )
2456: error("dp_gr_main : too large modulus");
2457: else
1.2 noro 2458: modular = ZTOS(m);
1.1 noro 2459: create_order_spec(0,ARG4(arg),&ord);
2460: } else if ( current_option )
2461: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
2462: else if ( ac == 1 )
2463: parse_gr_option(f,0,&v,&homo,&modular,&ord);
2464: else
2465: error("dp_gr_main : invalid argument");
2466: dp_gr_main(f,v,homo,modular,0,ord,rp);
2467: }
2468:
2469: void Pdp_interreduce(NODE arg,LIST *rp)
2470: {
2471: LIST f,v;
2472: VL vl;
2473: int ac;
2474: struct order_spec *ord;
2475:
2476: do_weyl = 0;
2477: asir_assert(ARG0(arg),O_LIST,"dp_interreduce");
2478: f = (LIST)ARG0(arg);
2479: f = remove_zero_from_list(f);
2480: if ( !BDY(f) ) {
2481: *rp = f; return;
2482: }
2483: if ( (ac = argc(arg)) == 3 ) {
2484: asir_assert(ARG1(arg),O_LIST,"dp_interreduce");
2485: v = (LIST)ARG1(arg);
2486: create_order_spec(0,ARG2(arg),&ord);
2487: }
2488: dp_interreduce(f,v,0,ord,rp);
2489: }
2490:
2491: void Pdp_gr_f_main(NODE arg,LIST *rp)
2492: {
2493: LIST f,v;
2494: Num homo;
2495: int m,field,t;
2496: struct order_spec *ord;
2497: NODE n;
2498:
2499: do_weyl = 0;
2500: asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
2501: asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
2502: asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
2503: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2504: f = remove_zero_from_list(f);
2505: if ( !BDY(f) ) {
2506: *rp = f; return;
2507: }
2508: homo = (Num)ARG2(arg);
2509: #if 0
2510: asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
1.2 noro 2511: m = ZTOS((Q)ARG3(arg));
1.1 noro 2512: if ( m )
2513: error("dp_gr_f_main : trace lifting is not implemented yet");
2514: create_order_spec(0,ARG4(arg),&ord);
2515: #else
2516: m = 0;
2517: create_order_spec(0,ARG3(arg),&ord);
2518: #endif
2519: field = 0;
2520: for ( n = BDY(f); n; n = NEXT(n) ) {
2521: t = get_field_type(BDY(n));
2522: if ( !t )
2523: continue;
2524: if ( t < 0 )
2525: error("dp_gr_f_main : incosistent coefficients");
2526: if ( !field )
2527: field = t;
2528: else if ( t != field )
2529: error("dp_gr_f_main : incosistent coefficients");
2530: }
2531: dp_gr_main(f,v,homo,m?1:0,field,ord,rp);
2532: }
2533:
2534: void Pdp_f4_main(NODE arg,LIST *rp)
2535: {
2536: LIST f,v;
2537: struct order_spec *ord;
2538:
2539: do_weyl = 0;
2540: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
2541: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
2542: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2543: f = remove_zero_from_list(f);
2544: if ( !BDY(f) ) {
2545: *rp = f; return;
2546: }
2547: create_order_spec(0,ARG2(arg),&ord);
2548: dp_f4_main(f,v,ord,rp);
2549: }
2550:
2551: /* dp_gr_checklist(list of dp) */
2552:
2553: void Pdp_gr_checklist(NODE arg,LIST *rp)
2554: {
2555: VECT g;
2556: LIST dp;
2557: NODE r;
2558: int n;
2559:
2560: do_weyl = 0;
2561: asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
2562: asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
1.2 noro 2563: n = ZTOS((Q)ARG1(arg));
1.1 noro 2564: gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
2565: r = mknode(2,g,dp);
2566: MKLIST(*rp,r);
2567: }
2568:
2569: void Pdp_f4_mod_main(NODE arg,LIST *rp)
2570: {
2571: LIST f,v;
2572: int m;
2573: struct order_spec *ord;
2574:
2575: do_weyl = 0;
2576: asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
2577: asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
2578: asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
1.2 noro 2579: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = ZTOS((Q)ARG2(arg));
1.1 noro 2580: f = remove_zero_from_list(f);
2581: if ( !BDY(f) ) {
2582: *rp = f; return;
2583: }
2584: if ( !m )
2585: error("dp_f4_mod_main : invalid argument");
2586: create_order_spec(0,ARG3(arg),&ord);
2587: dp_f4_mod_main(f,v,m,ord,rp);
2588: }
2589:
2590: void Pdp_gr_mod_main(NODE arg,LIST *rp)
2591: {
2592: LIST f,v;
2593: Num homo;
2594: int m;
2595: struct order_spec *ord;
2596:
2597: do_weyl = 0;
2598: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
2599: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
2600: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
2601: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
2602: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2603: f = remove_zero_from_list(f);
2604: if ( !BDY(f) ) {
2605: *rp = f; return;
2606: }
1.2 noro 2607: homo = (Num)ARG2(arg); m = ZTOS((Q)ARG3(arg));
1.1 noro 2608: if ( !m )
2609: error("dp_gr_mod_main : invalid argument");
2610: create_order_spec(0,ARG4(arg),&ord);
2611: dp_gr_mod_main(f,v,homo,m,ord,rp);
2612: }
2613:
2614: void Psetmod_ff(NODE node, Obj *val);
2615:
2616: void Pnd_f4(NODE arg,LIST *rp)
2617: {
2618: LIST f,v;
2619: int m,homo,retdp,ac;
2620: Obj val;
2621: Z mq,z;
2622: Num nhomo;
2623: NODE node;
2624: struct order_spec *ord;
2625:
2626: do_weyl = 0;
2627: nd_rref2 = 0;
2628: retdp = 0;
2629: if ( (ac = argc(arg)) == 4 ) {
2630: asir_assert(ARG0(arg),O_LIST,"nd_f4");
2631: asir_assert(ARG1(arg),O_LIST,"nd_f4");
2632: asir_assert(ARG2(arg),O_N,"nd_f4");
2633: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2634: f = remove_zero_from_list(f);
2635: if ( !BDY(f) ) {
2636: *rp = f; return;
2637: }
2638: mq = (Z)ARG2(arg);
1.2 noro 2639: STOZ((unsigned long)0x40000000,z);
1.1 noro 2640: if ( cmpz(mq,z) >= 0 ) {
2641: node = mknode(1,mq);
2642: Psetmod_ff(node,&val);
2643: m = -2;
2644: } else
1.2 noro 2645: m = ZTOS(mq);
1.1 noro 2646: create_order_spec(0,ARG3(arg),&ord);
2647: homo = 0;
2648: if ( get_opt("homo",&val) && val ) homo = 1;
2649: if ( get_opt("dp",&val) && val ) retdp = 1;
2650: if ( get_opt("rref2",&val) && val ) nd_rref2 = 1;
2651: } else if ( ac == 1 ) {
2652: f = (LIST)ARG0(arg);
2653: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
1.2 noro 2654: homo = ZTOS((Q)nhomo);
1.1 noro 2655: if ( get_opt("dp",&val) && val ) retdp = 1;
2656: if ( get_opt("rref2",&val) && val ) nd_rref2 = 1;
2657: } else
2658: error("nd_f4 : invalid argument");
2659: nd_gr(f,v,m,homo,retdp,1,ord,rp);
2660: }
2661:
2662: void Pnd_gr(NODE arg,LIST *rp)
2663: {
2664: LIST f,v;
2665: int m,homo,retdp,ac;
2666: Obj val;
2667: Z mq,z;
2668: Num nhomo;
2669: NODE node;
2670: struct order_spec *ord;
2671:
2672: do_weyl = 0;
2673: retdp = 0;
2674: if ( (ac=argc(arg)) == 4 ) {
2675: asir_assert(ARG0(arg),O_LIST,"nd_gr");
2676: asir_assert(ARG1(arg),O_LIST,"nd_gr");
2677: asir_assert(ARG2(arg),O_N,"nd_gr");
2678: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2679: f = remove_zero_from_list(f);
2680: if ( !BDY(f) ) {
2681: *rp = f; return;
2682: }
2683: mq = (Z)ARG2(arg);
1.2 noro 2684: STOZ(0x40000000,z);
1.1 noro 2685: if ( cmpz(mq,z) >= 0 ) {
2686: node = mknode(1,mq);
2687: Psetmod_ff(node,&val);
2688: m = -2;
2689: } else
1.2 noro 2690: m = ZTOS(mq);
1.1 noro 2691: create_order_spec(0,ARG3(arg),&ord);
2692: homo = 0;
2693: if ( get_opt("homo",&val) && val ) homo = 1;
2694: if ( get_opt("dp",&val) && val ) retdp = 1;
2695: } else if ( ac == 1 ) {
2696: f = (LIST)ARG0(arg);
2697: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
1.2 noro 2698: homo = ZTOS((Q)nhomo);
1.1 noro 2699: if ( get_opt("dp",&val) && val ) retdp = 1;
2700: } else
2701: error("nd_gr : invalid argument");
2702: nd_gr(f,v,m,homo,retdp,0,ord,rp);
2703: }
2704:
2705: void Pnd_gr_postproc(NODE arg,LIST *rp)
2706: {
2707: LIST f,v;
2708: int m,do_check;
2709: Z mq,z;
2710: Obj val;
2711: NODE node;
2712: struct order_spec *ord;
2713:
2714: do_weyl = 0;
2715: asir_assert(ARG0(arg),O_LIST,"nd_gr");
2716: asir_assert(ARG1(arg),O_LIST,"nd_gr");
2717: asir_assert(ARG2(arg),O_N,"nd_gr");
2718: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2719: f = remove_zero_from_list(f);
2720: if ( !BDY(f) ) {
2721: *rp = f; return;
2722: }
2723: mq = (Z)ARG2(arg);
1.2 noro 2724: STOZ(0x40000000,z);
1.1 noro 2725: if ( cmpz(mq,z) >= 0 ) {
2726: node = mknode(1,mq);
2727: Psetmod_ff(node,&val);
2728: m = -2;
2729: } else
1.2 noro 2730: m = ZTOS(mq);
1.1 noro 2731: create_order_spec(0,ARG3(arg),&ord);
2732: do_check = ARG4(arg) ? 1 : 0;
2733: nd_gr_postproc(f,v,m,ord,do_check,rp);
2734: }
2735:
2736: void Pnd_gr_recompute_trace(NODE arg,LIST *rp)
2737: {
2738: LIST f,v,tlist;
2739: int m;
2740: struct order_spec *ord;
2741:
2742: do_weyl = 0;
2743: asir_assert(ARG0(arg),O_LIST,"nd_gr_recompute_trace");
2744: asir_assert(ARG1(arg),O_LIST,"nd_gr_recompute_trace");
2745: asir_assert(ARG2(arg),O_N,"nd_gr_recompute_trace");
2746: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.2 noro 2747: m = ZTOS((Q)ARG2(arg));
1.1 noro 2748: create_order_spec(0,ARG3(arg),&ord);
2749: tlist = (LIST)ARG4(arg);
2750: nd_gr_recompute_trace(f,v,m,ord,tlist,rp);
2751: }
2752:
2753: Obj nd_btog_one(LIST f,LIST v,int m,struct order_spec *ord,LIST tlist,int pos);
2754: Obj nd_btog(LIST f,LIST v,int m,struct order_spec *ord,LIST tlist);
2755:
2756: void Pnd_btog(NODE arg,Obj *rp)
2757: {
2758: LIST f,v,tlist;
2759: Z mq,z;
2760: int m,ac,pos;
2761: struct order_spec *ord;
2762: NODE node;
2763: pointer val;
2764:
2765: do_weyl = 0;
2766: asir_assert(ARG0(arg),O_LIST,"nd_btog");
2767: asir_assert(ARG1(arg),O_LIST,"nd_btog");
2768: asir_assert(ARG2(arg),O_N,"nd_btog");
2769: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2770: mq = (Z)ARG2(arg);
1.2 noro 2771: STOZ(0x40000000,z);
1.1 noro 2772: if ( cmpz(mq,z) >= 0 ) {
2773: node = mknode(1,mq);
2774: Psetmod_ff(node,(Obj *)&val);
2775: m = -2;
2776: } else
1.2 noro 2777: m = ZTOS(mq);
1.1 noro 2778: create_order_spec(0,ARG3(arg),&ord);
2779: tlist = (LIST)ARG4(arg);
2780: if ( (ac = argc(arg)) == 6 ) {
2781: asir_assert(ARG5(arg),O_N,"nd_btog");
1.2 noro 2782: pos = ZTOS((Q)ARG5(arg));
1.1 noro 2783: *rp = nd_btog_one(f,v,m,ord,tlist,pos);
2784: } else if ( ac == 5 )
2785: *rp = nd_btog(f,v,m,ord,tlist);
2786: else
2787: error("nd_btog : argument mismatch");
2788: }
2789:
2790: void Pnd_weyl_gr_postproc(NODE arg,LIST *rp)
2791: {
2792: LIST f,v;
2793: int m,do_check;
2794: struct order_spec *ord;
2795:
2796: do_weyl = 1;
2797: asir_assert(ARG0(arg),O_LIST,"nd_gr");
2798: asir_assert(ARG1(arg),O_LIST,"nd_gr");
2799: asir_assert(ARG2(arg),O_N,"nd_gr");
2800: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2801: f = remove_zero_from_list(f);
2802: if ( !BDY(f) ) {
2803: *rp = f; do_weyl = 0; return;
2804: }
1.2 noro 2805: m = ZTOS((Q)ARG2(arg));
1.1 noro 2806: create_order_spec(0,ARG3(arg),&ord);
2807: do_check = ARG4(arg) ? 1 : 0;
2808: nd_gr_postproc(f,v,m,ord,do_check,rp);
2809: do_weyl = 0;
2810: }
2811:
2812: void Pnd_gr_trace(NODE arg,LIST *rp)
2813: {
2814: LIST f,v;
2815: int m,homo,ac;
2816: Num nhomo;
2817: struct order_spec *ord;
2818:
2819: do_weyl = 0;
2820: if ( (ac = argc(arg)) == 5 ) {
2821: asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
2822: asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
2823: asir_assert(ARG2(arg),O_N,"nd_gr_trace");
2824: asir_assert(ARG3(arg),O_N,"nd_gr_trace");
2825: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2826: f = remove_zero_from_list(f);
2827: if ( !BDY(f) ) {
2828: *rp = f; return;
2829: }
1.2 noro 2830: homo = ZTOS((Q)ARG2(arg));
2831: m = ZTOS((Q)ARG3(arg));
1.1 noro 2832: create_order_spec(0,ARG4(arg),&ord);
2833: } else if ( ac == 1 ) {
2834: f = (LIST)ARG0(arg);
2835: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
1.2 noro 2836: homo = ZTOS((Q)nhomo);
1.1 noro 2837: } else
2838: error("nd_gr_trace : invalid argument");
2839: nd_gr_trace(f,v,m,homo,0,ord,rp);
2840: }
2841:
2842: void Pnd_f4_trace(NODE arg,LIST *rp)
2843: {
2844: LIST f,v;
2845: int m,homo,ac;
2846: Num nhomo;
2847: struct order_spec *ord;
2848:
2849: do_weyl = 0;
2850: if ( (ac = argc(arg))==5 ) {
2851: asir_assert(ARG0(arg),O_LIST,"nd_f4_trace");
2852: asir_assert(ARG1(arg),O_LIST,"nd_f4_trace");
2853: asir_assert(ARG2(arg),O_N,"nd_f4_trace");
2854: asir_assert(ARG3(arg),O_N,"nd_f4_trace");
2855: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2856: f = remove_zero_from_list(f);
2857: if ( !BDY(f) ) {
2858: *rp = f; return;
2859: }
1.2 noro 2860: homo = ZTOS((Q)ARG2(arg));
2861: m = ZTOS((Q)ARG3(arg));
1.1 noro 2862: create_order_spec(0,ARG4(arg),&ord);
2863: } else if ( ac == 1 ) {
2864: f = (LIST)ARG0(arg);
2865: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
1.2 noro 2866: homo = ZTOS((Q)nhomo);
1.1 noro 2867: } else
2868: error("nd_gr_trace : invalid argument");
2869: nd_gr_trace(f,v,m,homo,1,ord,rp);
2870: }
2871:
2872: void Pnd_weyl_gr(NODE arg,LIST *rp)
2873: {
2874: LIST f,v;
2875: int m,homo,retdp,ac;
2876: Obj val;
2877: Num nhomo;
2878: struct order_spec *ord;
2879:
2880: do_weyl = 1;
2881: retdp = 0;
2882: if ( (ac = argc(arg)) == 4 ) {
2883: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr");
2884: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr");
2885: asir_assert(ARG2(arg),O_N,"nd_weyl_gr");
2886: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2887: f = remove_zero_from_list(f);
2888: if ( !BDY(f) ) {
2889: *rp = f; do_weyl = 0; return;
2890: }
1.2 noro 2891: m = ZTOS((Q)ARG2(arg));
1.1 noro 2892: create_order_spec(0,ARG3(arg),&ord);
2893: homo = 0;
2894: if ( get_opt("homo",&val) && val ) homo = 1;
2895: if ( get_opt("dp",&val) && val ) retdp = 1;
2896: } else if ( ac == 1 ) {
2897: f = (LIST)ARG0(arg);
2898: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
1.2 noro 2899: homo = ZTOS((Q)nhomo);
1.1 noro 2900: if ( get_opt("dp",&val) && val ) retdp = 1;
2901: } else
2902: error("nd_weyl_gr : invalid argument");
2903: nd_gr(f,v,m,homo,retdp,0,ord,rp);
2904: do_weyl = 0;
2905: }
2906:
2907: void Pnd_weyl_gr_trace(NODE arg,LIST *rp)
2908: {
2909: LIST f,v;
2910: int m,homo,ac;
2911: Num nhomo;
2912: struct order_spec *ord;
2913:
2914: do_weyl = 1;
2915: if ( (ac = argc(arg)) == 5 ) {
2916: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr_trace");
2917: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr_trace");
2918: asir_assert(ARG2(arg),O_N,"nd_weyl_gr_trace");
2919: asir_assert(ARG3(arg),O_N,"nd_weyl_gr_trace");
2920: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2921: f = remove_zero_from_list(f);
2922: if ( !BDY(f) ) {
2923: *rp = f; do_weyl = 0; return;
2924: }
1.2 noro 2925: homo = ZTOS((Q)ARG2(arg));
2926: m = ZTOS((Q)ARG3(arg));
1.1 noro 2927: create_order_spec(0,ARG4(arg),&ord);
2928: } else if ( ac == 1 ) {
2929: f = (LIST)ARG0(arg);
2930: parse_gr_option(f,current_option,&v,&nhomo,&m,&ord);
1.2 noro 2931: homo = ZTOS((Q)nhomo);
1.1 noro 2932: } else
2933: error("nd_weyl_gr_trace : invalid argument");
2934: nd_gr_trace(f,v,m,homo,0,ord,rp);
2935: do_weyl = 0;
2936: }
2937:
2938: void Pnd_nf(NODE arg,Obj *rp)
2939: {
2940: Obj f;
2941: LIST g,v;
2942: struct order_spec *ord;
2943:
2944: do_weyl = 0;
2945: asir_assert(ARG1(arg),O_LIST,"nd_nf");
2946: asir_assert(ARG2(arg),O_LIST,"nd_nf");
2947: asir_assert(ARG4(arg),O_N,"nd_nf");
2948: f = (Obj)ARG0(arg);
2949: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
2950: if ( !BDY(g) ) {
2951: *rp = f; return;
2952: }
2953: v = (LIST)ARG2(arg);
2954: create_order_spec(0,ARG3(arg),&ord);
1.2 noro 2955: nd_nf_p(f,g,v,ZTOS((Q)ARG4(arg)),ord,rp);
1.1 noro 2956: }
2957:
2958: void Pnd_weyl_nf(NODE arg,Obj *rp)
2959: {
2960: Obj f;
2961: LIST g,v;
2962: struct order_spec *ord;
2963:
2964: do_weyl = 1;
2965: asir_assert(ARG1(arg),O_LIST,"nd_weyl_nf");
2966: asir_assert(ARG2(arg),O_LIST,"nd_weyl_nf");
2967: asir_assert(ARG4(arg),O_N,"nd_weyl_nf");
2968: f = (Obj)ARG0(arg);
2969: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
2970: if ( !BDY(g) ) {
2971: *rp = f; return;
2972: }
2973: v = (LIST)ARG2(arg);
2974: create_order_spec(0,ARG3(arg),&ord);
1.2 noro 2975: nd_nf_p(f,g,v,ZTOS((Q)ARG4(arg)),ord,rp);
1.1 noro 2976: }
2977:
2978: /* for Weyl algebra */
2979:
2980: void Pdp_weyl_gr_main(NODE arg,LIST *rp)
2981: {
2982: LIST f,v;
2983: Num homo;
2984: Z m,z;
2985: int modular,ac;
2986: struct order_spec *ord;
2987:
2988:
2989: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
2990: f = (LIST)ARG0(arg);
2991: f = remove_zero_from_list(f);
2992: if ( !BDY(f) ) {
2993: *rp = f; return;
2994: }
2995: if ( (ac = argc(arg)) == 5 ) {
2996: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
2997: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
2998: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
2999: v = (LIST)ARG1(arg);
3000: homo = (Num)ARG2(arg);
3001: m = (Z)ARG3(arg);
1.2 noro 3002: STOZ(0x80000000,z);
1.1 noro 3003: if ( !m )
3004: modular = 0;
3005: else if ( cmpz(m,z) >= 0 )
3006: error("dp_weyl_gr_main : too large modulus");
3007: else
1.2 noro 3008: modular = ZTOS(m);
1.1 noro 3009: create_order_spec(0,ARG4(arg),&ord);
3010: } else if ( current_option )
3011: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
3012: else if ( ac == 1 )
3013: parse_gr_option(f,0,&v,&homo,&modular,&ord);
3014: else
3015: error("dp_weyl_gr_main : invalid argument");
3016: do_weyl = 1;
3017: dp_gr_main(f,v,homo,modular,0,ord,rp);
3018: do_weyl = 0;
3019: }
3020:
3021: void Pdp_weyl_gr_f_main(NODE arg,LIST *rp)
3022: {
3023: LIST f,v;
3024: Num homo;
3025: struct order_spec *ord;
3026:
3027: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
3028: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
3029: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
3030: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
3031: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
3032: f = remove_zero_from_list(f);
3033: if ( !BDY(f) ) {
3034: *rp = f; return;
3035: }
3036: homo = (Num)ARG2(arg);
3037: create_order_spec(0,ARG3(arg),&ord);
3038: do_weyl = 1;
3039: dp_gr_main(f,v,homo,0,1,ord,rp);
3040: do_weyl = 0;
3041: }
3042:
3043: void Pdp_weyl_f4_main(NODE arg,LIST *rp)
3044: {
3045: LIST f,v;
3046: struct order_spec *ord;
3047:
3048: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
3049: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
3050: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
3051: f = remove_zero_from_list(f);
3052: if ( !BDY(f) ) {
3053: *rp = f; return;
3054: }
3055: create_order_spec(0,ARG2(arg),&ord);
3056: do_weyl = 1;
3057: dp_f4_main(f,v,ord,rp);
3058: do_weyl = 0;
3059: }
3060:
3061: void Pdp_weyl_f4_mod_main(NODE arg,LIST *rp)
3062: {
3063: LIST f,v;
3064: int m;
3065: struct order_spec *ord;
3066:
3067: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
3068: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
3069: asir_assert(ARG2(arg),O_N,"dp_f4_main");
1.2 noro 3070: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = ZTOS((Q)ARG2(arg));
1.1 noro 3071: f = remove_zero_from_list(f);
3072: if ( !BDY(f) ) {
3073: *rp = f; return;
3074: }
3075: if ( !m )
3076: error("dp_weyl_f4_mod_main : invalid argument");
3077: create_order_spec(0,ARG3(arg),&ord);
3078: do_weyl = 1;
3079: dp_f4_mod_main(f,v,m,ord,rp);
3080: do_weyl = 0;
3081: }
3082:
3083: void Pdp_weyl_gr_mod_main(NODE arg,LIST *rp)
3084: {
3085: LIST f,v;
3086: Num homo;
3087: int m;
3088: struct order_spec *ord;
3089:
3090: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
3091: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
3092: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
3093: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
3094: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
3095: f = remove_zero_from_list(f);
3096: if ( !BDY(f) ) {
3097: *rp = f; return;
3098: }
1.2 noro 3099: homo = (Num)ARG2(arg); m = ZTOS((Q)ARG3(arg));
1.1 noro 3100: if ( !m )
3101: error("dp_weyl_gr_mod_main : invalid argument");
3102: create_order_spec(0,ARG4(arg),&ord);
3103: do_weyl = 1;
3104: dp_gr_mod_main(f,v,homo,m,ord,rp);
3105: do_weyl = 0;
3106: }
3107:
3108: VECT current_dl_weight_vector_obj;
3109: int *current_dl_weight_vector;
3110: int dp_negative_weight;
3111:
3112: void Pdp_set_weight(NODE arg,VECT *rp)
3113: {
3114: VECT v;
3115: int i,n;
3116: NODE node;
3117:
3118: if ( !arg )
3119: *rp = current_dl_weight_vector_obj;
3120: else if ( !ARG0(arg) ) {
3121: current_dl_weight_vector_obj = 0;
3122: current_dl_weight_vector = 0;
3123: dp_negative_weight = 0;
3124: *rp = 0;
3125: } else {
3126: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
3127: error("dp_set_weight : invalid argument");
3128: if ( OID(ARG0(arg)) == O_VECT )
3129: v = (VECT)ARG0(arg);
3130: else {
3131: node = (NODE)BDY((LIST)ARG0(arg));
3132: n = length(node);
3133: MKVECT(v,n);
3134: for ( i = 0; i < n; i++, node = NEXT(node) )
3135: BDY(v)[i] = BDY(node);
3136: }
3137: current_dl_weight_vector_obj = v;
3138: n = v->len;
3139: current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
3140: for ( i = 0; i < n; i++ )
1.2 noro 3141: current_dl_weight_vector[i] = ZTOS((Q)v->body[i]);
1.1 noro 3142: for ( i = 0; i < n; i++ )
3143: if ( current_dl_weight_vector[i] < 0 ) break;
3144: if ( i < n )
3145: dp_negative_weight = 1;
3146: else
3147: dp_negative_weight = 0;
3148: *rp = v;
3149: }
3150: }
3151:
3152: VECT current_module_weight_vector_obj;
3153: int *current_module_weight_vector;
3154:
3155: void Pdp_set_module_weight(NODE arg,VECT *rp)
3156: {
3157: VECT v;
3158: int i,n;
3159: NODE node;
3160:
3161: if ( !arg )
3162: *rp = current_module_weight_vector_obj;
3163: else if ( !ARG0(arg) ) {
3164: current_module_weight_vector_obj = 0;
3165: current_module_weight_vector = 0;
3166: *rp = 0;
3167: } else {
3168: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
3169: error("dp_module_set_weight : invalid argument");
3170: if ( OID(ARG0(arg)) == O_VECT )
3171: v = (VECT)ARG0(arg);
3172: else {
3173: node = (NODE)BDY((LIST)ARG0(arg));
3174: n = length(node);
3175: MKVECT(v,n);
3176: for ( i = 0; i < n; i++, node = NEXT(node) )
3177: BDY(v)[i] = BDY(node);
3178: }
3179: current_module_weight_vector_obj = v;
3180: n = v->len;
3181: current_module_weight_vector = (int *)CALLOC(n,sizeof(int));
3182: for ( i = 0; i < n; i++ )
1.2 noro 3183: current_module_weight_vector[i] = ZTOS((Q)v->body[i]);
1.1 noro 3184: *rp = v;
3185: }
3186: }
3187:
3188: extern Obj current_top_weight;
3189: extern Obj nd_top_weight;
3190:
3191: void Pdp_set_top_weight(NODE arg,Obj *rp)
3192: {
3193: VECT v;
3194: MAT m;
3195: Obj obj;
3196: int i,j,n,id,row,col;
3197: Q *mi;
3198: NODE node;
3199:
3200: if ( !arg )
3201: *rp = current_top_weight;
3202: else if ( !ARG0(arg) ) {
3203: reset_top_weight();
3204: *rp = 0;
3205: } else {
3206: id = OID(ARG0(arg));
3207: if ( id != O_VECT && id != O_MAT && id != O_LIST )
3208: error("dp_set_top_weight : invalid argument");
3209: if ( id == O_LIST ) {
3210: node = (NODE)BDY((LIST)ARG0(arg));
3211: n = length(node);
3212: MKVECT(v,n);
3213: for ( i = 0; i < n; i++, node = NEXT(node) )
3214: BDY(v)[i] = BDY(node);
3215: obj = (Obj)v;
3216: } else
3217: obj = ARG0(arg);
3218: if ( OID(obj) == O_VECT ) {
3219: v = (VECT)obj;
3220: for ( i = 0; i < v->len; i++ )
3221: if ( !INT((Q)BDY(v)[i]) || sgnz((Z)BDY(v)[i]) < 0 )
3222: error("dp_set_top_weight : each element must be a non-negative integer");
3223: } else {
3224: m = (MAT)obj; row = m->row; col = m->col;
3225: for ( i = 0; i < row; i++ )
3226: for ( j = 0, mi = (Q *)BDY(m)[i]; j < col; j++ )
3227: if ( !INT((Q)mi[j]) || sgnz((Z)mi[j]) < 0 )
3228: error("dp_set_top_weight : each element must be a non-negative integer");
3229: }
3230: current_top_weight = obj;
3231: nd_top_weight = obj;
3232: *rp = current_top_weight;
3233: }
3234: }
3235:
3236: LIST get_denomlist();
3237:
3238: void Pdp_get_denomlist(LIST *rp)
3239: {
3240: *rp = get_denomlist();
3241: }
3242:
3243: static VECT current_weyl_weight_vector_obj;
3244: int *current_weyl_weight_vector;
3245:
3246: void Pdp_weyl_set_weight(NODE arg,VECT *rp)
3247: {
3248: VECT v;
3249: NODE node;
3250: int i,n;
3251:
3252: if ( !arg )
3253: *rp = current_weyl_weight_vector_obj;
3254: else if ( !ARG0(arg) ) {
3255: current_weyl_weight_vector_obj = 0;
3256: current_weyl_weight_vector = 0;
3257: *rp = 0;
3258: } else {
3259: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
3260: error("dp_weyl_set_weight : invalid argument");
3261: if ( OID(ARG0(arg)) == O_VECT )
3262: v = (VECT)ARG0(arg);
3263: else {
3264: node = (NODE)BDY((LIST)ARG0(arg));
3265: n = length(node);
3266: MKVECT(v,n);
3267: for ( i = 0; i < n; i++, node = NEXT(node) )
3268: BDY(v)[i] = BDY(node);
3269: }
3270: current_weyl_weight_vector_obj = v;
3271: n = v->len;
3272: current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
3273: for ( i = 0; i < n; i++ )
1.2 noro 3274: current_weyl_weight_vector[i] = ZTOS((Q)v->body[i]);
1.1 noro 3275: *rp = v;
3276: }
3277: }
3278:
3279: NODE mono_raddec(NODE ideal);
3280:
3281: void Pdp_mono_raddec(NODE arg,LIST *rp)
3282: {
3283: NODE ideal,rd,t,t1,r,r1,u;
3284: VL vl0,vl;
3285: int nv,i,bpi;
3286: int *s;
3287: DP dp;
3288: P *v;
3289: LIST l;
3290:
3291: ideal = BDY((LIST)ARG0(arg));
3292: if ( !ideal ) *rp = (LIST)ARG0(arg);
3293: else {
3294: t = BDY((LIST)ARG1(arg));
3295: nv = length(t);
3296: v = (P *)MALLOC(nv*sizeof(P));
3297: for ( vl0 = 0, i = 0; t; t = NEXT(t), i++ ) {
3298: NEXTVL(vl0,vl); VR(vl) = VR((P)BDY(t));
3299: MKV(VR(vl),v[i]);
3300: }
3301: if ( vl0 ) NEXT(vl) = 0;
3302: for ( t = 0, r = ideal; r; r = NEXT(r) ) {
3303: ptod(CO,vl0,BDY(r),&dp); MKNODE(t1,dp,t); t = t1;
3304: }
3305: rd = mono_raddec(t);
3306: r = 0;
3307: bpi = (sizeof(int)/sizeof(char))*8;
3308: for ( u = rd; u; u = NEXT(u) ) {
3309: s = (int *)BDY(u);
3310: for ( i = nv-1, t = 0; i >= 0; i-- )
3311: if ( s[i/bpi]&(1<<(i%bpi)) ) {
3312: MKNODE(t1,v[i],t); t = t1;
3313: }
3314: MKLIST(l,t); MKNODE(r1,l,r); r = r1;
3315: }
3316: MKLIST(*rp,r);
3317: }
3318: }
3319:
3320: void Pdp_mono_reduce(NODE arg,LIST *rp)
3321: {
3322: NODE t,t0,t1,r0,r;
3323: int i,n;
3324: DP m;
3325: DP *a;
3326:
3327: t0 = BDY((LIST)ARG0(arg));
3328: t1 = BDY((LIST)ARG1(arg));
3329: n = length(t0);
3330: a = (DP *)MALLOC(n*sizeof(DP));
3331: for ( i = 0; i < n; i++, t0 = NEXT(t0) ) a[i] = (DP)BDY(t0);
3332: for ( t = t1; t; t = NEXT(t) ) {
3333: m = (DP)BDY(t);
3334: for ( i = 0; i < n; i++ )
3335: if ( a[i] && dp_redble(a[i],m) ) a[i] = 0;
3336: }
3337: for ( i = n-1, r0 = 0; i >= 0; i-- )
3338: if ( a[i] ) { NEXTNODE(r0,r); BDY(r) = a[i]; }
3339: if ( r0 ) NEXT(r) = 0;
3340: MKLIST(*rp,r0);
3341: }
3342:
3343: #define BLEN (8*sizeof(unsigned long))
3344:
3345: void showmat2(unsigned long **a,int row,int col)
3346: {
3347: int i,j;
3348:
3349: for ( i = 0; i < row; i++, putchar('\n') )
3350: for ( j = 0; j < col; j++ )
3351: if ( a[i][j/BLEN] & (1L<<(j%BLEN)) ) putchar('1');
3352: else putchar('0');
3353: }
3354:
3355: int rref2(unsigned long **a,int row,int col)
3356: {
3357: int i,j,k,l,s,wcol,wj;
3358: unsigned long bj;
3359: unsigned long *ai,*ak,*as,*t;
3360: int *pivot;
3361:
3362: wcol = (col+BLEN-1)/BLEN;
3363: pivot = (int *)MALLOC_ATOMIC(row*sizeof(int));
3364: i = 0;
3365: for ( j = 0; j < col; j++ ) {
3366: wj = j/BLEN; bj = 1L<<(j%BLEN);
3367: for ( k = i; k < row; k++ )
3368: if ( a[k][wj] & bj ) break;
3369: if ( k == row ) continue;
3370: pivot[i] = j;
3371: if ( k != i ) {
3372: t = a[i]; a[i] = a[k]; a[k] = t;
3373: }
3374: ai = a[i];
3375: for ( k = i+1; k < row; k++ ) {
3376: ak = a[k];
3377: if ( ak[wj] & bj ) {
3378: for ( l = wj; l < wcol; l++ )
3379: ak[l] ^= ai[l];
3380: }
3381: }
3382: i++;
3383: }
3384: for ( k = i-1; k >= 0; k-- ) {
3385: j = pivot[k]; wj = j/BLEN; bj = 1L<<(j%BLEN);
3386: ak = a[k];
3387: for ( s = 0; s < k; s++ ) {
3388: as = a[s];
3389: if ( as[wj] & bj ) {
3390: for ( l = wj; l < wcol; l++ )
3391: as[l] ^= ak[l];
3392: }
3393: }
3394: }
3395: return i;
3396: }
3397:
3398: void Pdp_rref2(NODE arg,VECT *rp)
3399: {
3400: VECT f,term,ret;
3401: int row,col,wcol,size,nv,i,j,rank,td;
3402: unsigned long **mat;
3403: unsigned long *v;
3404: DL d;
3405: DL *t;
3406: DP dp;
3407: MP m,m0;
3408:
3409: f = (VECT)ARG0(arg);
3410: row = f->len;
3411: term = (VECT)ARG1(arg);
3412: col = term->len;
3413: mat = (unsigned long **)MALLOC(row*sizeof(unsigned long *));
3414: size = sizeof(unsigned long)*((col+BLEN-1)/BLEN);
3415: nv = ((DP)term->body[0])->nv;
3416: t = (DL *)MALLOC(col*sizeof(DL));
3417: for ( i = 0; i < col; i++ ) t[i] = BDY((DP)BDY(term)[i])->dl;
3418: for ( i = 0; i < row; i++ ) {
3419: v = mat[i] = (unsigned long *)MALLOC_ATOMIC_IGNORE_OFF_PAGE(size);
3420: bzero(v,size);
3421: for ( j = 0, m = BDY((DP)BDY(f)[i]); m; m = NEXT(m) ) {
3422: d = m->dl;
3423: for ( ; !dl_equal(nv,d,t[j]); j++ );
3424: v[j/BLEN] |= 1L <<(j%BLEN);
3425: }
3426: }
3427: rank = rref2(mat,row,col);
3428: MKVECT(ret,rank);
3429: *rp = ret;
3430: for ( i = 0; i < rank; i++ ) {
3431: v = mat[i];
3432: m0 = 0;
3433: td = 0;
3434: for ( j = 0; j < col; j++ ) {
3435: if ( v[j/BLEN] & (1L<<(j%BLEN)) ) {
3436: NEXTMP(m0,m);
3437: m->dl = t[j];
3438: m->c = (Obj)ONE;
3439: td = MAX(td,m->dl->td);
3440: }
3441: }
3442: NEXT(m) = 0;
3443: MKDP(nv,m0,dp);
3444: dp->sugar = td;
3445: BDY(ret)[i] = (pointer)dp;
3446: }
3447: }
3448:
3449: #define HDL(f) (BDY(f)->dl)
3450:
3451: NODE sumi_criB(int nv,NODE d,DP *f,int m)
3452: {
3453: LIST p;
3454: NODE r0,r;
3455: int p0,p1;
3456: DL p2,lcm;
3457:
3458: NEWDL(lcm,nv);
3459: r0 = 0;
3460: for ( ; d; d = NEXT(d) ) {
3461: p = (LIST)BDY(d);
1.2 noro 3462: p0 = ZTOS((Q)ARG0(BDY(p)));
3463: p1 = ZTOS((Q)ARG1(BDY(p)));
1.1 noro 3464: p2 = HDL((DP)ARG2(BDY(p)));
3465: if(!_dl_redble(HDL((DP)f[m]),p2,nv) ||
3466: dl_equal(nv,lcm_of_DL(nv,HDL(f[p0]),HDL(f[m]),lcm),p2) ||
3467: dl_equal(nv,lcm_of_DL(nv,HDL(f[p1]),HDL(f[m]),lcm),p2) ) {
3468: NEXTNODE(r0,r);
3469: BDY(r) = p;
3470: }
3471: }
3472: if ( r0 ) NEXT(r) = 0;
3473: return r0;
3474: }
3475:
3476: NODE sumi_criFMD(int nv,DP *f,int m)
3477: {
3478: DL *a;
3479: DL l1,dl1,dl2;
3480: int i,j,k,k2;
3481: NODE r,r1,nd;
3482: MP mp;
3483: DP u;
3484: Z iq,mq;
3485: LIST list;
3486:
3487: /* a[i] = lcm(LT(f[i]),LT(f[m])) */
3488: a = (DL *)ALLOCA(m*sizeof(DL));
3489: for ( i = 0; i < m; i++ ) {
3490: a[i] = lcm_of_DL(nv,HDL(f[i]),HDL(f[m]),0);
3491: }
3492: r = 0;
3493: for( i = 0; i < m; i++) {
3494: l1 = a[i];
3495: if ( !l1 ) continue;
3496: /* Tkm = Tim (k<i) */
3497: for( k = 0; k < i; k++)
3498: if( dl_equal(nv,l1,a[k]) ) break;
3499: if( k == i ){
3500: /* Tk|Tim && Tkm != Tim (k<m) */
3501: for ( k2 = 0; k2 < m; k2++ )
3502: if ( _dl_redble(HDL(f[k2]),l1,nv) &&
3503: !dl_equal(nv,l1,a[k2]) ) break;
3504: if ( k2 == m ) {
3505: dl1 = HDL(f[i]); dl2 = HDL(f[m]);
3506: for ( k2 = 0; k2 < nv; k2++ )
3507: if ( dl1->d[k2] && dl2->d[k2] ) break;
3508: if ( k2 < nv ) {
3509: NEWMP(mp); mp->dl = l1; C(mp) = (Obj)ONE;
3510: NEXT(mp) = 0; MKDP(nv,mp,u); u->sugar = l1->td;
1.2 noro 3511: STOZ(i,iq); STOZ(m,mq);
1.1 noro 3512: nd = mknode(3,iq,mq,u);
3513: MKLIST(list,nd);
3514: MKNODE(r1,list,r);
3515: r = r1;
3516: }
3517: }
3518: }
3519: }
3520: return r;
3521: }
3522:
3523: LIST sumi_updatepairs(LIST d,DP *f,int m)
3524: {
3525: NODE old,new,t;
3526: LIST l;
3527: int nv;
3528:
3529: nv = f[0]->nv;
3530: old = sumi_criB(nv,BDY(d),f,m);
3531: new = sumi_criFMD(nv,f,m);
3532: if ( !new ) new = old;
3533: else {
3534: for ( t = new ; NEXT(t); t = NEXT(t) );
3535: NEXT(t) = old;
3536: }
3537: MKLIST(l,new);
3538: return l;
3539: }
3540:
3541: VECT ltov(LIST l)
3542: {
3543: NODE n;
3544: int i,len;
3545: VECT v;
3546:
3547: n = BDY(l);
3548: len = length(n);
3549: MKVECT(v,len);
3550: for ( i = 0; i < len; i++, n = NEXT(n) )
3551: BDY(v)[i] = BDY(n);
3552: return v;
3553: }
3554:
3555: DL subdl(int nv,DL d1,DL d2)
3556: {
3557: int i;
3558: DL d;
3559:
3560: NEWDL(d,nv);
3561: d->td = d1->td-d2->td;
3562: for ( i = 0; i < nv; i++ )
3563: d->d[i] = d1->d[i]-d2->d[i];
3564: return d;
3565: }
3566:
3567: DP dltodp(int nv,DL d)
3568: {
3569: MP mp;
3570: DP dp;
3571:
3572: NEWMP(mp); mp->dl = d; C(mp) = (Obj)ONE;
3573: NEXT(mp) = 0; MKDP(nv,mp,dp); dp->sugar = d->td;
3574: return dp;
3575: }
3576:
3577: LIST sumi_simplify(int nv,DL t,DP p,NODE f2,int simp)
3578: {
3579: DL d,h,hw;
3580: DP u,w,dp;
3581: int n,i,last;
3582: LIST *v;
3583: LIST list;
3584: NODE s,r;
3585:
3586: d = t; u = p;
3587: /* only the last history is used */
3588: if ( f2 && simp && t->td != 0 ) {
3589: adddl(nv,t,HDL(p),&h);
3590: n = length(f2);
3591: last = 1;
3592: if ( simp > 1 ) last = n;
3593: v = (LIST *)ALLOCA(n*sizeof(LIST));
3594: for ( r = f2, i = 0; r; r = NEXT(r), i++ ) v[n-i-1] = BDY(r);
3595: for ( i = 0; i < last; i++ ) {
3596: for ( s = BDY((LIST)v[i]); s; s = NEXT(s) ) {
3597: w = (DP)BDY(s); hw = HDL(w);
3598: if ( _dl_redble(hw,h,nv) ) {
3599: u = w;
3600: d = subdl(nv,h,hw);
3601: goto fin;
3602: }
3603: }
3604: }
3605: }
3606: fin:
3607: dp = dltodp(nv,d);
3608: r = mknode(2,dp,u);
3609: MKLIST(list,r);
3610: return list;
3611: }
3612:
3613: LIST sumi_symbolic(NODE l,int q,NODE f2,DP *g,int simp)
3614: {
3615: int nv;
3616: NODE t,r;
3617: NODE f0,f,fd0,fd,done0,done,red0,red;
3618: DL h,d;
3619: DP mul;
3620: int m;
3621: LIST tp,l0,l1,l2,l3,list;
3622: VECT v0,v1,v2,v3;
3623:
3624: nv = ((DP)BDY(l))->nv;
3625: t = 0;
3626:
3627: f0 = 0; fd0 = 0; done0 = 0; red0 = 0;
3628:
3629: for ( ; l; l = NEXT(l) ) {
3630: t = symb_merge(t,dp_dllist((DP)BDY(l)),nv);
3631: NEXTNODE(fd0,fd); BDY(fd) = BDY(l);
3632: }
3633:
3634: while ( t ) {
3635: h = (DL)BDY(t);
3636: NEXTNODE(done0,done); BDY(done) = dltodp(nv,h);
3637: t = NEXT(t);
3638: for(m = 0; m < q; m++)
3639: if ( _dl_redble(HDL(g[m]),h,nv) ) break;
3640: if ( m == q ) {
3641: } else {
3642: d = subdl(nv,h,HDL(g[m]));
3643: tp = sumi_simplify(nv,d,g[m],f2,simp);
3644:
3645: muldm(CO,ARG1(BDY(tp)),BDY((DP)ARG0(BDY(tp))),&mul);
3646: t = symb_merge(t,NEXT(dp_dllist(mul)),nv);
3647:
3648: NEXTNODE(f0,f); BDY(f) = tp;
3649: NEXTNODE(fd0,fd); BDY(fd) = mul;
3650: NEXTNODE(red0,red); BDY(red) = mul;
3651: }
3652: }
3653: if ( fd0 ) NEXT(fd) = 0; MKLIST(l0,fd0);
3654: v0 = ltov(l0);
3655: if ( done0 ) NEXT(done) = 0; MKLIST(l1,done0);
3656: v1 = ltov(l1);
3657: if ( f0 ) NEXT(f) = 0; MKLIST(l2,f0);
3658: v2 = ltov(l2);
3659: if ( red0 ) NEXT(red) = 0; MKLIST(l3,red0);
3660: v3 = ltov(l3);
3661: r = mknode(4,v0,v1,v2,v3);
3662: MKLIST(list,r);
3663: return list;
3664: }
3665:
3666: void Psumi_symbolic(NODE arg,LIST *rp)
3667: {
3668: NODE l,f2;
3669: DP *g;
3670: int q,simp;
3671:
3672: l = BDY((LIST)ARG0(arg));
1.2 noro 3673: q = ZTOS((Q)ARG1(arg));
1.1 noro 3674: f2 = BDY((LIST)ARG2(arg));
3675: g = (DP *)BDY((VECT)ARG3(arg));
1.2 noro 3676: simp = ZTOS((Q)ARG4(arg));
1.1 noro 3677: *rp = sumi_symbolic(l,q,f2,g,simp);
3678: }
3679:
3680: void Psumi_updatepairs(NODE arg,LIST *rp)
3681: {
3682: LIST d,l;
3683: DP *f;
3684: int m;
3685:
3686: d = (LIST)ARG0(arg);
3687: f = (DP *)BDY((VECT)ARG1(arg));
1.2 noro 3688: m = ZTOS((Q)ARG2(arg));
1.1 noro 3689: *rp = sumi_updatepairs(d,f,m);
3690: }
3691:
3692: LIST remove_zero_from_list(LIST l)
3693: {
3694: NODE n,r0,r;
3695: LIST rl;
3696:
3697: asir_assert(l,O_LIST,"remove_zero_from_list");
3698: n = BDY(l);
3699: for ( r0 = 0; n; n = NEXT(n) )
3700: if ( BDY(n) ) {
3701: NEXTNODE(r0,r);
3702: BDY(r) = BDY(n);
3703: }
3704: if ( r0 )
3705: NEXT(r) = 0;
3706: MKLIST(rl,r0);
3707: return rl;
3708: }
3709:
3710: int get_field_type(P p)
3711: {
3712: int type,t;
3713: DCP dc;
3714:
3715: if ( !p )
3716: return 0;
3717: else if ( NUM(p) )
3718: return NID((Num)p);
3719: else {
3720: type = 0;
3721: for ( dc = DC(p); dc; dc = NEXT(dc) ) {
3722: t = get_field_type(COEF(dc));
3723: if ( !t )
3724: continue;
3725: if ( t < 0 )
3726: return t;
3727: if ( !type )
3728: type = t;
3729: else if ( t != type )
3730: return -1;
3731: }
3732: return type;
3733: }
3734: }
3735:
3736: void Pdpv_ord(NODE arg,Obj *rp)
3737: {
3738: int ac,id;
3739: LIST shift;
3740:
3741: ac = argc(arg);
3742: if ( ac ) {
1.2 noro 3743: id = ZTOS((Q)ARG0(arg));
1.1 noro 3744: if ( ac > 1 && ARG1(arg) && OID((Obj)ARG1(arg))==O_LIST )
3745: shift = (LIST)ARG1(arg);
3746: else
3747: shift = 0;
3748: create_modorder_spec(id,shift,&dp_current_modspec);
3749: }
3750: *rp = dp_current_modspec->obj;
3751: }
3752:
3753: extern int dpm_ispot;
3754:
3755: void Pdpm_ord(NODE arg,LIST *rp)
3756: {
3757: Z q;
3758: NODE nd;
3759: struct order_spec *spec;
3760:
3761: if ( arg ) {
3762: nd = BDY((LIST)ARG0(arg));
3763: if ( !create_order_spec(0,(Obj)ARG1(nd),&spec) )
3764: error("dpm_ord : invalid order specification");
1.2 noro 3765: initdpm(spec,ZTOS((Q)ARG0(nd)));
1.1 noro 3766: }
1.2 noro 3767: STOZ(dpm_ispot,q);
1.1 noro 3768: nd = mknode(2,q,dp_current_spec->obj);
3769: MKLIST(*rp,nd);
3770: }
3771:
3772: void Pdpm_hm(NODE arg,DPM *rp)
3773: {
3774: DPM p;
3775:
3776: p = (DPM)ARG0(arg); asir_assert(p,O_DPM,"dpm_hm");
3777: dpm_hm(p,rp);
3778: }
3779:
3780: void Pdpm_ht(NODE arg,DPM *rp)
3781: {
3782: DPM p;
3783:
3784: p = (DPM)ARG0(arg); asir_assert(p,O_DPM,"dp_ht");
3785: dpm_ht(p,rp);
3786: }
3787:
3788: void Pdpm_hc(NODE arg,Obj *rp)
3789: {
3790: asir_assert(ARG0(arg),O_DPM,"dpm_hc");
3791: if ( !ARG0(arg) )
3792: *rp = 0;
3793: else
3794: *rp = BDY((DPM)ARG0(arg))->c;
3795: }
3796:
3797:
3798: void Pdpv_ht(NODE arg,LIST *rp)
3799: {
3800: NODE n;
3801: DP ht;
3802: int pos;
3803: DPV p;
3804: Z q;
3805:
3806: asir_assert(ARG0(arg),O_DPV,"dpv_ht");
3807: p = (DPV)ARG0(arg);
3808: pos = dpv_hp(p);
3809: if ( pos < 0 )
3810: ht = 0;
3811: else
3812: dp_ht(BDY(p)[pos],&ht);
1.2 noro 3813: STOZ(pos,q);
1.1 noro 3814: n = mknode(2,q,ht);
3815: MKLIST(*rp,n);
3816: }
3817:
3818: void Pdpv_hm(NODE arg,LIST *rp)
3819: {
3820: NODE n;
3821: DP ht;
3822: int pos;
3823: DPV p;
3824: Z q;
3825:
3826: asir_assert(ARG0(arg),O_DPV,"dpv_hm");
3827: p = (DPV)ARG0(arg);
3828: pos = dpv_hp(p);
3829: if ( pos < 0 )
3830: ht = 0;
3831: else
3832: dp_hm(BDY(p)[pos],&ht);
1.2 noro 3833: STOZ(pos,q);
1.1 noro 3834: n = mknode(2,q,ht);
3835: MKLIST(*rp,n);
3836: }
3837:
3838: void Pdpv_hc(NODE arg,LIST *rp)
3839: {
3840: NODE n;
3841: P hc;
3842: int pos;
3843: DPV p;
3844: Z q;
3845:
3846: asir_assert(ARG0(arg),O_DPV,"dpv_hc");
3847: p = (DPV)ARG0(arg);
3848: pos = dpv_hp(p);
3849: if ( pos < 0 )
3850: hc = 0;
3851: else
3852: hc = (P)BDY(BDY(p)[pos])->c;
1.2 noro 3853: STOZ(pos,q);
1.1 noro 3854: n = mknode(2,q,hc);
3855: MKLIST(*rp,n);
3856: }
3857:
3858: int dpv_hp(DPV p)
3859: {
3860: int len,i,maxp,maxw,w,slen;
3861: int *shift;
3862: DP *e;
3863:
3864: len = p->len;
3865: e = p->body;
3866: slen = dp_current_modspec->len;
3867: shift = dp_current_modspec->degree_shift;
3868: switch ( dp_current_modspec->id ) {
3869: case ORD_REVGRADLEX:
3870: for ( maxp = -1, i = 0; i < len; i++ )
3871: if ( !e[i] ) continue;
3872: else if ( maxp < 0 ) {
3873: maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
3874: } else {
3875: w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
3876: if ( w >= maxw ) {
3877: maxw = w; maxp = i;
3878: }
3879: }
3880: return maxp;
3881: case ORD_GRADLEX:
3882: for ( maxp = -1, i = 0; i < len; i++ )
3883: if ( !e[i] ) continue;
3884: else if ( maxp < 0 ) {
3885: maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
3886: } else {
3887: w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
3888: if ( w > maxw ) {
3889: maxw = w; maxp = i;
3890: }
3891: }
3892: return maxp;
3893: break;
3894: case ORD_LEX:
3895: for ( i = 0; i < len; i++ )
3896: if ( e[i] ) return i;
3897: return -1;
3898: break;
3899: }
3900: }
3901:
3902: int get_opt(char *key0,Obj *r) {
3903: NODE tt,p;
3904: char *key;
3905:
3906: if ( current_option ) {
3907: for ( tt = current_option; tt; tt = NEXT(tt) ) {
3908: p = BDY((LIST)BDY(tt));
3909: key = BDY((STRING)BDY(p));
3910: /* value = (Obj)BDY(NEXT(p)); */
3911: if ( !strcmp(key,key0) ) {
3912: *r = (Obj)BDY(NEXT(p));
3913: return 1;
3914: }
3915: }
3916: }
3917: return 0;
3918: }
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 / asir2018 / builtin