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