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