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