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