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