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