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