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