Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.89
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.68 noro 9: * conditions of this Agreement. For the avoidance of doubt, you acquire * only a limited right to use the SOFTWARE hereunder, and FLL or any
1.5 noro 10: * third party developer retains all rights, including but not limited to
11: * copyrights, in and to the SOFTWARE.
12: *
13: * (1) FLL does not grant you a license in any way for commercial
14: * purposes. You may use the SOFTWARE only for non-commercial and
15: * non-profit purposes only, such as academic, research and internal
16: * business use.
17: * (2) The SOFTWARE is protected by the Copyright Law of Japan and
18: * international copyright treaties. If you make copies of the SOFTWARE,
19: * with or without modification, as permitted hereunder, you shall affix
20: * to all such copies of the SOFTWARE the above copyright notice.
21: * (3) An explicit reference to this SOFTWARE and its copyright owner
22: * shall be made on your publication or presentation in any form of the
23: * results obtained by use of the SOFTWARE.
24: * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.6 noro 25: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.5 noro 26: * for such modification or the source code of the modified part of the
27: * SOFTWARE.
28: *
29: * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
30: * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
31: * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
32: * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
33: * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
34: * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
35: * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
36: * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
37: * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
38: * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
39: * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
40: * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
41: * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
42: * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
43: * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
44: * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
45: * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
46: *
1.89 ! noro 47: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.88 2013/06/14 04:47:17 ohara Exp $
1.5 noro 48: */
1.1 noro 49: #include "ca.h"
50: #include "base.h"
51: #include "parse.h"
52:
1.61 noro 53: extern int dp_fcoeffs;
1.8 noro 54: extern int dp_nelim;
55: extern int dp_order_pair_length;
56: extern struct order_pair *dp_order_pair;
1.46 noro 57: extern struct order_spec *dp_current_spec;
1.52 noro 58: extern struct modorder_spec *dp_current_modspec;
1.8 noro 59:
1.11 noro 60: int do_weyl;
1.1 noro 61:
1.44 noro 62: void Pdp_sort();
1.32 noro 63: void Pdp_mul_trunc(),Pdp_quo();
1.64 noro 64: void Pdp_ord(), Pdp_ptod(), Pdp_dtop(), Phomogenize();
1.1 noro 65: void Pdp_ptozp(), Pdp_ptozp2(), Pdp_red(), Pdp_red2(), Pdp_lcm(), Pdp_redble();
66: void Pdp_sp(), Pdp_hm(), Pdp_ht(), Pdp_hc(), Pdp_rest(), Pdp_td(), Pdp_sugar();
1.30 ohara 67: void Pdp_set_sugar();
1.1 noro 68: void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv();
69: void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat();
1.70 noro 70: void Pdp_nf(),Pdp_true_nf(),Pdp_true_nf_marked(),Pdp_true_nf_marked_mod();
1.79 noro 71: void Pdp_true_nf_and_quotient_marked(),Pdp_true_nf_and_quotient_marked_mod();
1.1 noro 72: void Pdp_nf_mod(),Pdp_true_nf_mod();
73: void Pdp_criB(),Pdp_nelim();
1.9 noro 74: void Pdp_minp(),Pdp_sp_mod();
1.1 noro 75: void Pdp_homo(),Pdp_dehomo();
1.16 noro 76: void Pdp_gr_mod_main(),Pdp_gr_f_main();
1.1 noro 77: void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags();
1.63 noro 78: void Pdp_interreduce();
1.16 noro 79: void Pdp_f4_main(),Pdp_f4_mod_main(),Pdp_f4_f_main();
1.1 noro 80: void Pdp_gr_print();
1.28 noro 81: void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_mdtod(), Pdp_nf_tab_f();
1.8 noro 82: void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
83: void Pdp_cont();
1.22 noro 84: void Pdp_gr_checklist();
1.52 noro 85: void Pdp_ltod(),Pdpv_ord(),Pdpv_ht(),Pdpv_hm(),Pdpv_hc();
1.1 noro 86:
1.13 noro 87: void Pdp_weyl_red();
88: void Pdp_weyl_sp();
89: void Pdp_weyl_nf(),Pdp_weyl_nf_mod();
1.16 noro 90: void Pdp_weyl_gr_main(),Pdp_weyl_gr_mod_main(),Pdp_weyl_gr_f_main();
91: void Pdp_weyl_f4_main(),Pdp_weyl_f4_mod_main(),Pdp_weyl_f4_f_main();
1.13 noro 92: void Pdp_weyl_mul(),Pdp_weyl_mul_mod();
1.15 noro 93: void Pdp_weyl_set_weight();
1.77 noro 94: void Pdp_set_weight(),Pdp_set_top_weight(),Pdp_set_module_weight();
1.16 noro 95: void Pdp_nf_f(),Pdp_weyl_nf_f();
96: void Pdp_lnf_f();
1.62 noro 97: void Pnd_gr(),Pnd_gr_trace(),Pnd_f4(),Pnd_f4_trace();
1.75 noro 98: void Pnd_gr_postproc(), Pnd_weyl_gr_postproc();
1.89 ! noro 99: void Pnd_gr_recompute_trace(), Pnd_btog();
1.38 noro 100: void Pnd_weyl_gr(),Pnd_weyl_gr_trace();
1.83 noro 101: void Pnd_nf(),Pnd_weyl_nf();
1.49 noro 102: void Pdp_initial_term();
103: void Pdp_order();
1.66 noro 104: void Pdp_inv_or_split();
1.74 noro 105: void Pdp_compute_last_t();
1.68 noro 106: void Pdp_compute_last_w();
1.70 noro 107: void Pdp_compute_essential_df();
1.72 noro 108: void Pdp_get_denomlist();
1.80 noro 109: void Pdp_symb_add();
1.82 noro 110: void Pdp_mono_raddec();
1.84 noro 111: void Pdp_mono_reduce();
1.49 noro 112:
113: LIST dp_initial_term();
114: LIST dp_order();
115: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
116: int *modular,struct order_spec **ord);
1.88 ohara 117: NODE dp_inv_or_split(NODE gb,DP f,struct order_spec *spec, DP *inv);
1.11 noro 118:
1.25 noro 119: LIST remove_zero_from_list(LIST);
120:
1.1 noro 121: struct ftab dp_tab[] = {
1.8 noro 122: /* content reduction */
1.1 noro 123: {"dp_ptozp",Pdp_ptozp,1},
124: {"dp_ptozp2",Pdp_ptozp2,2},
125: {"dp_prim",Pdp_prim,1},
1.8 noro 126: {"dp_red_coef",Pdp_red_coef,2},
127: {"dp_cont",Pdp_cont,1},
128:
1.11 noro 129: /* polynomial ring */
1.32 noro 130: /* special operations */
131: {"dp_mul_trunc",Pdp_mul_trunc,3},
132: {"dp_quo",Pdp_quo,2},
133:
1.8 noro 134: /* s-poly */
135: {"dp_sp",Pdp_sp,2},
136: {"dp_sp_mod",Pdp_sp_mod,3},
137:
138: /* m-reduction */
1.1 noro 139: {"dp_red",Pdp_red,3},
140: {"dp_red_mod",Pdp_red_mod,4},
1.8 noro 141:
142: /* normal form */
1.1 noro 143: {"dp_nf",Pdp_nf,4},
1.16 noro 144: {"dp_nf_f",Pdp_nf_f,4},
1.1 noro 145: {"dp_true_nf",Pdp_true_nf,4},
1.67 noro 146: {"dp_true_nf_marked",Pdp_true_nf_marked,4},
1.73 noro 147: {"dp_true_nf_and_quotient_marked",Pdp_true_nf_and_quotient_marked,4},
1.79 noro 148: {"dp_true_nf_and_quotient_marked_mod",Pdp_true_nf_and_quotient_marked_mod,5},
1.70 noro 149: {"dp_true_nf_marked_mod",Pdp_true_nf_marked_mod,5},
1.1 noro 150: {"dp_nf_mod",Pdp_nf_mod,5},
151: {"dp_true_nf_mod",Pdp_true_nf_mod,5},
1.8 noro 152: {"dp_lnf_mod",Pdp_lnf_mod,3},
1.28 noro 153: {"dp_nf_tab_f",Pdp_nf_tab_f,2},
1.8 noro 154: {"dp_nf_tab_mod",Pdp_nf_tab_mod,3},
1.16 noro 155: {"dp_lnf_f",Pdp_lnf_f,2},
1.8 noro 156:
157: /* Buchberger algorithm */
1.46 noro 158: {"dp_gr_main",Pdp_gr_main,-5},
1.63 noro 159: {"dp_interreduce",Pdp_interreduce,3},
1.1 noro 160: {"dp_gr_mod_main",Pdp_gr_mod_main,5},
1.27 noro 161: {"dp_gr_f_main",Pdp_gr_f_main,4},
1.23 noro 162: {"dp_gr_checklist",Pdp_gr_checklist,2},
1.40 noro 163: {"nd_f4",Pnd_f4,4},
1.33 noro 164: {"nd_gr",Pnd_gr,4},
1.36 noro 165: {"nd_gr_trace",Pnd_gr_trace,5},
1.62 noro 166: {"nd_f4_trace",Pnd_f4_trace,5},
1.58 noro 167: {"nd_gr_postproc",Pnd_gr_postproc,5},
1.89 ! noro 168: #if 0
1.86 noro 169: {"nd_gr_recompute_trace",Pnd_gr_recompute_trace,5},
1.89 ! noro 170: #endif
! 171: {"nd_btog",Pnd_btog,5},
1.75 noro 172: {"nd_weyl_gr_postproc",Pnd_weyl_gr_postproc,5},
1.38 noro 173: {"nd_weyl_gr",Pnd_weyl_gr,4},
174: {"nd_weyl_gr_trace",Pnd_weyl_gr_trace,5},
1.39 noro 175: {"nd_nf",Pnd_nf,5},
1.83 noro 176: {"nd_weyl_nf",Pnd_weyl_nf,5},
1.8 noro 177:
178: /* F4 algorithm */
1.1 noro 179: {"dp_f4_main",Pdp_f4_main,3},
180: {"dp_f4_mod_main",Pdp_f4_mod_main,4},
1.8 noro 181:
1.11 noro 182: /* weyl algebra */
1.12 noro 183: /* multiplication */
184: {"dp_weyl_mul",Pdp_weyl_mul,2},
1.13 noro 185: {"dp_weyl_mul_mod",Pdp_weyl_mul_mod,3},
1.12 noro 186:
1.11 noro 187: /* s-poly */
188: {"dp_weyl_sp",Pdp_weyl_sp,2},
189:
190: /* m-reduction */
191: {"dp_weyl_red",Pdp_weyl_red,3},
192:
193: /* normal form */
194: {"dp_weyl_nf",Pdp_weyl_nf,4},
1.13 noro 195: {"dp_weyl_nf_mod",Pdp_weyl_nf_mod,5},
1.16 noro 196: {"dp_weyl_nf_f",Pdp_weyl_nf_f,4},
1.11 noro 197:
198: /* Buchberger algorithm */
1.50 noro 199: {"dp_weyl_gr_main",Pdp_weyl_gr_main,-5},
1.11 noro 200: {"dp_weyl_gr_mod_main",Pdp_weyl_gr_mod_main,5},
1.16 noro 201: {"dp_weyl_gr_f_main",Pdp_weyl_gr_f_main,4},
1.11 noro 202:
203: /* F4 algorithm */
204: {"dp_weyl_f4_main",Pdp_weyl_f4_main,3},
1.19 noro 205: {"dp_weyl_f4_mod_main",Pdp_weyl_f4_mod_main,4},
1.11 noro 206:
1.15 noro 207: /* misc */
1.66 noro 208: {"dp_inv_or_split",Pdp_inv_or_split,3},
1.24 noro 209: {"dp_set_weight",Pdp_set_weight,-1},
1.77 noro 210: {"dp_set_module_weight",Pdp_set_module_weight,-1},
1.71 noro 211: {"dp_set_top_weight",Pdp_set_top_weight,-1},
1.15 noro 212: {"dp_weyl_set_weight",Pdp_weyl_set_weight,-1},
1.72 noro 213:
214: {"dp_get_denomlist",Pdp_get_denomlist,0},
1.8 noro 215: {0,0,0},
216: };
217:
218: struct ftab dp_supp_tab[] = {
219: /* setting flags */
1.44 noro 220: {"dp_sort",Pdp_sort,1},
1.8 noro 221: {"dp_ord",Pdp_ord,-1},
1.52 noro 222: {"dpv_ord",Pdpv_ord,-2},
1.8 noro 223: {"dp_set_kara",Pdp_set_kara,-1},
224: {"dp_nelim",Pdp_nelim,-1},
1.1 noro 225: {"dp_gr_flags",Pdp_gr_flags,-1},
226: {"dp_gr_print",Pdp_gr_print,-1},
1.8 noro 227:
228: /* converters */
1.64 noro 229: {"homogenize",Phomogenize,3},
1.53 noro 230: {"dp_ptod",Pdp_ptod,-2},
1.8 noro 231: {"dp_dtop",Pdp_dtop,2},
232: {"dp_homo",Pdp_homo,1},
233: {"dp_dehomo",Pdp_dehomo,1},
234: {"dp_etov",Pdp_etov,1},
235: {"dp_vtoe",Pdp_vtoe,1},
236: {"dp_dtov",Pdp_dtov,1},
237: {"dp_mdtod",Pdp_mdtod,1},
238: {"dp_mod",Pdp_mod,3},
239: {"dp_rat",Pdp_rat,1},
1.53 noro 240: {"dp_ltod",Pdp_ltod,-2},
1.8 noro 241:
242: /* criteria */
243: {"dp_cri1",Pdp_cri1,2},
244: {"dp_cri2",Pdp_cri2,2},
245: {"dp_criB",Pdp_criB,3},
246:
247: /* simple operation */
248: {"dp_subd",Pdp_subd,2},
249: {"dp_lcm",Pdp_lcm,2},
250: {"dp_hm",Pdp_hm,1},
251: {"dp_ht",Pdp_ht,1},
252: {"dp_hc",Pdp_hc,1},
1.52 noro 253: {"dpv_hm",Pdpv_hm,1},
254: {"dpv_ht",Pdpv_ht,1},
255: {"dpv_hc",Pdpv_hc,1},
1.8 noro 256: {"dp_rest",Pdp_rest,1},
1.49 noro 257: {"dp_initial_term",Pdp_initial_term,1},
258: {"dp_order",Pdp_order,1},
1.80 noro 259: {"dp_symb_add",Pdp_symb_add,2},
1.8 noro 260:
261: /* degree and size */
262: {"dp_td",Pdp_td,1},
263: {"dp_mag",Pdp_mag,1},
264: {"dp_sugar",Pdp_sugar,1},
1.30 ohara 265: {"dp_set_sugar",Pdp_set_sugar,2},
1.8 noro 266:
267: /* misc */
268: {"dp_mbase",Pdp_mbase,1},
269: {"dp_redble",Pdp_redble,2},
270: {"dp_sep",Pdp_sep,2},
271: {"dp_idiv",Pdp_idiv,2},
272: {"dp_tdiv",Pdp_tdiv,2},
273: {"dp_minp",Pdp_minp,2},
1.68 noro 274: {"dp_compute_last_w",Pdp_compute_last_w,5},
1.74 noro 275: {"dp_compute_last_t",Pdp_compute_last_t,5},
1.70 noro 276: {"dp_compute_essential_df",Pdp_compute_essential_df,2},
1.82 noro 277: {"dp_mono_raddec",Pdp_mono_raddec,2},
1.84 noro 278: {"dp_mono_reduce",Pdp_mono_reduce,2},
1.8 noro 279:
280: {0,0,0}
1.1 noro 281: };
1.44 noro 282:
1.68 noro 283: NODE compute_last_w(NODE g,NODE gh,int n,int **v,int row1,int **m1,int row2,int **m2);
1.74 noro 284: Q compute_last_t(NODE g,NODE gh,Q t,VECT w1,VECT w2,NODE *homo,VECT *wp);
285:
286: void Pdp_compute_last_t(NODE arg,LIST *rp)
287: {
288: NODE g,gh,homo,n;
289: LIST hlist;
290: VECT v1,v2,w;
291: Q t;
292:
293: g = (NODE)BDY((LIST)ARG0(arg));
294: gh = (NODE)BDY((LIST)ARG1(arg));
295: t = (Q)ARG2(arg);
296: v1 = (VECT)ARG3(arg);
297: v2 = (VECT)ARG4(arg);
298: t = compute_last_t(g,gh,t,v1,v2,&homo,&w);
299: MKLIST(hlist,homo);
300: n = mknode(3,t,w,hlist);
301: MKLIST(*rp,n);
302: }
1.68 noro 303:
304: void Pdp_compute_last_w(NODE arg,LIST *rp)
305: {
306: NODE g,gh,r;
307: VECT w,rv;
308: LIST l;
309: MAT w1,w2;
310: int row1,row2,i,j,n;
311: int *v;
312: int **m1,**m2;
313: Q q;
314:
315: g = (NODE)BDY((LIST)ARG0(arg));
316: gh = (NODE)BDY((LIST)ARG1(arg));
317: w = (VECT)ARG2(arg);
318: w1 = (MAT)ARG3(arg);
319: w2 = (MAT)ARG4(arg);
320: n = w1->col;
321: row1 = w1->row;
322: row2 = w2->row;
323: if ( w ) {
324: v = W_ALLOC(n);
325: for ( i = 0; i < n; i++ ) v[i] = QTOS((Q)w->body[i]);
326: } else v = 0;
327: m1 = almat(row1,n);
328: for ( i = 0; i < row1; i++ )
329: for ( j = 0; j < n; j++ ) m1[i][j] = QTOS((Q)w1->body[i][j]);
330: m2 = almat(row2,n);
331: for ( i = 0; i < row2; i++ )
332: for ( j = 0; j < n; j++ ) m2[i][j] = QTOS((Q)w2->body[i][j]);
333: r = compute_last_w(g,gh,n,&v,row1,m1,row2,m2);
334: if ( !r ) *rp = 0;
335: else {
336: MKVECT(rv,n);
337: for ( i = 0; i < n; i++ ) {
338: STOQ(v[i],q); rv->body[i] = (pointer)q;
339: }
340: MKLIST(l,r);
341: r = mknode(2,rv,l);
342: MKLIST(*rp,r);
343: }
344: }
345:
1.70 noro 346: NODE compute_essential_df(DP *g,DP *gh,int n);
347:
348: void Pdp_compute_essential_df(NODE arg,LIST *rp)
349: {
350: VECT g,gh;
351: NODE r;
352:
353: g = (VECT)ARG0(arg);
354: gh = (VECT)ARG1(arg);
355: r = (NODE)compute_essential_df((DP *)BDY(g),(DP *)BDY(gh),g->len);
356: MKLIST(*rp,r);
357: }
358:
1.66 noro 359: void Pdp_inv_or_split(arg,rp)
360: NODE arg;
361: Obj *rp;
362: {
363: NODE gb,newgb;
364: DP f,inv;
365: struct order_spec *spec;
366: LIST list;
367:
368: do_weyl = 0; dp_fcoeffs = 0;
369: asir_assert(ARG0(arg),O_LIST,"dp_inv_or_split");
370: asir_assert(ARG1(arg),O_DP,"dp_inv_or_split");
371: if ( !create_order_spec(0,(Obj)ARG2(arg),&spec) )
372: error("dp_inv_or_split : invalid order specification");
373: gb = BDY((LIST)ARG0(arg));
374: f = (DP)ARG1(arg);
375: newgb = (NODE)dp_inv_or_split(gb,f,spec,&inv);
376: if ( !newgb ) {
377: /* invertible */
378: *rp = (Obj)inv;
379: } else {
380: MKLIST(list,newgb);
381: *rp = (Obj)list;
382: }
383: }
384:
1.44 noro 385: void Pdp_sort(arg,rp)
386: NODE arg;
387: DP *rp;
388: {
389: dp_sort((DP)ARG0(arg),rp);
390: }
1.1 noro 391:
1.8 noro 392: void Pdp_mdtod(arg,rp)
393: NODE arg;
394: DP *rp;
395: {
396: MP m,mr,mr0;
397: DP p;
398: P t;
399:
400: p = (DP)ARG0(arg);
401: if ( !p )
402: *rp = 0;
403: else {
404: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
405: mptop(m->c,&t); NEXTMP(mr0,mr); mr->c = t; mr->dl = m->dl;
406: }
407: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
408: }
409: }
410:
411: void Pdp_sep(arg,rp)
412: NODE arg;
413: VECT *rp;
414: {
415: DP p,r;
416: MP m,t;
417: MP *w0,*w;
418: int i,n,d,nv,sugar;
419: VECT v;
420: pointer *pv;
421:
422: p = (DP)ARG0(arg); m = BDY(p);
423: d = QTOS((Q)ARG1(arg));
424: for ( t = m, n = 0; t; t = NEXT(t), n++ );
425: if ( d > n )
426: d = n;
427: MKVECT(v,d); *rp = v;
428: pv = BDY(v); nv = p->nv; sugar = p->sugar;
429: w0 = (MP *)MALLOC(d*sizeof(MP)); bzero(w0,d*sizeof(MP));
430: w = (MP *)MALLOC(d*sizeof(MP)); bzero(w,d*sizeof(MP));
431: for ( t = BDY(p), i = 0; t; t = NEXT(t), i++, i %= d ) {
432: NEXTMP(w0[i],w[i]); w[i]->c = t->c; w[i]->dl = t->dl;
433: }
434: for ( i = 0; i < d; i++ ) {
435: NEXT(w[i]) = 0; MKDP(nv,w0[i],r); r->sugar = sugar;
436: pv[i] = (pointer)r;
437: }
438: }
439:
440: void Pdp_idiv(arg,rp)
441: NODE arg;
442: DP *rp;
443: {
444: dp_idiv((DP)ARG0(arg),(Q)ARG1(arg),rp);
445: }
446:
447: void Pdp_cont(arg,rp)
448: NODE arg;
449: Q *rp;
450: {
451: dp_cont((DP)ARG0(arg),rp);
452: }
453:
454: void Pdp_dtov(arg,rp)
455: NODE arg;
456: VECT *rp;
457: {
458: dp_dtov((DP)ARG0(arg),rp);
459: }
460:
461: void Pdp_mbase(arg,rp)
462: NODE arg;
463: LIST *rp;
464: {
465: NODE mb;
466:
467: asir_assert(ARG0(arg),O_LIST,"dp_mbase");
468: dp_mbase(BDY((LIST)ARG0(arg)),&mb);
469: MKLIST(*rp,mb);
470: }
471:
472: void Pdp_etov(arg,rp)
473: NODE arg;
474: VECT *rp;
475: {
476: DP dp;
477: int n,i;
478: int *d;
479: VECT v;
480: Q t;
481:
482: dp = (DP)ARG0(arg);
483: asir_assert(dp,O_DP,"dp_etov");
484: n = dp->nv; d = BDY(dp)->dl->d;
485: MKVECT(v,n);
486: for ( i = 0; i < n; i++ ) {
487: STOQ(d[i],t); v->body[i] = (pointer)t;
488: }
489: *rp = v;
490: }
491:
492: void Pdp_vtoe(arg,rp)
493: NODE arg;
494: DP *rp;
495: {
496: DP dp;
497: DL dl;
498: MP m;
499: int n,i,td;
500: int *d;
501: VECT v;
502:
503: v = (VECT)ARG0(arg);
504: asir_assert(v,O_VECT,"dp_vtoe");
505: n = v->len;
506: NEWDL(dl,n); d = dl->d;
507: for ( i = 0, td = 0; i < n; i++ ) {
1.24 noro 508: d[i] = QTOS((Q)(v->body[i])); td += MUL_WEIGHT(d[i],i);
1.8 noro 509: }
510: dl->td = td;
511: NEWMP(m); m->dl = dl; m->c = (P)ONE; NEXT(m) = 0;
512: MKDP(n,m,dp); dp->sugar = td;
513: *rp = dp;
514: }
515:
516: void Pdp_lnf_mod(arg,rp)
517: NODE arg;
518: LIST *rp;
519: {
520: DP r1,r2;
521: NODE b,g,n;
522: int mod;
523:
524: asir_assert(ARG0(arg),O_LIST,"dp_lnf_mod");
525: asir_assert(ARG1(arg),O_LIST,"dp_lnf_mod");
526: asir_assert(ARG2(arg),O_N,"dp_lnf_mod");
527: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
528: mod = QTOS((Q)ARG2(arg));
529: dp_lnf_mod((DP)BDY(b),(DP)BDY(NEXT(b)),g,mod,&r1,&r2);
530: NEWNODE(n); BDY(n) = (pointer)r1;
531: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
532: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
533: }
534:
1.16 noro 535: void Pdp_lnf_f(arg,rp)
536: NODE arg;
537: LIST *rp;
538: {
539: DP r1,r2;
540: NODE b,g,n;
541:
542: asir_assert(ARG0(arg),O_LIST,"dp_lnf_f");
543: asir_assert(ARG1(arg),O_LIST,"dp_lnf_f");
544: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
545: dp_lnf_f((DP)BDY(b),(DP)BDY(NEXT(b)),g,&r1,&r2);
546: NEWNODE(n); BDY(n) = (pointer)r1;
547: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
548: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
549: }
550:
1.8 noro 551: void Pdp_nf_tab_mod(arg,rp)
552: NODE arg;
553: DP *rp;
554: {
555: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_mod");
556: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_mod");
557: asir_assert(ARG2(arg),O_N,"dp_nf_tab_mod");
558: dp_nf_tab_mod((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),
559: QTOS((Q)ARG2(arg)),rp);
1.28 noro 560: }
561:
562: void Pdp_nf_tab_f(arg,rp)
563: NODE arg;
564: DP *rp;
565: {
566: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_f");
567: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_f");
568: dp_nf_tab_f((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),rp);
1.8 noro 569: }
1.1 noro 570:
571: void Pdp_ord(arg,rp)
572: NODE arg;
573: Obj *rp;
574: {
1.46 noro 575: struct order_spec *spec;
1.51 noro 576: LIST v;
577: struct oLIST f;
578: Num homo;
579: int modular;
580:
581: f.id = O_LIST; f.body = 0;
1.59 noro 582: if ( !arg && !current_option )
1.46 noro 583: *rp = dp_current_spec->obj;
1.1 noro 584: else {
1.53 noro 585: if ( current_option )
586: parse_gr_option(&f,current_option,&v,&homo,&modular,&spec);
1.51 noro 587: else if ( !create_order_spec(0,(Obj)ARG0(arg),&spec) )
588: error("dp_ord : invalid order specification");
1.46 noro 589: initd(spec); *rp = spec->obj;
1.1 noro 590: }
591: }
592:
593: void Pdp_ptod(arg,rp)
594: NODE arg;
595: DP *rp;
596: {
1.53 noro 597: P p;
1.1 noro 598: NODE n;
599: VL vl,tvl;
1.53 noro 600: struct oLIST f;
601: int ac;
602: LIST v;
603: Num homo;
604: int modular;
605: struct order_spec *ord;
1.1 noro 606:
607: asir_assert(ARG0(arg),O_P,"dp_ptod");
1.53 noro 608: p = (P)ARG0(arg);
609: ac = argc(arg);
610: if ( ac == 1 ) {
611: if ( current_option ) {
612: f.id = O_LIST; f.body = mknode(1,p);
613: parse_gr_option(&f,current_option,&v,&homo,&modular,&ord);
1.54 noro 614: initd(ord);
1.53 noro 615: } else
616: error("dp_ptod : invalid argument");
617: } else {
618: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
619: v = (LIST)ARG1(arg);
620: }
621: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
1.1 noro 622: if ( !vl ) {
623: NEWVL(vl); tvl = vl;
624: } else {
625: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
626: }
627: VR(tvl) = VR((P)BDY(n));
628: }
629: if ( vl )
630: NEXT(tvl) = 0;
1.53 noro 631: ptod(CO,vl,p,rp);
1.64 noro 632: }
633:
634: void Phomogenize(arg,rp)
635: NODE arg;
636: P *rp;
637: {
638: P p;
639: DP d,h;
640: NODE n;
641: V hv;
642: VL vl,tvl,last;
643: struct oLIST f;
644: LIST v;
645:
646: asir_assert(ARG0(arg),O_P,"homogenize");
647: p = (P)ARG0(arg);
648: asir_assert(ARG1(arg),O_LIST,"homogenize");
649: v = (LIST)ARG1(arg);
650: asir_assert(ARG2(arg),O_P,"homogenize");
651: hv = VR((P)ARG2(arg));
652: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
653: if ( !vl ) {
654: NEWVL(vl); tvl = vl;
655: } else {
656: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
657: }
658: VR(tvl) = VR((P)BDY(n));
659: }
660: if ( vl ) {
661: last = tvl;
662: NEXT(tvl) = 0;
663: }
664: ptod(CO,vl,p,&d);
665: dp_homo(d,&h);
666: NEWVL(NEXT(last)); last = NEXT(last);
667: VR(last) = hv; NEXT(last) = 0;
668: dtop(CO,vl,h,rp);
1.1 noro 669: }
670:
1.52 noro 671: void Pdp_ltod(arg,rp)
672: NODE arg;
673: DPV *rp;
674: {
675: NODE n;
676: VL vl,tvl;
1.53 noro 677: LIST f,v;
678: int sugar,i,len,ac,modular;
679: Num homo;
680: struct order_spec *ord;
1.52 noro 681: DP *e;
682: NODE nd,t;
683:
1.53 noro 684: ac = argc(arg);
1.52 noro 685: asir_assert(ARG0(arg),O_LIST,"dp_ptod");
1.53 noro 686: f = (LIST)ARG0(arg);
687: if ( ac == 1 ) {
688: if ( current_option ) {
689: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.54 noro 690: initd(ord);
1.53 noro 691: } else
692: error("dp_ltod : invalid argument");
693: } else {
694: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
695: v = (LIST)ARG1(arg);
696: }
697: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
1.52 noro 698: if ( !vl ) {
699: NEWVL(vl); tvl = vl;
700: } else {
701: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
702: }
703: VR(tvl) = VR((P)BDY(n));
704: }
705: if ( vl )
706: NEXT(tvl) = 0;
1.53 noro 707:
708: nd = BDY(f);
1.52 noro 709: len = length(nd);
710: e = (DP *)MALLOC(len*sizeof(DP));
711: sugar = 0;
712: for ( i = 0, t = nd; i < len; i++, t = NEXT(t) ) {
713: ptod(CO,vl,(P)BDY(t),&e[i]);
714: if ( e[i] )
715: sugar = MAX(sugar,e[i]->sugar);
716: }
717: MKDPV(len,e,*rp);
718: }
719:
1.1 noro 720: void Pdp_dtop(arg,rp)
721: NODE arg;
722: P *rp;
723: {
724: NODE n;
725: VL vl,tvl;
726:
727: asir_assert(ARG0(arg),O_DP,"dp_dtop");
728: asir_assert(ARG1(arg),O_LIST,"dp_dtop");
729: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
730: if ( !vl ) {
731: NEWVL(vl); tvl = vl;
732: } else {
733: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
734: }
735: VR(tvl) = VR((P)BDY(n));
736: }
737: if ( vl )
738: NEXT(tvl) = 0;
739: dtop(CO,vl,(DP)ARG0(arg),rp);
740: }
741:
742: extern LIST Dist;
743:
744: void Pdp_ptozp(arg,rp)
745: NODE arg;
1.60 ohara 746: Obj *rp;
1.1 noro 747: {
1.60 ohara 748: Q t;
749: NODE tt,p;
750: NODE n,n0;
751: char *key;
752: DP pp;
753: LIST list;
754: int get_factor=0;
755:
1.1 noro 756: asir_assert(ARG0(arg),O_DP,"dp_ptozp");
1.60 ohara 757:
758: /* analyze the option */
759: if ( current_option ) {
760: for ( tt = current_option; tt; tt = NEXT(tt) ) {
761: p = BDY((LIST)BDY(tt));
762: key = BDY((STRING)BDY(p));
763: /* value = (Obj)BDY(NEXT(p)); */
764: if ( !strcmp(key,"factor") ) get_factor=1;
765: else {
766: error("ptozp: unknown option.");
767: }
768: }
769: }
770:
771: dp_ptozp3((DP)ARG0(arg),&t,&pp);
772:
773: /* printexpr(NULL,t); */
774: /* if the option factor is given, then it returns the answer
775: in the format [zpoly, num] where num*zpoly is equal to the argument.*/
776: if (get_factor) {
777: n0 = mknode(2,pp,t);
778: MKLIST(list,n0);
779: *rp = (Obj)list;
780: } else
781: *rp = (Obj)pp;
1.1 noro 782: }
783:
784: void Pdp_ptozp2(arg,rp)
785: NODE arg;
786: LIST *rp;
787: {
788: DP p0,p1,h,r;
789: NODE n0;
790:
791: p0 = (DP)ARG0(arg); p1 = (DP)ARG1(arg);
792: asir_assert(p0,O_DP,"dp_ptozp2");
793: asir_assert(p1,O_DP,"dp_ptozp2");
1.10 noro 794: dp_ptozp2(p0,p1,&h,&r);
1.1 noro 795: NEWNODE(n0); BDY(n0) = (pointer)h;
796: NEWNODE(NEXT(n0)); BDY(NEXT(n0)) = (pointer)r;
797: NEXT(NEXT(n0)) = 0;
798: MKLIST(*rp,n0);
799: }
800:
801: void Pdp_prim(arg,rp)
802: NODE arg;
803: DP *rp;
804: {
805: DP t;
806:
807: asir_assert(ARG0(arg),O_DP,"dp_prim");
808: dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
809: }
810:
811: void Pdp_mod(arg,rp)
812: NODE arg;
813: DP *rp;
814: {
815: DP p;
816: int mod;
817: NODE subst;
818:
819: asir_assert(ARG0(arg),O_DP,"dp_mod");
820: asir_assert(ARG1(arg),O_N,"dp_mod");
821: asir_assert(ARG2(arg),O_LIST,"dp_mod");
822: p = (DP)ARG0(arg); mod = QTOS((Q)ARG1(arg));
823: subst = BDY((LIST)ARG2(arg));
824: dp_mod(p,mod,subst,rp);
825: }
826:
827: void Pdp_rat(arg,rp)
828: NODE arg;
829: DP *rp;
830: {
831: asir_assert(ARG0(arg),O_DP,"dp_rat");
832: dp_rat((DP)ARG0(arg),rp);
833: }
834:
1.9 noro 835: extern int DP_Multiple;
836:
1.1 noro 837: void Pdp_nf(arg,rp)
838: NODE arg;
839: DP *rp;
840: {
841: NODE b;
842: DP *ps;
843: DP g;
844: int full;
845:
1.61 noro 846: do_weyl = 0; dp_fcoeffs = 0;
1.1 noro 847: asir_assert(ARG0(arg),O_LIST,"dp_nf");
848: asir_assert(ARG1(arg),O_DP,"dp_nf");
849: asir_assert(ARG2(arg),O_VECT,"dp_nf");
850: asir_assert(ARG3(arg),O_N,"dp_nf");
851: if ( !(g = (DP)ARG1(arg)) ) {
852: *rp = 0; return;
853: }
854: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
855: full = (Q)ARG3(arg) ? 1 : 0;
1.16 noro 856: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
1.1 noro 857: }
858:
1.11 noro 859: void Pdp_weyl_nf(arg,rp)
860: NODE arg;
861: DP *rp;
862: {
863: NODE b;
864: DP *ps;
865: DP g;
866: int full;
867:
868: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf");
869: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf");
870: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf");
871: asir_assert(ARG3(arg),O_N,"dp_weyl_nf");
872: if ( !(g = (DP)ARG1(arg)) ) {
873: *rp = 0; return;
874: }
875: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
876: full = (Q)ARG3(arg) ? 1 : 0;
1.12 noro 877: do_weyl = 1;
1.16 noro 878: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
879: do_weyl = 0;
880: }
881:
882: /* nf computation using field operations */
883:
884: void Pdp_nf_f(arg,rp)
885: NODE arg;
886: DP *rp;
887: {
888: NODE b;
889: DP *ps;
890: DP g;
891: int full;
892:
893: do_weyl = 0;
894: asir_assert(ARG0(arg),O_LIST,"dp_nf_f");
895: asir_assert(ARG1(arg),O_DP,"dp_nf_f");
896: asir_assert(ARG2(arg),O_VECT,"dp_nf_f");
897: asir_assert(ARG3(arg),O_N,"dp_nf_f");
898: if ( !(g = (DP)ARG1(arg)) ) {
899: *rp = 0; return;
900: }
901: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
902: full = (Q)ARG3(arg) ? 1 : 0;
903: dp_nf_f(b,g,ps,full,rp);
904: }
905:
906: void Pdp_weyl_nf_f(arg,rp)
907: NODE arg;
908: DP *rp;
909: {
910: NODE b;
911: DP *ps;
912: DP g;
913: int full;
914:
915: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_f");
916: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_f");
917: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_f");
918: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_f");
919: if ( !(g = (DP)ARG1(arg)) ) {
920: *rp = 0; return;
921: }
922: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
923: full = (Q)ARG3(arg) ? 1 : 0;
924: do_weyl = 1;
925: dp_nf_f(b,g,ps,full,rp);
1.12 noro 926: do_weyl = 0;
1.11 noro 927: }
928:
1.13 noro 929: void Pdp_nf_mod(arg,rp)
930: NODE arg;
931: DP *rp;
932: {
933: NODE b;
934: DP g;
935: DP *ps;
936: int mod,full,ac;
937: NODE n,n0;
938:
1.14 noro 939: do_weyl = 0;
1.13 noro 940: ac = argc(arg);
1.14 noro 941: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
942: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
943: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
944: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
945: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
1.13 noro 946: if ( !(g = (DP)ARG1(arg)) ) {
947: *rp = 0; return;
948: }
949: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
950: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
951: for ( n0 = n = 0; b; b = NEXT(b) ) {
952: NEXTNODE(n0,n);
953: BDY(n) = (pointer)QTOS((Q)BDY(b));
954: }
955: if ( n0 )
956: NEXT(n) = 0;
957: dp_nf_mod(n0,g,ps,mod,full,rp);
958: }
959:
1.1 noro 960: void Pdp_true_nf(arg,rp)
961: NODE arg;
962: LIST *rp;
963: {
964: NODE b,n;
965: DP *ps;
966: DP g;
967: DP nm;
968: P dn;
969: int full;
970:
1.61 noro 971: do_weyl = 0; dp_fcoeffs = 0;
1.1 noro 972: asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
973: asir_assert(ARG1(arg),O_DP,"dp_true_nf");
974: asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
975: asir_assert(ARG3(arg),O_N,"dp_nf");
976: if ( !(g = (DP)ARG1(arg)) ) {
977: nm = 0; dn = (P)ONE;
978: } else {
979: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
980: full = (Q)ARG3(arg) ? 1 : 0;
981: dp_true_nf(b,g,ps,full,&nm,&dn);
982: }
983: NEWNODE(n); BDY(n) = (pointer)nm;
984: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
985: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
986: }
987:
1.67 noro 988: void Pdp_true_nf_marked(arg,rp)
989: NODE arg;
990: LIST *rp;
991: {
992: NODE b,n;
993: DP *ps,*hps;
994: DP g;
995: DP nm;
1.69 noro 996: Q cont;
1.67 noro 997: P dn;
998: int full;
999:
1000: do_weyl = 0; dp_fcoeffs = 0;
1001: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_marked");
1002: asir_assert(ARG1(arg),O_DP,"dp_true_nf_marked");
1003: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_marked");
1004: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_marked");
1005: if ( !(g = (DP)ARG1(arg)) ) {
1006: nm = 0; dn = (P)ONE;
1007: } else {
1008: b = BDY((LIST)ARG0(arg));
1009: ps = (DP *)BDY((VECT)ARG2(arg));
1010: hps = (DP *)BDY((VECT)ARG3(arg));
1.69 noro 1011: dp_true_nf_marked(b,g,ps,hps,&nm,&cont,&dn);
1.67 noro 1012: }
1.69 noro 1013: n = mknode(3,nm,cont,dn);
1014: MKLIST(*rp,n);
1.67 noro 1015: }
1016:
1.73 noro 1017: DP *dp_true_nf_and_quotient_marked (NODE b,DP g,DP *ps,DP *hps,DP *rp,P *dnp);
1018:
1019: void Pdp_true_nf_and_quotient_marked(arg,rp)
1020: NODE arg;
1021: LIST *rp;
1022: {
1023: NODE b,n;
1024: DP *ps,*hps;
1025: DP g;
1026: DP nm;
1027: VECT quo;
1028: P dn;
1029: int full;
1030:
1031: do_weyl = 0; dp_fcoeffs = 0;
1032: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_and_quotient_marked");
1033: asir_assert(ARG1(arg),O_DP,"dp_true_nf_and_quotient_marked");
1034: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_and_quotient_marked");
1035: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_and_quotient_marked");
1036: if ( !(g = (DP)ARG1(arg)) ) {
1037: nm = 0; dn = (P)ONE;
1038: } else {
1039: b = BDY((LIST)ARG0(arg));
1040: ps = (DP *)BDY((VECT)ARG2(arg));
1041: hps = (DP *)BDY((VECT)ARG3(arg));
1042: NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
1043: quo->body = (pointer *)dp_true_nf_and_quotient_marked(b,g,ps,hps,&nm,&dn);
1044: }
1045: n = mknode(3,nm,dn,quo);
1046: MKLIST(*rp,n);
1047: }
1048:
1.79 noro 1049: DP *dp_true_nf_and_quotient_marked_mod (NODE b,DP g,DP *ps,DP *hps,int mod,DP *rp,P *dnp);
1050:
1051: void Pdp_true_nf_and_quotient_marked_mod(arg,rp)
1052: NODE arg;
1053: LIST *rp;
1054: {
1055: NODE b,n;
1056: DP *ps,*hps;
1057: DP g;
1058: DP nm;
1059: VECT quo;
1060: P dn;
1061: int full,mod;
1062:
1063: do_weyl = 0; dp_fcoeffs = 0;
1064: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_and_quotient_marked_mod");
1065: asir_assert(ARG1(arg),O_DP,"dp_true_nf_and_quotient_marked_mod");
1066: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_and_quotient_marked_mod");
1067: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_and_quotient_marked_mod");
1068: asir_assert(ARG4(arg),O_N,"dp_true_nf_and_quotient_marked_mod");
1069: if ( !(g = (DP)ARG1(arg)) ) {
1070: nm = 0; dn = (P)ONE;
1071: } else {
1072: b = BDY((LIST)ARG0(arg));
1073: ps = (DP *)BDY((VECT)ARG2(arg));
1074: hps = (DP *)BDY((VECT)ARG3(arg));
1075: mod = QTOS((Q)ARG4(arg));
1076: NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
1077: quo->body = (pointer *)dp_true_nf_and_quotient_marked_mod(b,g,ps,hps,mod,&nm,&dn);
1078: }
1079: n = mknode(3,nm,dn,quo);
1080: MKLIST(*rp,n);
1081: }
1082:
1.70 noro 1083: void Pdp_true_nf_marked_mod(arg,rp)
1084: NODE arg;
1085: LIST *rp;
1086: {
1087: NODE b,n;
1088: DP *ps,*hps;
1089: DP g;
1090: DP nm;
1091: P dn;
1092: int mod;
1093:
1094: do_weyl = 0; dp_fcoeffs = 0;
1095: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_marked_mod");
1096: asir_assert(ARG1(arg),O_DP,"dp_true_nf_marked_mod");
1097: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_marked_mod");
1098: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_marked_mod");
1099: asir_assert(ARG4(arg),O_N,"dp_true_nf_marked_mod");
1100: if ( !(g = (DP)ARG1(arg)) ) {
1101: nm = 0; dn = (P)ONE;
1102: } else {
1103: b = BDY((LIST)ARG0(arg));
1104: ps = (DP *)BDY((VECT)ARG2(arg));
1105: hps = (DP *)BDY((VECT)ARG3(arg));
1106: mod = QTOS((Q)ARG4(arg));
1107: dp_true_nf_marked_mod(b,g,ps,hps,mod,&nm,&dn);
1108: }
1109: n = mknode(2,nm,dn);
1110: MKLIST(*rp,n);
1111: }
1112:
1.13 noro 1113: void Pdp_weyl_nf_mod(arg,rp)
1.8 noro 1114: NODE arg;
1115: DP *rp;
1116: {
1117: NODE b;
1118: DP g;
1119: DP *ps;
1120: int mod,full,ac;
1.9 noro 1121: NODE n,n0;
1.8 noro 1122:
1123: ac = argc(arg);
1.14 noro 1124: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_mod");
1125: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_mod");
1126: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_mod");
1127: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_mod");
1128: asir_assert(ARG4(arg),O_N,"dp_weyl_nf_mod");
1.8 noro 1129: if ( !(g = (DP)ARG1(arg)) ) {
1130: *rp = 0; return;
1131: }
1132: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
1133: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
1.9 noro 1134: for ( n0 = n = 0; b; b = NEXT(b) ) {
1135: NEXTNODE(n0,n);
1136: BDY(n) = (pointer)QTOS((Q)BDY(b));
1137: }
1138: if ( n0 )
1139: NEXT(n) = 0;
1.13 noro 1140: do_weyl = 1;
1141: dp_nf_mod(n0,g,ps,mod,full,rp);
1142: do_weyl = 0;
1.8 noro 1143: }
1144:
1145: void Pdp_true_nf_mod(arg,rp)
1146: NODE arg;
1147: LIST *rp;
1148: {
1149: NODE b;
1150: DP g,nm;
1151: P dn;
1152: DP *ps;
1153: int mod,full;
1154: NODE n;
1155:
1.11 noro 1156: do_weyl = 0;
1.8 noro 1157: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
1158: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
1159: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
1160: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
1161: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
1162: if ( !(g = (DP)ARG1(arg)) ) {
1163: nm = 0; dn = (P)ONEM;
1164: } else {
1165: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
1166: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
1167: dp_true_nf_mod(b,g,ps,mod,full,&nm,&dn);
1168: }
1169: NEWNODE(n); BDY(n) = (pointer)nm;
1170: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
1171: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.1 noro 1172: }
1173:
1174: void Pdp_tdiv(arg,rp)
1175: NODE arg;
1176: DP *rp;
1177: {
1178: MP m,mr,mr0;
1179: DP p;
1180: Q c;
1181: N d,q,r;
1182: int sgn;
1183:
1184: asir_assert(ARG0(arg),O_DP,"dp_tdiv");
1185: asir_assert(ARG1(arg),O_N,"dp_tdiv");
1186: p = (DP)ARG0(arg); d = NM((Q)ARG1(arg)); sgn = SGN((Q)ARG1(arg));
1187: if ( !p )
1188: *rp = 0;
1189: else {
1190: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
1191: divn(NM((Q)m->c),d,&q,&r);
1192: if ( r ) {
1193: *rp = 0; return;
1194: } else {
1195: NEXTMP(mr0,mr); NTOQ(q,SGN((Q)m->c)*sgn,c);
1196: mr->c = (P)c; mr->dl = m->dl;
1197: }
1198: }
1199: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
1200: }
1201: }
1202:
1203: void Pdp_red_coef(arg,rp)
1204: NODE arg;
1205: DP *rp;
1206: {
1207: MP m,mr,mr0;
1208: P q,r;
1209: DP p;
1210: P mod;
1211:
1212: p = (DP)ARG0(arg); mod = (P)ARG1(arg);
1213: asir_assert(p,O_DP,"dp_red_coef");
1214: asir_assert(mod,O_P,"dp_red_coef");
1215: if ( !p )
1216: *rp = 0;
1217: else {
1218: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
1219: divsrp(CO,m->c,mod,&q,&r);
1220: if ( r ) {
1221: NEXTMP(mr0,mr); mr->c = r; mr->dl = m->dl;
1222: }
1223: }
1224: if ( mr0 ) {
1225: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
1226: } else
1227: *rp = 0;
1228: }
1229: }
1230:
1231: void Pdp_redble(arg,rp)
1232: NODE arg;
1233: Q *rp;
1234: {
1235: asir_assert(ARG0(arg),O_DP,"dp_redble");
1236: asir_assert(ARG1(arg),O_DP,"dp_redble");
1237: if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
1238: *rp = ONE;
1239: else
1240: *rp = 0;
1241: }
1242:
1243: void Pdp_red_mod(arg,rp)
1244: NODE arg;
1245: LIST *rp;
1246: {
1247: DP h,r;
1248: P dmy;
1249: NODE n;
1250:
1.11 noro 1251: do_weyl = 0;
1.1 noro 1252: asir_assert(ARG0(arg),O_DP,"dp_red_mod");
1253: asir_assert(ARG1(arg),O_DP,"dp_red_mod");
1254: asir_assert(ARG2(arg),O_DP,"dp_red_mod");
1255: asir_assert(ARG3(arg),O_N,"dp_red_mod");
1256: dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),QTOS((Q)ARG3(arg)),
1257: &h,&r,&dmy);
1258: NEWNODE(n); BDY(n) = (pointer)h;
1259: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
1260: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1261: }
1.13 noro 1262:
1.1 noro 1263: void Pdp_subd(arg,rp)
1264: NODE arg;
1265: DP *rp;
1266: {
1267: DP p1,p2;
1268:
1269: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1270: asir_assert(p1,O_DP,"dp_subd");
1271: asir_assert(p2,O_DP,"dp_subd");
1272: dp_subd(p1,p2,rp);
1273: }
1274:
1.80 noro 1275: void Pdp_symb_add(arg,rp)
1276: NODE arg;
1277: DP *rp;
1278: {
1279: DP p1,p2,r;
1280: NODE s0;
1281: MP mp0,mp;
1282: int nv;
1283:
1284: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1285: asir_assert(p1,O_DP,"dp_symb_add");
1286: asir_assert(p2,O_DP,"dp_symb_add");
1287: if ( p1->nv != p2->nv )
1288: error("dp_sumb_add : invalid input");
1289: nv = p1->nv;
1290: s0 = symb_merge(dp_dllist(p1),dp_dllist(p2),nv);
1291: for ( mp0 = 0; s0; s0 = NEXT(s0) ) {
1292: NEXTMP(mp0,mp); mp->dl = (DL)BDY(s0); mp->c = (P)ONE;
1293: }
1294: NEXT(mp) = 0;
1295: MKDP(nv,mp0,r); r->sugar = MAX(p1->sugar,p2->sugar);
1296: *rp = r;
1297: }
1298:
1.32 noro 1299: void Pdp_mul_trunc(arg,rp)
1300: NODE arg;
1301: DP *rp;
1302: {
1303: DP p1,p2,p;
1304:
1305: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); p = (DP)ARG2(arg);
1306: asir_assert(p1,O_DP,"dp_mul_trunc");
1307: asir_assert(p2,O_DP,"dp_mul_trunc");
1308: asir_assert(p,O_DP,"dp_mul_trunc");
1309: comm_muld_trunc(CO,p1,p2,BDY(p)->dl,rp);
1310: }
1311:
1312: void Pdp_quo(arg,rp)
1313: NODE arg;
1314: DP *rp;
1315: {
1316: DP p1,p2;
1317:
1318: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1319: asir_assert(p1,O_DP,"dp_quo");
1320: asir_assert(p2,O_DP,"dp_quo");
1321: comm_quod(CO,p1,p2,rp);
1322: }
1323:
1.12 noro 1324: void Pdp_weyl_mul(arg,rp)
1325: NODE arg;
1326: DP *rp;
1327: {
1328: DP p1,p2;
1329:
1330: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1.32 noro 1331: asir_assert(p1,O_DP,"dp_weyl_mul"); asir_assert(p2,O_DP,"dp_weyl_mul");
1.12 noro 1332: do_weyl = 1;
1333: muld(CO,p1,p2,rp);
1.13 noro 1334: do_weyl = 0;
1335: }
1336:
1337: void Pdp_weyl_mul_mod(arg,rp)
1338: NODE arg;
1339: DP *rp;
1340: {
1341: DP p1,p2;
1342: Q m;
1343:
1344: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); m = (Q)ARG2(arg);
1345: asir_assert(p1,O_DP,"dp_weyl_mul_mod");
1346: asir_assert(p2,O_DP,"dp_mul_mod");
1347: asir_assert(m,O_N,"dp_mul_mod");
1348: do_weyl = 1;
1349: mulmd(CO,QTOS(m),p1,p2,rp);
1.12 noro 1350: do_weyl = 0;
1351: }
1352:
1.1 noro 1353: void Pdp_red(arg,rp)
1354: NODE arg;
1355: LIST *rp;
1356: {
1357: NODE n;
1.4 noro 1358: DP head,rest,dmy1;
1.1 noro 1359: P dmy;
1360:
1.11 noro 1361: do_weyl = 0;
1.1 noro 1362: asir_assert(ARG0(arg),O_DP,"dp_red");
1363: asir_assert(ARG1(arg),O_DP,"dp_red");
1364: asir_assert(ARG2(arg),O_DP,"dp_red");
1.4 noro 1365: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.1 noro 1366: NEWNODE(n); BDY(n) = (pointer)head;
1367: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
1368: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1369: }
1370:
1.11 noro 1371: void Pdp_weyl_red(arg,rp)
1372: NODE arg;
1373: LIST *rp;
1374: {
1375: NODE n;
1376: DP head,rest,dmy1;
1377: P dmy;
1378:
1379: asir_assert(ARG0(arg),O_DP,"dp_weyl_red");
1380: asir_assert(ARG1(arg),O_DP,"dp_weyl_red");
1381: asir_assert(ARG2(arg),O_DP,"dp_weyl_red");
1.12 noro 1382: do_weyl = 1;
1.11 noro 1383: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.12 noro 1384: do_weyl = 0;
1.11 noro 1385: NEWNODE(n); BDY(n) = (pointer)head;
1386: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
1387: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1388: }
1389:
1.1 noro 1390: void Pdp_sp(arg,rp)
1391: NODE arg;
1392: DP *rp;
1393: {
1394: DP p1,p2;
1395:
1.11 noro 1396: do_weyl = 0;
1.1 noro 1397: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1398: asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
1399: dp_sp(p1,p2,rp);
1400: }
1401:
1.11 noro 1402: void Pdp_weyl_sp(arg,rp)
1403: NODE arg;
1404: DP *rp;
1405: {
1406: DP p1,p2;
1407:
1408: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1409: asir_assert(p1,O_DP,"dp_weyl_sp"); asir_assert(p2,O_DP,"dp_sp");
1.12 noro 1410: do_weyl = 1;
1.11 noro 1411: dp_sp(p1,p2,rp);
1.12 noro 1412: do_weyl = 0;
1.11 noro 1413: }
1414:
1.1 noro 1415: void Pdp_sp_mod(arg,rp)
1416: NODE arg;
1417: DP *rp;
1418: {
1419: DP p1,p2;
1420: int mod;
1421:
1.11 noro 1422: do_weyl = 0;
1.1 noro 1423: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1424: asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
1425: asir_assert(ARG2(arg),O_N,"dp_sp_mod");
1426: mod = QTOS((Q)ARG2(arg));
1427: dp_sp_mod(p1,p2,mod,rp);
1428: }
1429:
1430: void Pdp_lcm(arg,rp)
1431: NODE arg;
1432: DP *rp;
1433: {
1434: int i,n,td;
1435: DL d1,d2,d;
1436: MP m;
1437: DP p1,p2;
1438:
1439: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1440: asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
1441: n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
1442: NEWDL(d,n);
1443: for ( i = 0, td = 0; i < n; i++ ) {
1.24 noro 1444: d->d[i] = MAX(d1->d[i],d2->d[i]); td += MUL_WEIGHT(d->d[i],i);
1.1 noro 1445: }
1446: d->td = td;
1447: NEWMP(m); m->dl = d; m->c = (P)ONE; NEXT(m) = 0;
1448: MKDP(n,m,*rp); (*rp)->sugar = td; /* XXX */
1449: }
1450:
1451: void Pdp_hm(arg,rp)
1452: NODE arg;
1453: DP *rp;
1454: {
1455: DP p;
1456:
1457: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
1458: dp_hm(p,rp);
1459: }
1460:
1461: void Pdp_ht(arg,rp)
1462: NODE arg;
1463: DP *rp;
1464: {
1465: DP p;
1466: MP m,mr;
1467:
1468: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
1.52 noro 1469: dp_ht(p,rp);
1.1 noro 1470: }
1471:
1472: void Pdp_hc(arg,rp)
1473: NODE arg;
1474: P *rp;
1475: {
1476: asir_assert(ARG0(arg),O_DP,"dp_hc");
1477: if ( !ARG0(arg) )
1478: *rp = 0;
1479: else
1480: *rp = BDY((DP)ARG0(arg))->c;
1481: }
1482:
1483: void Pdp_rest(arg,rp)
1484: NODE arg;
1485: DP *rp;
1486: {
1487: asir_assert(ARG0(arg),O_DP,"dp_rest");
1488: if ( !ARG0(arg) )
1489: *rp = 0;
1490: else
1491: dp_rest((DP)ARG0(arg),rp);
1492: }
1493:
1494: void Pdp_td(arg,rp)
1495: NODE arg;
1496: Q *rp;
1497: {
1498: DP p;
1499:
1500: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
1501: if ( !p )
1502: *rp = 0;
1503: else
1504: STOQ(BDY(p)->dl->td,*rp);
1505: }
1506:
1507: void Pdp_sugar(arg,rp)
1508: NODE arg;
1509: Q *rp;
1510: {
1511: DP p;
1512:
1513: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
1514: if ( !p )
1515: *rp = 0;
1516: else
1517: STOQ(p->sugar,*rp);
1.30 ohara 1518: }
1519:
1.49 noro 1520: void Pdp_initial_term(arg,rp)
1521: NODE arg;
1522: Obj *rp;
1523: {
1524: struct order_spec *ord;
1525: Num homo;
1526: int modular,is_list;
1527: LIST v,f,l,initiallist;
1528: NODE n;
1529:
1530: f = (LIST)ARG0(arg);
1531: if ( f && OID(f) == O_LIST )
1532: is_list = 1;
1533: else {
1534: n = mknode(1,f); MKLIST(l,n); f = l;
1535: is_list = 0;
1536: }
1.54 noro 1537: if ( current_option ) {
1.53 noro 1538: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.54 noro 1539: initd(ord);
1540: } else
1.49 noro 1541: ord = dp_current_spec;
1542: initiallist = dp_initial_term(f,ord);
1543: if ( !is_list )
1544: *rp = (Obj)BDY(BDY(initiallist));
1545: else
1546: *rp = (Obj)initiallist;
1547: }
1548:
1549: void Pdp_order(arg,rp)
1550: NODE arg;
1551: Obj *rp;
1552: {
1553: struct order_spec *ord;
1554: Num homo;
1555: int modular,is_list;
1556: LIST v,f,l,ordlist;
1557: NODE n;
1558:
1559: f = (LIST)ARG0(arg);
1560: if ( f && OID(f) == O_LIST )
1561: is_list = 1;
1562: else {
1563: n = mknode(1,f); MKLIST(l,n); f = l;
1564: is_list = 0;
1565: }
1.54 noro 1566: if ( current_option ) {
1.53 noro 1567: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.54 noro 1568: initd(ord);
1569: } else
1.49 noro 1570: ord = dp_current_spec;
1571: ordlist = dp_order(f,ord);
1572: if ( !is_list )
1573: *rp = (Obj)BDY(BDY(ordlist));
1574: else
1575: *rp = (Obj)ordlist;
1576: }
1577:
1.30 ohara 1578: void Pdp_set_sugar(arg,rp)
1579: NODE arg;
1580: Q *rp;
1581: {
1582: DP p;
1583: Q q;
1584: int i;
1585:
1586: p = (DP)ARG0(arg);
1587: q = (Q)ARG1(arg);
1588: if ( p && q) {
1589: asir_assert(p,O_DP,"dp_set_sugar");
1590: asir_assert(q,O_N, "dp_set_sugar");
1591: i = QTOS(q);
1592: if (p->sugar < i) {
1593: p->sugar = i;
1594: }
1595: }
1596: *rp = 0;
1.1 noro 1597: }
1598:
1599: void Pdp_cri1(arg,rp)
1600: NODE arg;
1601: Q *rp;
1602: {
1603: DP p1,p2;
1604: int *d1,*d2;
1605: int i,n;
1606:
1607: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1608: asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
1609: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
1610: for ( i = 0; i < n; i++ )
1611: if ( d1[i] > d2[i] )
1612: break;
1613: *rp = i == n ? ONE : 0;
1614: }
1615:
1616: void Pdp_cri2(arg,rp)
1617: NODE arg;
1618: Q *rp;
1619: {
1620: DP p1,p2;
1621: int *d1,*d2;
1622: int i,n;
1623:
1624: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1625: asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
1626: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
1627: for ( i = 0; i < n; i++ )
1628: if ( MIN(d1[i],d2[i]) >= 1 )
1629: break;
1630: *rp = i == n ? ONE : 0;
1631: }
1632:
1633: void Pdp_minp(arg,rp)
1634: NODE arg;
1635: LIST *rp;
1636: {
1637: NODE tn,tn1,d,dd,dd0,p,tp;
1638: LIST l,minp;
1639: DP lcm,tlcm;
1640: int s,ts;
1641:
1642: asir_assert(ARG0(arg),O_LIST,"dp_minp");
1643: d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
1644: p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
1645: if ( !ARG1(arg) ) {
1646: s = QTOS((Q)BDY(p)); p = NEXT(p);
1647: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1648: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1649: tlcm = (DP)BDY(tp); tp = NEXT(tp);
1650: ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
1651: NEXTNODE(dd0,dd);
1652: if ( ts < s ) {
1653: BDY(dd) = (pointer)minp;
1654: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1655: } else if ( ts == s ) {
1656: if ( compd(CO,lcm,tlcm) > 0 ) {
1657: BDY(dd) = (pointer)minp;
1658: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1659: } else
1660: BDY(dd) = BDY(d);
1661: } else
1662: BDY(dd) = BDY(d);
1663: }
1664: } else {
1665: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1666: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1667: tlcm = (DP)BDY(tp);
1668: NEXTNODE(dd0,dd);
1669: if ( compd(CO,lcm,tlcm) > 0 ) {
1670: BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
1671: } else
1672: BDY(dd) = BDY(d);
1673: }
1674: }
1675: if ( dd0 )
1676: NEXT(dd) = 0;
1677: MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
1678: }
1679:
1680: void Pdp_criB(arg,rp)
1681: NODE arg;
1682: LIST *rp;
1683: {
1684: NODE d,ij,dd,ddd;
1685: int i,j,s,n;
1686: DP *ps;
1687: DL ts,ti,tj,lij,tdl;
1688:
1689: asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
1690: asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
1691: asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
1692: if ( !d )
1693: *rp = (LIST)ARG0(arg);
1694: else {
1695: ts = BDY(ps[s])->dl;
1696: n = ps[s]->nv;
1697: NEWDL(tdl,n);
1698: for ( dd = 0; d; d = NEXT(d) ) {
1699: ij = BDY((LIST)BDY(d));
1700: i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1701: j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1702: lij = BDY((DP)BDY(ij))->dl;
1703: ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
1704: if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
1705: || !dl_equal(n,lij,tdl)
1706: || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
1707: && dl_equal(n,tdl,lij))
1708: || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
1709: && dl_equal(n,tdl,lij)) ) {
1710: MKNODE(ddd,BDY(d),dd);
1711: dd = ddd;
1712: }
1713: }
1714: MKLIST(*rp,dd);
1715: }
1716: }
1717:
1718: void Pdp_nelim(arg,rp)
1719: NODE arg;
1720: Q *rp;
1721: {
1722: if ( arg ) {
1723: asir_assert(ARG0(arg),O_N,"dp_nelim");
1724: dp_nelim = QTOS((Q)ARG0(arg));
1725: }
1726: STOQ(dp_nelim,*rp);
1727: }
1728:
1729: void Pdp_mag(arg,rp)
1730: NODE arg;
1731: Q *rp;
1732: {
1733: DP p;
1734: int s;
1735: MP m;
1736:
1737: p = (DP)ARG0(arg);
1738: asir_assert(p,O_DP,"dp_mag");
1739: if ( !p )
1740: *rp = 0;
1741: else {
1742: for ( s = 0, m = BDY(p); m; m = NEXT(m) )
1743: s += p_mag(m->c);
1744: STOQ(s,*rp);
1745: }
1746: }
1747:
1748: extern int kara_mag;
1749:
1750: void Pdp_set_kara(arg,rp)
1751: NODE arg;
1752: Q *rp;
1753: {
1754: if ( arg ) {
1755: asir_assert(ARG0(arg),O_N,"dp_set_kara");
1756: kara_mag = QTOS((Q)ARG0(arg));
1757: }
1758: STOQ(kara_mag,*rp);
1759: }
1760:
1761: void Pdp_homo(arg,rp)
1762: NODE arg;
1763: DP *rp;
1764: {
1765: asir_assert(ARG0(arg),O_DP,"dp_homo");
1766: dp_homo((DP)ARG0(arg),rp);
1767: }
1768:
1.8 noro 1769: void Pdp_dehomo(arg,rp)
1770: NODE arg;
1.1 noro 1771: DP *rp;
1772: {
1.8 noro 1773: asir_assert(ARG0(arg),O_DP,"dp_dehomo");
1774: dp_dehomo((DP)ARG0(arg),rp);
1775: }
1776:
1777: void Pdp_gr_flags(arg,rp)
1778: NODE arg;
1779: LIST *rp;
1780: {
1781: Obj name,value;
1782: NODE n;
1.1 noro 1783:
1.8 noro 1784: if ( arg ) {
1785: asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
1786: n = BDY((LIST)ARG0(arg));
1787: while ( n ) {
1788: name = (Obj)BDY(n); n = NEXT(n);
1789: if ( !n )
1790: break;
1791: else {
1792: value = (Obj)BDY(n); n = NEXT(n);
1793: }
1794: dp_set_flag(name,value);
1.1 noro 1795: }
1796: }
1.8 noro 1797: dp_make_flaglist(rp);
1798: }
1799:
1.29 noro 1800: extern int DP_Print, DP_PrintShort;
1.8 noro 1801:
1802: void Pdp_gr_print(arg,rp)
1803: NODE arg;
1804: Q *rp;
1805: {
1806: Q q;
1.29 noro 1807: int s;
1.8 noro 1808:
1809: if ( arg ) {
1810: asir_assert(ARG0(arg),O_N,"dp_gr_print");
1.29 noro 1811: q = (Q)ARG0(arg);
1812: s = QTOS(q);
1813: switch ( s ) {
1814: case 0:
1815: DP_Print = 0; DP_PrintShort = 0;
1816: break;
1817: case 1:
1818: DP_Print = 1;
1819: break;
1.41 noro 1820: case 2:
1.29 noro 1821: DP_Print = 0; DP_PrintShort = 1;
1.43 noro 1822: break;
1.41 noro 1823: default:
1824: DP_Print = s; DP_PrintShort = 0;
1.29 noro 1825: break;
1826: }
1827: } else {
1828: if ( DP_Print ) {
1829: STOQ(1,q);
1830: } else if ( DP_PrintShort ) {
1831: STOQ(2,q);
1832: } else
1833: q = 0;
1834: }
1.8 noro 1835: *rp = q;
1.1 noro 1836: }
1837:
1.46 noro 1838: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
1839: int *modular,struct order_spec **ord)
1840: {
1841: NODE t,p;
1842: Q m;
1843: char *key;
1844: Obj value,dmy;
1845: int ord_is_set = 0;
1846: int modular_is_set = 0;
1847: int homo_is_set = 0;
1.47 noro 1848: VL vl,vl0;
1.46 noro 1849: LIST vars;
1.47 noro 1850: char xiname[BUFSIZ];
1851: NODE x0,x;
1852: DP d;
1853: P xi;
1854: int nv,i;
1.46 noro 1855:
1856: /* extract vars */
1857: vars = 0;
1858: for ( t = opt; t; t = NEXT(t) ) {
1859: p = BDY((LIST)BDY(t));
1860: key = BDY((STRING)BDY(p));
1861: value = (Obj)BDY(NEXT(p));
1862: if ( !strcmp(key,"v") ) {
1863: /* variable list */
1864: vars = (LIST)value;
1865: break;
1866: }
1867: }
1.48 noro 1868: if ( vars ) {
1869: *v = vars; pltovl(vars,&vl);
1870: } else {
1871: for ( t = BDY(f); t; t = NEXT(t) )
1872: if ( BDY(t) && OID((Obj)BDY(t))==O_DP )
1873: break;
1874: if ( t ) {
1875: /* f is DP list */
1876: /* create dummy var list */
1877: d = (DP)BDY(t);
1878: nv = NV(d);
1879: for ( i = 0, vl0 = 0, x0 = 0; i < nv; i++ ) {
1880: NEXTVL(vl0,vl);
1881: NEXTNODE(x0,x);
1882: sprintf(xiname,"x%d",i);
1883: makevar(xiname,&xi);
1884: x->body = (pointer)xi;
1885: vl->v = VR((P)xi);
1886: }
1887: if ( vl0 ) {
1888: NEXT(vl) = 0;
1889: NEXT(x) = 0;
1890: }
1891: MKLIST(vars,x0);
1892: *v = vars;
1893: vl = vl0;
1894: } else {
1895: get_vars((Obj)f,&vl); vltopl(vl,v);
1.47 noro 1896: }
1.46 noro 1897: }
1898:
1899: for ( t = opt; t; t = NEXT(t) ) {
1900: p = BDY((LIST)BDY(t));
1901: key = BDY((STRING)BDY(p));
1902: value = (Obj)BDY(NEXT(p));
1903: if ( !strcmp(key,"v") ) {
1904: /* variable list; ignore */
1905: } else if ( !strcmp(key,"order") ) {
1906: /* order spec */
1.51 noro 1907: if ( !vl )
1908: error("parse_gr_option : variables must be specified");
1.46 noro 1909: create_order_spec(vl,value,ord);
1910: ord_is_set = 1;
1911: } else if ( !strcmp(key,"block") ) {
1912: create_order_spec(0,value,ord);
1.51 noro 1913: ord_is_set = 1;
1.46 noro 1914: } else if ( !strcmp(key,"matrix") ) {
1915: create_order_spec(0,value,ord);
1.51 noro 1916: ord_is_set = 1;
1.46 noro 1917: } else if ( !strcmp(key,"sugarweight") ) {
1918: /* weight */
1919: Pdp_set_weight(NEXT(p),&dmy);
1920: } else if ( !strcmp(key,"homo") ) {
1921: *homo = (Num)value;
1922: homo_is_set = 1;
1923: } else if ( !strcmp(key,"trace") ) {
1924: m = (Q)value;
1925: if ( !m )
1926: *modular = 0;
1927: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1
1928: && BD(NM(m))[0] >= 0x80000000) )
1929: error("parse_gr_option : too large modulus");
1930: else
1931: *modular = QTOS(m);
1932: modular_is_set = 1;
1933: } else
1934: error("parse_gr_option : not implemented");
1935: }
1936: if ( !ord_is_set ) create_order_spec(0,0,ord);
1937: if ( !modular_is_set ) *modular = 0;
1938: if ( !homo_is_set ) *homo = 0;
1939: }
1940:
1.8 noro 1941: void Pdp_gr_main(arg,rp)
1.1 noro 1942: NODE arg;
1.8 noro 1943: LIST *rp;
1.1 noro 1944: {
1.8 noro 1945: LIST f,v;
1.46 noro 1946: VL vl;
1.8 noro 1947: Num homo;
1948: Q m;
1.46 noro 1949: int modular,ac;
1950: struct order_spec *ord;
1.8 noro 1951:
1.11 noro 1952: do_weyl = 0;
1.8 noro 1953: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1.46 noro 1954: f = (LIST)ARG0(arg);
1.25 noro 1955: f = remove_zero_from_list(f);
1956: if ( !BDY(f) ) {
1957: *rp = f; return;
1958: }
1.53 noro 1959: if ( (ac = argc(arg)) == 5 ) {
1.46 noro 1960: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
1961: asir_assert(ARG2(arg),O_N,"dp_gr_main");
1962: asir_assert(ARG3(arg),O_N,"dp_gr_main");
1.49 noro 1963: v = (LIST)ARG1(arg);
1.46 noro 1964: homo = (Num)ARG2(arg);
1965: m = (Q)ARG3(arg);
1966: if ( !m )
1967: modular = 0;
1968: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1969: error("dp_gr_main : too large modulus");
1970: else
1971: modular = QTOS(m);
1972: create_order_spec(0,ARG4(arg),&ord);
1.53 noro 1973: } else if ( current_option )
1974: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.46 noro 1975: else if ( ac == 1 )
1976: parse_gr_option(f,0,&v,&homo,&modular,&ord);
1.8 noro 1977: else
1.46 noro 1978: error("dp_gr_main : invalid argument");
1979: dp_gr_main(f,v,homo,modular,0,ord,rp);
1.63 noro 1980: }
1981:
1982: void Pdp_interreduce(arg,rp)
1983: NODE arg;
1984: LIST *rp;
1985: {
1986: LIST f,v;
1987: VL vl;
1988: int ac;
1989: struct order_spec *ord;
1990:
1991: do_weyl = 0;
1992: asir_assert(ARG0(arg),O_LIST,"dp_interreduce");
1993: f = (LIST)ARG0(arg);
1994: f = remove_zero_from_list(f);
1995: if ( !BDY(f) ) {
1996: *rp = f; return;
1997: }
1998: if ( (ac = argc(arg)) == 3 ) {
1999: asir_assert(ARG1(arg),O_LIST,"dp_interreduce");
2000: v = (LIST)ARG1(arg);
2001: create_order_spec(0,ARG2(arg),&ord);
2002: }
2003: dp_interreduce(f,v,0,ord,rp);
1.16 noro 2004: }
2005:
2006: void Pdp_gr_f_main(arg,rp)
2007: NODE arg;
2008: LIST *rp;
2009: {
2010: LIST f,v;
2011: Num homo;
1.26 noro 2012: int m,field,t;
1.46 noro 2013: struct order_spec *ord;
1.26 noro 2014: NODE n;
1.16 noro 2015:
2016: do_weyl = 0;
2017: asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
2018: asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
2019: asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
2020: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2021: f = remove_zero_from_list(f);
2022: if ( !BDY(f) ) {
2023: *rp = f; return;
2024: }
1.16 noro 2025: homo = (Num)ARG2(arg);
1.27 noro 2026: #if 0
2027: asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
1.26 noro 2028: m = QTOS((Q)ARG3(arg));
2029: if ( m )
2030: error("dp_gr_f_main : trace lifting is not implemented yet");
1.46 noro 2031: create_order_spec(0,ARG4(arg),&ord);
1.27 noro 2032: #else
2033: m = 0;
1.46 noro 2034: create_order_spec(0,ARG3(arg),&ord);
1.27 noro 2035: #endif
1.26 noro 2036: field = 0;
2037: for ( n = BDY(f); n; n = NEXT(n) ) {
2038: t = get_field_type(BDY(n));
2039: if ( !t )
2040: continue;
2041: if ( t < 0 )
2042: error("dp_gr_f_main : incosistent coefficients");
2043: if ( !field )
2044: field = t;
2045: else if ( t != field )
2046: error("dp_gr_f_main : incosistent coefficients");
2047: }
1.46 noro 2048: dp_gr_main(f,v,homo,m?1:0,field,ord,rp);
1.1 noro 2049: }
2050:
1.8 noro 2051: void Pdp_f4_main(arg,rp)
2052: NODE arg;
2053: LIST *rp;
1.1 noro 2054: {
1.8 noro 2055: LIST f,v;
1.46 noro 2056: struct order_spec *ord;
1.1 noro 2057:
1.11 noro 2058: do_weyl = 0;
1.8 noro 2059: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
2060: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
2061: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2062: f = remove_zero_from_list(f);
2063: if ( !BDY(f) ) {
2064: *rp = f; return;
2065: }
1.46 noro 2066: create_order_spec(0,ARG2(arg),&ord);
2067: dp_f4_main(f,v,ord,rp);
1.22 noro 2068: }
2069:
2070: /* dp_gr_checklist(list of dp) */
2071:
2072: void Pdp_gr_checklist(arg,rp)
2073: NODE arg;
2074: LIST *rp;
2075: {
2076: VECT g;
2077: LIST dp;
2078: NODE r;
1.23 noro 2079: int n;
1.22 noro 2080:
2081: do_weyl = 0;
2082: asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
1.23 noro 2083: asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
2084: n = QTOS((Q)ARG1(arg));
2085: gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
1.22 noro 2086: r = mknode(2,g,dp);
2087: MKLIST(*rp,r);
1.1 noro 2088: }
2089:
1.8 noro 2090: void Pdp_f4_mod_main(arg,rp)
2091: NODE arg;
2092: LIST *rp;
1.1 noro 2093: {
1.8 noro 2094: LIST f,v;
2095: int m;
1.46 noro 2096: struct order_spec *ord;
1.8 noro 2097:
1.11 noro 2098: do_weyl = 0;
1.17 noro 2099: asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
2100: asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
2101: asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
1.8 noro 2102: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 2103: f = remove_zero_from_list(f);
2104: if ( !BDY(f) ) {
2105: *rp = f; return;
2106: }
1.20 noro 2107: if ( !m )
2108: error("dp_f4_mod_main : invalid argument");
1.46 noro 2109: create_order_spec(0,ARG3(arg),&ord);
2110: dp_f4_mod_main(f,v,m,ord,rp);
1.8 noro 2111: }
1.1 noro 2112:
1.8 noro 2113: void Pdp_gr_mod_main(arg,rp)
2114: NODE arg;
2115: LIST *rp;
2116: {
2117: LIST f,v;
2118: Num homo;
2119: int m;
1.46 noro 2120: struct order_spec *ord;
1.8 noro 2121:
1.11 noro 2122: do_weyl = 0;
1.8 noro 2123: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
2124: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
2125: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
2126: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1.11 noro 2127: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2128: f = remove_zero_from_list(f);
2129: if ( !BDY(f) ) {
2130: *rp = f; return;
2131: }
1.11 noro 2132: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 2133: if ( !m )
2134: error("dp_gr_mod_main : invalid argument");
1.46 noro 2135: create_order_spec(0,ARG4(arg),&ord);
2136: dp_gr_mod_main(f,v,homo,m,ord,rp);
1.33 noro 2137: }
2138:
1.40 noro 2139: void Pnd_f4(arg,rp)
2140: NODE arg;
2141: LIST *rp;
2142: {
2143: LIST f,v;
1.87 noro 2144: int m,homo,retdp;
2145: Obj val;
1.46 noro 2146: struct order_spec *ord;
1.40 noro 2147:
2148: do_weyl = 0;
1.76 noro 2149: asir_assert(ARG0(arg),O_LIST,"nd_f4");
2150: asir_assert(ARG1(arg),O_LIST,"nd_f4");
2151: asir_assert(ARG2(arg),O_N,"nd_f4");
1.40 noro 2152: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2153: f = remove_zero_from_list(f);
2154: if ( !BDY(f) ) {
2155: *rp = f; return;
2156: }
2157: m = QTOS((Q)ARG2(arg));
1.46 noro 2158: create_order_spec(0,ARG3(arg),&ord);
1.87 noro 2159: homo = retdp = 0;
2160: if ( get_opt("homo",&val) && val ) homo = 1;
2161: if ( get_opt("dp",&val) && val ) retdp = 1;
2162: nd_gr(f,v,m,homo,retdp,1,ord,rp);
1.40 noro 2163: }
2164:
1.33 noro 2165: void Pnd_gr(arg,rp)
2166: NODE arg;
2167: LIST *rp;
2168: {
2169: LIST f,v;
1.87 noro 2170: int m,homo,retdp;
2171: Obj val;
1.46 noro 2172: struct order_spec *ord;
1.33 noro 2173:
2174: do_weyl = 0;
2175: asir_assert(ARG0(arg),O_LIST,"nd_gr");
2176: asir_assert(ARG1(arg),O_LIST,"nd_gr");
1.36 noro 2177: asir_assert(ARG2(arg),O_N,"nd_gr");
1.33 noro 2178: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2179: f = remove_zero_from_list(f);
2180: if ( !BDY(f) ) {
2181: *rp = f; return;
2182: }
2183: m = QTOS((Q)ARG2(arg));
1.46 noro 2184: create_order_spec(0,ARG3(arg),&ord);
1.87 noro 2185: homo = retdp = 0;
2186: if ( get_opt("homo",&val) && val ) homo = 1;
2187: if ( get_opt("dp",&val) && val ) retdp = 1;
2188: nd_gr(f,v,m,homo,retdp,0,ord,rp);
1.58 noro 2189: }
2190:
2191: void Pnd_gr_postproc(arg,rp)
2192: NODE arg;
2193: LIST *rp;
2194: {
2195: LIST f,v;
2196: int m,do_check;
2197: struct order_spec *ord;
2198:
2199: do_weyl = 0;
2200: asir_assert(ARG0(arg),O_LIST,"nd_gr");
2201: asir_assert(ARG1(arg),O_LIST,"nd_gr");
2202: asir_assert(ARG2(arg),O_N,"nd_gr");
2203: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2204: f = remove_zero_from_list(f);
2205: if ( !BDY(f) ) {
2206: *rp = f; return;
2207: }
2208: m = QTOS((Q)ARG2(arg));
2209: create_order_spec(0,ARG3(arg),&ord);
2210: do_check = ARG4(arg) ? 1 : 0;
2211: nd_gr_postproc(f,v,m,ord,do_check,rp);
1.36 noro 2212: }
2213:
1.89 ! noro 2214: #if 0
1.86 noro 2215: void Pnd_gr_recompute_trace(arg,rp)
2216: NODE arg;
2217: LIST *rp;
2218: {
2219: LIST f,v,tlist;
2220: int m;
2221: struct order_spec *ord;
2222:
2223: do_weyl = 0;
2224: asir_assert(ARG0(arg),O_LIST,"nd_gr_recompute_trace");
2225: asir_assert(ARG1(arg),O_LIST,"nd_gr_recompute_trace");
2226: asir_assert(ARG2(arg),O_N,"nd_gr_recompute_trace");
2227: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2228: m = QTOS((Q)ARG2(arg));
2229: create_order_spec(0,ARG3(arg),&ord);
2230: tlist = (LIST)ARG4(arg);
2231: nd_gr_recompute_trace(f,v,m,ord,tlist,rp);
2232: }
1.89 ! noro 2233: #endif
! 2234:
! 2235: void Pnd_btog(arg,rp)
! 2236: NODE arg;
! 2237: MAT *rp;
! 2238: {
! 2239: LIST f,v,tlist;
! 2240: int m;
! 2241: struct order_spec *ord;
! 2242:
! 2243: do_weyl = 0;
! 2244: asir_assert(ARG0(arg),O_LIST,"nd_btog");
! 2245: asir_assert(ARG1(arg),O_LIST,"nd_btog");
! 2246: asir_assert(ARG2(arg),O_N,"nd_btog");
! 2247: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
! 2248: m = QTOS((Q)ARG2(arg));
! 2249: create_order_spec(0,ARG3(arg),&ord);
! 2250: tlist = (LIST)ARG4(arg);
! 2251: *rp = nd_btog(f,v,m,ord,tlist);
! 2252: }
1.86 noro 2253:
1.75 noro 2254: void Pnd_weyl_gr_postproc(arg,rp)
2255: NODE arg;
2256: LIST *rp;
2257: {
2258: LIST f,v;
2259: int m,do_check;
2260: struct order_spec *ord;
2261:
2262: do_weyl = 1;
2263: asir_assert(ARG0(arg),O_LIST,"nd_gr");
2264: asir_assert(ARG1(arg),O_LIST,"nd_gr");
2265: asir_assert(ARG2(arg),O_N,"nd_gr");
2266: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2267: f = remove_zero_from_list(f);
2268: if ( !BDY(f) ) {
1.80 noro 2269: *rp = f; do_weyl = 0; return;
1.75 noro 2270: }
2271: m = QTOS((Q)ARG2(arg));
2272: create_order_spec(0,ARG3(arg),&ord);
2273: do_check = ARG4(arg) ? 1 : 0;
2274: nd_gr_postproc(f,v,m,ord,do_check,rp);
1.80 noro 2275: do_weyl = 0;
1.75 noro 2276: }
2277:
1.36 noro 2278: void Pnd_gr_trace(arg,rp)
2279: NODE arg;
2280: LIST *rp;
2281: {
2282: LIST f,v;
2283: int m,homo;
1.46 noro 2284: struct order_spec *ord;
1.36 noro 2285:
2286: do_weyl = 0;
2287: asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
2288: asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
2289: asir_assert(ARG2(arg),O_N,"nd_gr_trace");
2290: asir_assert(ARG3(arg),O_N,"nd_gr_trace");
2291: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2292: f = remove_zero_from_list(f);
2293: if ( !BDY(f) ) {
2294: *rp = f; return;
2295: }
2296: homo = QTOS((Q)ARG2(arg));
2297: m = QTOS((Q)ARG3(arg));
1.46 noro 2298: create_order_spec(0,ARG4(arg),&ord);
1.62 noro 2299: nd_gr_trace(f,v,m,homo,0,ord,rp);
2300: }
2301:
2302: void Pnd_f4_trace(arg,rp)
2303: NODE arg;
2304: LIST *rp;
2305: {
2306: LIST f,v;
2307: int m,homo;
2308: struct order_spec *ord;
2309:
2310: do_weyl = 0;
2311: asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
2312: asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
2313: asir_assert(ARG2(arg),O_N,"nd_gr_trace");
2314: asir_assert(ARG3(arg),O_N,"nd_gr_trace");
2315: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2316: f = remove_zero_from_list(f);
2317: if ( !BDY(f) ) {
2318: *rp = f; return;
2319: }
2320: homo = QTOS((Q)ARG2(arg));
2321: m = QTOS((Q)ARG3(arg));
2322: create_order_spec(0,ARG4(arg),&ord);
2323: nd_gr_trace(f,v,m,homo,1,ord,rp);
1.11 noro 2324: }
2325:
1.38 noro 2326: void Pnd_weyl_gr(arg,rp)
2327: NODE arg;
2328: LIST *rp;
2329: {
2330: LIST f,v;
1.87 noro 2331: int m,homo,retdp;
2332: Obj val;
1.46 noro 2333: struct order_spec *ord;
1.38 noro 2334:
2335: do_weyl = 1;
2336: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr");
2337: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr");
2338: asir_assert(ARG2(arg),O_N,"nd_weyl_gr");
2339: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2340: f = remove_zero_from_list(f);
2341: if ( !BDY(f) ) {
1.80 noro 2342: *rp = f; do_weyl = 0; return;
1.38 noro 2343: }
2344: m = QTOS((Q)ARG2(arg));
1.46 noro 2345: create_order_spec(0,ARG3(arg),&ord);
1.87 noro 2346: homo = retdp = 0;
2347: if ( get_opt("homo",&val) && val ) homo = 1;
2348: if ( get_opt("dp",&val) && val ) retdp = 1;
2349: nd_gr(f,v,m,homo,retdp,0,ord,rp);
1.80 noro 2350: do_weyl = 0;
1.38 noro 2351: }
2352:
2353: void Pnd_weyl_gr_trace(arg,rp)
2354: NODE arg;
2355: LIST *rp;
2356: {
2357: LIST f,v;
2358: int m,homo;
1.46 noro 2359: struct order_spec *ord;
1.38 noro 2360:
2361: do_weyl = 1;
2362: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr_trace");
2363: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr_trace");
2364: asir_assert(ARG2(arg),O_N,"nd_weyl_gr_trace");
2365: asir_assert(ARG3(arg),O_N,"nd_weyl_gr_trace");
2366: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2367: f = remove_zero_from_list(f);
2368: if ( !BDY(f) ) {
1.80 noro 2369: *rp = f; do_weyl = 0; return;
1.38 noro 2370: }
2371: homo = QTOS((Q)ARG2(arg));
2372: m = QTOS((Q)ARG3(arg));
1.46 noro 2373: create_order_spec(0,ARG4(arg),&ord);
1.65 noro 2374: nd_gr_trace(f,v,m,homo,0,ord,rp);
1.80 noro 2375: do_weyl = 0;
1.38 noro 2376: }
1.39 noro 2377:
1.83 noro 2378: void Pnd_nf(NODE arg,Obj *rp)
1.39 noro 2379: {
1.83 noro 2380: Obj f;
1.39 noro 2381: LIST g,v;
1.46 noro 2382: struct order_spec *ord;
1.39 noro 2383:
2384: do_weyl = 0;
2385: asir_assert(ARG1(arg),O_LIST,"nd_nf");
2386: asir_assert(ARG2(arg),O_LIST,"nd_nf");
2387: asir_assert(ARG4(arg),O_N,"nd_nf");
1.83 noro 2388: f = (Obj)ARG0(arg);
2389: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
2390: if ( !BDY(g) ) {
2391: *rp = f; return;
2392: }
2393: v = (LIST)ARG2(arg);
2394: create_order_spec(0,ARG3(arg),&ord);
2395: nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),ord,rp);
2396: }
2397:
2398: void Pnd_weyl_nf(NODE arg,Obj *rp)
2399: {
2400: Obj f;
2401: LIST g,v;
2402: struct order_spec *ord;
2403:
2404: do_weyl = 1;
2405: asir_assert(ARG1(arg),O_LIST,"nd_weyl_nf");
2406: asir_assert(ARG2(arg),O_LIST,"nd_weyl_nf");
2407: asir_assert(ARG4(arg),O_N,"nd_weyl_nf");
2408: f = (Obj)ARG0(arg);
1.39 noro 2409: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
2410: if ( !BDY(g) ) {
2411: *rp = f; return;
2412: }
2413: v = (LIST)ARG2(arg);
1.46 noro 2414: create_order_spec(0,ARG3(arg),&ord);
2415: nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),ord,rp);
1.39 noro 2416: }
2417:
1.11 noro 2418: /* for Weyl algebra */
2419:
2420: void Pdp_weyl_gr_main(arg,rp)
2421: NODE arg;
2422: LIST *rp;
2423: {
2424: LIST f,v;
2425: Num homo;
2426: Q m;
1.49 noro 2427: int modular,ac;
1.46 noro 2428: struct order_spec *ord;
1.11 noro 2429:
1.49 noro 2430:
1.11 noro 2431: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1.49 noro 2432: f = (LIST)ARG0(arg);
1.25 noro 2433: f = remove_zero_from_list(f);
2434: if ( !BDY(f) ) {
2435: *rp = f; return;
2436: }
1.53 noro 2437: if ( (ac = argc(arg)) == 5 ) {
1.49 noro 2438: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
2439: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
2440: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
2441: v = (LIST)ARG1(arg);
2442: homo = (Num)ARG2(arg);
2443: m = (Q)ARG3(arg);
2444: if ( !m )
2445: modular = 0;
2446: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
2447: error("dp_weyl_gr_main : too large modulus");
2448: else
2449: modular = QTOS(m);
2450: create_order_spec(0,ARG4(arg),&ord);
1.53 noro 2451: } else if ( current_option )
2452: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.49 noro 2453: else if ( ac == 1 )
2454: parse_gr_option(f,0,&v,&homo,&modular,&ord);
1.11 noro 2455: else
1.49 noro 2456: error("dp_weyl_gr_main : invalid argument");
1.12 noro 2457: do_weyl = 1;
1.46 noro 2458: dp_gr_main(f,v,homo,modular,0,ord,rp);
1.16 noro 2459: do_weyl = 0;
2460: }
2461:
2462: void Pdp_weyl_gr_f_main(arg,rp)
2463: NODE arg;
2464: LIST *rp;
2465: {
2466: LIST f,v;
2467: Num homo;
1.46 noro 2468: struct order_spec *ord;
1.16 noro 2469:
2470: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
2471: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
2472: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
2473: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
2474: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2475: f = remove_zero_from_list(f);
2476: if ( !BDY(f) ) {
2477: *rp = f; return;
2478: }
1.16 noro 2479: homo = (Num)ARG2(arg);
1.46 noro 2480: create_order_spec(0,ARG3(arg),&ord);
1.16 noro 2481: do_weyl = 1;
1.46 noro 2482: dp_gr_main(f,v,homo,0,1,ord,rp);
1.12 noro 2483: do_weyl = 0;
1.11 noro 2484: }
2485:
2486: void Pdp_weyl_f4_main(arg,rp)
2487: NODE arg;
2488: LIST *rp;
2489: {
2490: LIST f,v;
1.46 noro 2491: struct order_spec *ord;
1.11 noro 2492:
2493: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
2494: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
2495: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2496: f = remove_zero_from_list(f);
2497: if ( !BDY(f) ) {
2498: *rp = f; return;
2499: }
1.46 noro 2500: create_order_spec(0,ARG2(arg),&ord);
1.12 noro 2501: do_weyl = 1;
1.46 noro 2502: dp_f4_main(f,v,ord,rp);
1.12 noro 2503: do_weyl = 0;
1.11 noro 2504: }
2505:
2506: void Pdp_weyl_f4_mod_main(arg,rp)
2507: NODE arg;
2508: LIST *rp;
2509: {
2510: LIST f,v;
2511: int m;
1.46 noro 2512: struct order_spec *ord;
1.11 noro 2513:
2514: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
2515: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
2516: asir_assert(ARG2(arg),O_N,"dp_f4_main");
2517: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 2518: f = remove_zero_from_list(f);
2519: if ( !BDY(f) ) {
2520: *rp = f; return;
2521: }
1.20 noro 2522: if ( !m )
2523: error("dp_weyl_f4_mod_main : invalid argument");
1.46 noro 2524: create_order_spec(0,ARG3(arg),&ord);
1.12 noro 2525: do_weyl = 1;
1.46 noro 2526: dp_f4_mod_main(f,v,m,ord,rp);
1.12 noro 2527: do_weyl = 0;
1.11 noro 2528: }
2529:
2530: void Pdp_weyl_gr_mod_main(arg,rp)
2531: NODE arg;
2532: LIST *rp;
2533: {
2534: LIST f,v;
2535: Num homo;
2536: int m;
1.46 noro 2537: struct order_spec *ord;
1.11 noro 2538:
2539: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
2540: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
2541: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
2542: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
1.8 noro 2543: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2544: f = remove_zero_from_list(f);
2545: if ( !BDY(f) ) {
2546: *rp = f; return;
2547: }
1.8 noro 2548: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 2549: if ( !m )
2550: error("dp_weyl_gr_mod_main : invalid argument");
1.46 noro 2551: create_order_spec(0,ARG4(arg),&ord);
1.12 noro 2552: do_weyl = 1;
1.46 noro 2553: dp_gr_mod_main(f,v,homo,m,ord,rp);
1.12 noro 2554: do_weyl = 0;
1.1 noro 2555: }
1.8 noro 2556:
1.57 noro 2557: VECT current_dl_weight_vector_obj;
1.24 noro 2558: int *current_dl_weight_vector;
2559:
2560: void Pdp_set_weight(arg,rp)
2561: NODE arg;
2562: VECT *rp;
2563: {
2564: VECT v;
2565: int i,n;
1.45 noro 2566: NODE node;
1.24 noro 2567:
2568: if ( !arg )
2569: *rp = current_dl_weight_vector_obj;
2570: else if ( !ARG0(arg) ) {
2571: current_dl_weight_vector_obj = 0;
2572: current_dl_weight_vector = 0;
2573: *rp = 0;
2574: } else {
1.45 noro 2575: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
2576: error("dp_set_weight : invalid argument");
2577: if ( OID(ARG0(arg)) == O_VECT )
2578: v = (VECT)ARG0(arg);
2579: else {
2580: node = (NODE)BDY((LIST)ARG0(arg));
2581: n = length(node);
2582: MKVECT(v,n);
2583: for ( i = 0; i < n; i++, node = NEXT(node) )
2584: BDY(v)[i] = BDY(node);
2585: }
1.24 noro 2586: current_dl_weight_vector_obj = v;
2587: n = v->len;
2588: current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
2589: for ( i = 0; i < n; i++ )
2590: current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
2591: *rp = v;
2592: }
2593: }
2594:
1.77 noro 2595: VECT current_module_weight_vector_obj;
2596: int *current_module_weight_vector;
2597:
2598: void Pdp_set_module_weight(arg,rp)
2599: NODE arg;
2600: VECT *rp;
2601: {
2602: VECT v;
2603: int i,n;
2604: NODE node;
2605:
2606: if ( !arg )
2607: *rp = current_module_weight_vector_obj;
2608: else if ( !ARG0(arg) ) {
2609: current_module_weight_vector_obj = 0;
2610: current_module_weight_vector = 0;
2611: *rp = 0;
2612: } else {
2613: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
2614: error("dp_module_set_weight : invalid argument");
2615: if ( OID(ARG0(arg)) == O_VECT )
2616: v = (VECT)ARG0(arg);
2617: else {
2618: node = (NODE)BDY((LIST)ARG0(arg));
2619: n = length(node);
2620: MKVECT(v,n);
2621: for ( i = 0; i < n; i++, node = NEXT(node) )
2622: BDY(v)[i] = BDY(node);
2623: }
2624: current_module_weight_vector_obj = v;
2625: n = v->len;
2626: current_module_weight_vector = (int *)CALLOC(n,sizeof(int));
2627: for ( i = 0; i < n; i++ )
2628: current_module_weight_vector[i] = QTOS((Q)v->body[i]);
2629: *rp = v;
2630: }
2631: }
2632:
1.71 noro 2633: VECT current_top_weight_vector_obj;
2634: N *current_top_weight_vector;
2635:
2636: void Pdp_set_top_weight(arg,rp)
2637: NODE arg;
2638: VECT *rp;
2639: {
2640: VECT v;
2641: int i,n;
2642: NODE node;
2643:
2644: if ( !arg )
2645: *rp = current_top_weight_vector_obj;
2646: else if ( !ARG0(arg) ) {
2647: current_top_weight_vector = 0;
2648: current_top_weight_vector_obj = 0;
2649: *rp = 0;
2650: } else {
2651: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
2652: error("dp_set_top_weight : invalid argument");
2653: if ( OID(ARG0(arg)) == O_VECT )
2654: v = (VECT)ARG0(arg);
2655: else {
2656: node = (NODE)BDY((LIST)ARG0(arg));
2657: n = length(node);
2658: MKVECT(v,n);
2659: for ( i = 0; i < n; i++, node = NEXT(node) )
2660: BDY(v)[i] = BDY(node);
2661: }
2662: for ( i = 0; i < v->len; i++ )
1.74 noro 2663: if ( !INT(BDY(v)[i]) || (BDY(v)[i] && SGN((Q)BDY(v)[i]) < 0) )
1.71 noro 2664: error("dp_set_top_weight : each element must be a non-negative integer");
2665: current_top_weight_vector_obj = v;
2666: current_top_weight_vector = (N *)MALLOC(v->len*sizeof(N));
2667: for ( i = 0; i < v->len; i++ ) {
1.74 noro 2668: current_top_weight_vector[i] = !BDY(v)[i]?0:NM((Q)BDY(v)[i]);
1.71 noro 2669: }
2670: *rp = current_top_weight_vector_obj;
2671: }
2672: }
2673:
1.72 noro 2674: LIST get_denomlist();
2675:
2676: void Pdp_get_denomlist(LIST *rp)
2677: {
2678: *rp = get_denomlist();
2679: }
2680:
1.24 noro 2681: static VECT current_weyl_weight_vector_obj;
2682: int *current_weyl_weight_vector;
1.15 noro 2683:
2684: void Pdp_weyl_set_weight(arg,rp)
2685: NODE arg;
2686: VECT *rp;
2687: {
2688: VECT v;
1.85 noro 2689: NODE node;
1.15 noro 2690: int i,n;
2691:
2692: if ( !arg )
1.24 noro 2693: *rp = current_weyl_weight_vector_obj;
1.78 noro 2694: else if ( !ARG0(arg) ) {
2695: current_weyl_weight_vector_obj = 0;
2696: current_weyl_weight_vector = 0;
2697: *rp = 0;
2698: } else {
1.85 noro 2699: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
2700: error("dp_weyl_set_weight : invalid argument");
2701: if ( OID(ARG0(arg)) == O_VECT )
2702: v = (VECT)ARG0(arg);
2703: else {
2704: node = (NODE)BDY((LIST)ARG0(arg));
2705: n = length(node);
2706: MKVECT(v,n);
2707: for ( i = 0; i < n; i++, node = NEXT(node) )
2708: BDY(v)[i] = BDY(node);
2709: }
1.24 noro 2710: current_weyl_weight_vector_obj = v;
1.15 noro 2711: n = v->len;
1.24 noro 2712: current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
1.15 noro 2713: for ( i = 0; i < n; i++ )
1.24 noro 2714: current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
1.15 noro 2715: *rp = v;
2716: }
1.25 noro 2717: }
2718:
1.82 noro 2719: NODE mono_raddec(NODE ideal);
2720:
2721: void Pdp_mono_raddec(NODE arg,LIST *rp)
2722: {
2723: NODE ideal,rd,t,t1,r,r1,u;
2724: VL vl0,vl;
2725: int nv,i,bpi;
2726: int *s;
2727: DP dp;
2728: P *v;
2729: LIST l;
2730:
2731: ideal = BDY((LIST)ARG0(arg));
2732: if ( !ideal ) *rp = (LIST)ARG0(arg);
2733: else {
2734: t = BDY((LIST)ARG1(arg));
2735: nv = length(t);
2736: v = (P)MALLOC(nv*sizeof(P));
2737: for ( vl0 = 0, i = 0; t; t = NEXT(t), i++ ) {
2738: NEXTVL(vl0,vl); VR(vl) = VR((P)BDY(t));
2739: MKV(VR(vl),v[i]);
2740: }
2741: if ( vl0 ) NEXT(vl) = 0;
2742: for ( t = 0, r = ideal; r; r = NEXT(r) ) {
2743: ptod(CO,vl0,BDY(r),&dp); MKNODE(t1,dp,t); t = t1;
2744: }
2745: rd = mono_raddec(t);
2746: r = 0;
2747: bpi = (sizeof(int)/sizeof(char))*8;
2748: for ( u = rd; u; u = NEXT(u) ) {
2749: s = (int *)BDY(u);
2750: for ( i = nv-1, t = 0; i >= 0; i-- )
2751: if ( s[i/bpi]&(1<<(i%bpi)) ) {
2752: MKNODE(t1,v[i],t); t = t1;
2753: }
2754: MKLIST(l,t); MKNODE(r1,l,r); r = r1;
2755: }
2756: MKLIST(*rp,r);
2757: }
2758: }
2759:
1.84 noro 2760: void Pdp_mono_reduce(NODE arg,LIST *rp)
2761: {
2762: NODE t,t0,t1,r0,r;
2763: int i,n;
2764: DP m;
2765: DP *a;
2766:
2767: t0 = BDY((LIST)ARG0(arg));
2768: t1 = BDY((LIST)ARG1(arg));
2769: n = length(t0);
2770: a = (DP *)MALLOC(n*sizeof(DP));
2771: for ( i = 0; i < n; i++, t0 = NEXT(t0) ) a[i] = (DP)BDY(t0);
2772: for ( t = t1; t; t = NEXT(t) ) {
2773: m = (DP)BDY(t);
2774: for ( i = 0; i < n; i++ )
2775: if ( a[i] && dp_redble(a[i],m) ) a[i] = 0;
2776: }
2777: for ( i = n-1, r0 = 0; i >= 0; i-- )
2778: if ( a[i] ) { NEXTNODE(r0,r); BDY(r) = a[i]; }
2779: if ( r0 ) NEXT(r) = 0;
2780: MKLIST(*rp,r0);
2781: }
2782:
1.25 noro 2783: LIST remove_zero_from_list(LIST l)
2784: {
2785: NODE n,r0,r;
2786: LIST rl;
2787:
2788: asir_assert(l,O_LIST,"remove_zero_from_list");
2789: n = BDY(l);
2790: for ( r0 = 0; n; n = NEXT(n) )
2791: if ( BDY(n) ) {
2792: NEXTNODE(r0,r);
2793: BDY(r) = BDY(n);
2794: }
2795: if ( r0 )
2796: NEXT(r) = 0;
2797: MKLIST(rl,r0);
2798: return rl;
1.26 noro 2799: }
2800:
2801: int get_field_type(P p)
2802: {
2803: int type,t;
2804: DCP dc;
2805:
2806: if ( !p )
2807: return 0;
2808: else if ( NUM(p) )
2809: return NID((Num)p);
2810: else {
2811: type = 0;
2812: for ( dc = DC(p); dc; dc = NEXT(dc) ) {
2813: t = get_field_type(COEF(dc));
2814: if ( !t )
2815: continue;
2816: if ( t < 0 )
2817: return t;
2818: if ( !type )
2819: type = t;
2820: else if ( t != type )
2821: return -1;
2822: }
2823: return type;
1.52 noro 2824: }
2825: }
2826:
2827: void Pdpv_ord(NODE arg,Obj *rp)
2828: {
2829: int ac,id;
2830: LIST shift;
2831:
2832: ac = argc(arg);
2833: if ( ac ) {
2834: id = QTOS((Q)ARG0(arg));
2835: if ( ac > 1 && ARG1(arg) && OID((Obj)ARG1(arg))==O_LIST )
2836: shift = (LIST)ARG1(arg);
2837: else
2838: shift = 0;
2839: create_modorder_spec(id,shift,&dp_current_modspec);
2840: }
2841: *rp = dp_current_modspec->obj;
2842: }
2843:
2844: void Pdpv_ht(NODE arg,LIST *rp)
2845: {
2846: NODE n;
2847: DP ht;
2848: int pos;
2849: DPV p;
2850: Q q;
2851:
2852: asir_assert(ARG0(arg),O_DPV,"dpv_ht");
2853: p = (DPV)ARG0(arg);
2854: pos = dpv_hp(p);
2855: if ( pos < 0 )
2856: ht = 0;
2857: else
2858: dp_ht(BDY(p)[pos],&ht);
2859: STOQ(pos,q);
2860: n = mknode(2,q,ht);
2861: MKLIST(*rp,n);
2862: }
2863:
2864: void Pdpv_hm(NODE arg,LIST *rp)
2865: {
2866: NODE n;
2867: DP ht;
2868: int pos;
2869: DPV p;
2870: Q q;
2871:
2872: asir_assert(ARG0(arg),O_DPV,"dpv_hm");
2873: p = (DPV)ARG0(arg);
2874: pos = dpv_hp(p);
2875: if ( pos < 0 )
2876: ht = 0;
2877: else
2878: dp_hm(BDY(p)[pos],&ht);
2879: STOQ(pos,q);
2880: n = mknode(2,q,ht);
2881: MKLIST(*rp,n);
2882: }
2883:
2884: void Pdpv_hc(NODE arg,LIST *rp)
2885: {
2886: NODE n;
2887: P hc;
2888: int pos;
2889: DPV p;
2890: Q q;
2891:
2892: asir_assert(ARG0(arg),O_DPV,"dpv_hc");
2893: p = (DPV)ARG0(arg);
2894: pos = dpv_hp(p);
2895: if ( pos < 0 )
2896: hc = 0;
2897: else
2898: hc = BDY(BDY(p)[pos])->c;
2899: STOQ(pos,q);
2900: n = mknode(2,q,hc);
2901: MKLIST(*rp,n);
2902: }
2903:
2904: int dpv_hp(DPV p)
2905: {
2906: int len,i,maxp,maxw,w,slen;
2907: int *shift;
2908: DP *e;
2909:
2910: len = p->len;
2911: e = p->body;
2912: slen = dp_current_modspec->len;
2913: shift = dp_current_modspec->degree_shift;
2914: switch ( dp_current_modspec->id ) {
2915: case ORD_REVGRADLEX:
2916: for ( maxp = -1, i = 0; i < len; i++ )
2917: if ( !e[i] ) continue;
2918: else if ( maxp < 0 ) {
2919: maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
2920: } else {
2921: w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
2922: if ( w >= maxw ) {
2923: maxw = w; maxp = i;
2924: }
2925: }
2926: return maxp;
2927: case ORD_GRADLEX:
2928: for ( maxp = -1, i = 0; i < len; i++ )
2929: if ( !e[i] ) continue;
2930: else if ( maxp < 0 ) {
2931: maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
2932: } else {
2933: w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
2934: if ( w > maxw ) {
2935: maxw = w; maxp = i;
2936: }
2937: }
2938: return maxp;
2939: break;
2940: case ORD_LEX:
2941: for ( i = 0; i < len; i++ )
2942: if ( e[i] ) return i;
2943: return -1;
2944: break;
1.26 noro 2945: }
1.15 noro 2946: }
1.81 noro 2947:
2948: int get_opt(char *key0,Obj *r) {
2949: NODE tt,p;
2950: char *key;
2951:
2952: if ( current_option ) {
2953: for ( tt = current_option; tt; tt = NEXT(tt) ) {
2954: p = BDY((LIST)BDY(tt));
2955: key = BDY((STRING)BDY(p));
2956: /* value = (Obj)BDY(NEXT(p)); */
2957: if ( !strcmp(key,key0) ) {
2958: *r = (Obj)BDY(NEXT(p));
2959: return 1;
2960: }
2961: }
2962: }
2963: return 0;
2964: }
2965:
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