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