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