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