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