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