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