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