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