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