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