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