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