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