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