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