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