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