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