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