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