Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.53
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.53 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.52 2004/05/14 06:02:54 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);
! 474: dp_current_spec = ord;
! 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);
! 513: dp_current_spec = ord;
! 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.53 ! noro 1179: if ( current_option )
! 1180: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.49 noro 1181: else
1182: ord = dp_current_spec;
1183: initiallist = dp_initial_term(f,ord);
1184: if ( !is_list )
1185: *rp = (Obj)BDY(BDY(initiallist));
1186: else
1187: *rp = (Obj)initiallist;
1188: }
1189:
1190: void Pdp_order(arg,rp)
1191: NODE arg;
1192: Obj *rp;
1193: {
1194: struct order_spec *ord;
1195: Num homo;
1196: int modular,is_list;
1197: LIST v,f,l,ordlist;
1198: NODE n;
1199:
1200: f = (LIST)ARG0(arg);
1201: if ( f && OID(f) == O_LIST )
1202: is_list = 1;
1203: else {
1204: n = mknode(1,f); MKLIST(l,n); f = l;
1205: is_list = 0;
1206: }
1.53 ! noro 1207: if ( current_option )
! 1208: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.49 noro 1209: else
1210: ord = dp_current_spec;
1211: ordlist = dp_order(f,ord);
1212: if ( !is_list )
1213: *rp = (Obj)BDY(BDY(ordlist));
1214: else
1215: *rp = (Obj)ordlist;
1216: }
1217:
1.30 ohara 1218: void Pdp_set_sugar(arg,rp)
1219: NODE arg;
1220: Q *rp;
1221: {
1222: DP p;
1223: Q q;
1224: int i;
1225:
1226: p = (DP)ARG0(arg);
1227: q = (Q)ARG1(arg);
1228: if ( p && q) {
1229: asir_assert(p,O_DP,"dp_set_sugar");
1230: asir_assert(q,O_N, "dp_set_sugar");
1231: i = QTOS(q);
1232: if (p->sugar < i) {
1233: p->sugar = i;
1234: }
1235: }
1236: *rp = 0;
1.1 noro 1237: }
1238:
1239: void Pdp_cri1(arg,rp)
1240: NODE arg;
1241: Q *rp;
1242: {
1243: DP p1,p2;
1244: int *d1,*d2;
1245: int i,n;
1246:
1247: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1248: asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
1249: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
1250: for ( i = 0; i < n; i++ )
1251: if ( d1[i] > d2[i] )
1252: break;
1253: *rp = i == n ? ONE : 0;
1254: }
1255:
1256: void Pdp_cri2(arg,rp)
1257: NODE arg;
1258: Q *rp;
1259: {
1260: DP p1,p2;
1261: int *d1,*d2;
1262: int i,n;
1263:
1264: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1265: asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
1266: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
1267: for ( i = 0; i < n; i++ )
1268: if ( MIN(d1[i],d2[i]) >= 1 )
1269: break;
1270: *rp = i == n ? ONE : 0;
1271: }
1272:
1273: void Pdp_minp(arg,rp)
1274: NODE arg;
1275: LIST *rp;
1276: {
1277: NODE tn,tn1,d,dd,dd0,p,tp;
1278: LIST l,minp;
1279: DP lcm,tlcm;
1280: int s,ts;
1281:
1282: asir_assert(ARG0(arg),O_LIST,"dp_minp");
1283: d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
1284: p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
1285: if ( !ARG1(arg) ) {
1286: s = QTOS((Q)BDY(p)); p = NEXT(p);
1287: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1288: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1289: tlcm = (DP)BDY(tp); tp = NEXT(tp);
1290: ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
1291: NEXTNODE(dd0,dd);
1292: if ( ts < s ) {
1293: BDY(dd) = (pointer)minp;
1294: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1295: } else if ( ts == s ) {
1296: if ( compd(CO,lcm,tlcm) > 0 ) {
1297: BDY(dd) = (pointer)minp;
1298: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1299: } else
1300: BDY(dd) = BDY(d);
1301: } else
1302: BDY(dd) = BDY(d);
1303: }
1304: } else {
1305: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1306: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1307: tlcm = (DP)BDY(tp);
1308: NEXTNODE(dd0,dd);
1309: if ( compd(CO,lcm,tlcm) > 0 ) {
1310: BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
1311: } else
1312: BDY(dd) = BDY(d);
1313: }
1314: }
1315: if ( dd0 )
1316: NEXT(dd) = 0;
1317: MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
1318: }
1319:
1320: void Pdp_criB(arg,rp)
1321: NODE arg;
1322: LIST *rp;
1323: {
1324: NODE d,ij,dd,ddd;
1325: int i,j,s,n;
1326: DP *ps;
1327: DL ts,ti,tj,lij,tdl;
1328:
1329: asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
1330: asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
1331: asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
1332: if ( !d )
1333: *rp = (LIST)ARG0(arg);
1334: else {
1335: ts = BDY(ps[s])->dl;
1336: n = ps[s]->nv;
1337: NEWDL(tdl,n);
1338: for ( dd = 0; d; d = NEXT(d) ) {
1339: ij = BDY((LIST)BDY(d));
1340: i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1341: j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1342: lij = BDY((DP)BDY(ij))->dl;
1343: ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
1344: if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
1345: || !dl_equal(n,lij,tdl)
1346: || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
1347: && dl_equal(n,tdl,lij))
1348: || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
1349: && dl_equal(n,tdl,lij)) ) {
1350: MKNODE(ddd,BDY(d),dd);
1351: dd = ddd;
1352: }
1353: }
1354: MKLIST(*rp,dd);
1355: }
1356: }
1357:
1358: void Pdp_nelim(arg,rp)
1359: NODE arg;
1360: Q *rp;
1361: {
1362: if ( arg ) {
1363: asir_assert(ARG0(arg),O_N,"dp_nelim");
1364: dp_nelim = QTOS((Q)ARG0(arg));
1365: }
1366: STOQ(dp_nelim,*rp);
1367: }
1368:
1369: void Pdp_mag(arg,rp)
1370: NODE arg;
1371: Q *rp;
1372: {
1373: DP p;
1374: int s;
1375: MP m;
1376:
1377: p = (DP)ARG0(arg);
1378: asir_assert(p,O_DP,"dp_mag");
1379: if ( !p )
1380: *rp = 0;
1381: else {
1382: for ( s = 0, m = BDY(p); m; m = NEXT(m) )
1383: s += p_mag(m->c);
1384: STOQ(s,*rp);
1385: }
1386: }
1387:
1388: extern int kara_mag;
1389:
1390: void Pdp_set_kara(arg,rp)
1391: NODE arg;
1392: Q *rp;
1393: {
1394: if ( arg ) {
1395: asir_assert(ARG0(arg),O_N,"dp_set_kara");
1396: kara_mag = QTOS((Q)ARG0(arg));
1397: }
1398: STOQ(kara_mag,*rp);
1399: }
1400:
1401: void Pdp_homo(arg,rp)
1402: NODE arg;
1403: DP *rp;
1404: {
1405: asir_assert(ARG0(arg),O_DP,"dp_homo");
1406: dp_homo((DP)ARG0(arg),rp);
1407: }
1408:
1.8 noro 1409: void Pdp_dehomo(arg,rp)
1410: NODE arg;
1.1 noro 1411: DP *rp;
1412: {
1.8 noro 1413: asir_assert(ARG0(arg),O_DP,"dp_dehomo");
1414: dp_dehomo((DP)ARG0(arg),rp);
1415: }
1416:
1417: void Pdp_gr_flags(arg,rp)
1418: NODE arg;
1419: LIST *rp;
1420: {
1421: Obj name,value;
1422: NODE n;
1.1 noro 1423:
1.8 noro 1424: if ( arg ) {
1425: asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
1426: n = BDY((LIST)ARG0(arg));
1427: while ( n ) {
1428: name = (Obj)BDY(n); n = NEXT(n);
1429: if ( !n )
1430: break;
1431: else {
1432: value = (Obj)BDY(n); n = NEXT(n);
1433: }
1434: dp_set_flag(name,value);
1.1 noro 1435: }
1436: }
1.8 noro 1437: dp_make_flaglist(rp);
1438: }
1439:
1.29 noro 1440: extern int DP_Print, DP_PrintShort;
1.8 noro 1441:
1442: void Pdp_gr_print(arg,rp)
1443: NODE arg;
1444: Q *rp;
1445: {
1446: Q q;
1.29 noro 1447: int s;
1.8 noro 1448:
1449: if ( arg ) {
1450: asir_assert(ARG0(arg),O_N,"dp_gr_print");
1.29 noro 1451: q = (Q)ARG0(arg);
1452: s = QTOS(q);
1453: switch ( s ) {
1454: case 0:
1455: DP_Print = 0; DP_PrintShort = 0;
1456: break;
1457: case 1:
1458: DP_Print = 1;
1459: break;
1.41 noro 1460: case 2:
1.29 noro 1461: DP_Print = 0; DP_PrintShort = 1;
1.43 noro 1462: break;
1.41 noro 1463: default:
1464: DP_Print = s; DP_PrintShort = 0;
1.29 noro 1465: break;
1466: }
1467: } else {
1468: if ( DP_Print ) {
1469: STOQ(1,q);
1470: } else if ( DP_PrintShort ) {
1471: STOQ(2,q);
1472: } else
1473: q = 0;
1474: }
1.8 noro 1475: *rp = q;
1.1 noro 1476: }
1477:
1.46 noro 1478: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
1479: int *modular,struct order_spec **ord)
1480: {
1481: NODE t,p;
1482: Q m;
1483: char *key;
1484: Obj value,dmy;
1485: int ord_is_set = 0;
1486: int modular_is_set = 0;
1487: int homo_is_set = 0;
1.47 noro 1488: VL vl,vl0;
1.46 noro 1489: LIST vars;
1.47 noro 1490: char xiname[BUFSIZ];
1491: NODE x0,x;
1492: DP d;
1493: P xi;
1494: int nv,i;
1.46 noro 1495:
1496: /* extract vars */
1497: vars = 0;
1498: for ( t = opt; t; t = NEXT(t) ) {
1499: p = BDY((LIST)BDY(t));
1500: key = BDY((STRING)BDY(p));
1501: value = (Obj)BDY(NEXT(p));
1502: if ( !strcmp(key,"v") ) {
1503: /* variable list */
1504: vars = (LIST)value;
1505: break;
1506: }
1507: }
1.48 noro 1508: if ( vars ) {
1509: *v = vars; pltovl(vars,&vl);
1510: } else {
1511: for ( t = BDY(f); t; t = NEXT(t) )
1512: if ( BDY(t) && OID((Obj)BDY(t))==O_DP )
1513: break;
1514: if ( t ) {
1515: /* f is DP list */
1516: /* create dummy var list */
1517: d = (DP)BDY(t);
1518: nv = NV(d);
1519: for ( i = 0, vl0 = 0, x0 = 0; i < nv; i++ ) {
1520: NEXTVL(vl0,vl);
1521: NEXTNODE(x0,x);
1522: sprintf(xiname,"x%d",i);
1523: makevar(xiname,&xi);
1524: x->body = (pointer)xi;
1525: vl->v = VR((P)xi);
1526: }
1527: if ( vl0 ) {
1528: NEXT(vl) = 0;
1529: NEXT(x) = 0;
1530: }
1531: MKLIST(vars,x0);
1532: *v = vars;
1533: vl = vl0;
1534: } else {
1535: get_vars((Obj)f,&vl); vltopl(vl,v);
1.47 noro 1536: }
1.46 noro 1537: }
1538:
1539: for ( t = opt; t; t = NEXT(t) ) {
1540: p = BDY((LIST)BDY(t));
1541: key = BDY((STRING)BDY(p));
1542: value = (Obj)BDY(NEXT(p));
1543: if ( !strcmp(key,"v") ) {
1544: /* variable list; ignore */
1545: } else if ( !strcmp(key,"order") ) {
1546: /* order spec */
1.51 noro 1547: if ( !vl )
1548: error("parse_gr_option : variables must be specified");
1.46 noro 1549: create_order_spec(vl,value,ord);
1550: ord_is_set = 1;
1551: } else if ( !strcmp(key,"block") ) {
1552: create_order_spec(0,value,ord);
1.51 noro 1553: ord_is_set = 1;
1.46 noro 1554: } else if ( !strcmp(key,"matrix") ) {
1555: create_order_spec(0,value,ord);
1.51 noro 1556: ord_is_set = 1;
1.46 noro 1557: } else if ( !strcmp(key,"sugarweight") ) {
1558: /* weight */
1559: Pdp_set_weight(NEXT(p),&dmy);
1560: } else if ( !strcmp(key,"homo") ) {
1561: *homo = (Num)value;
1562: homo_is_set = 1;
1563: } else if ( !strcmp(key,"trace") ) {
1564: m = (Q)value;
1565: if ( !m )
1566: *modular = 0;
1567: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1
1568: && BD(NM(m))[0] >= 0x80000000) )
1569: error("parse_gr_option : too large modulus");
1570: else
1571: *modular = QTOS(m);
1572: modular_is_set = 1;
1573: } else
1574: error("parse_gr_option : not implemented");
1575: }
1576: if ( !ord_is_set ) create_order_spec(0,0,ord);
1577: if ( !modular_is_set ) *modular = 0;
1578: if ( !homo_is_set ) *homo = 0;
1579: }
1580:
1.8 noro 1581: void Pdp_gr_main(arg,rp)
1.1 noro 1582: NODE arg;
1.8 noro 1583: LIST *rp;
1.1 noro 1584: {
1.8 noro 1585: LIST f,v;
1.46 noro 1586: VL vl;
1.8 noro 1587: Num homo;
1588: Q m;
1.46 noro 1589: int modular,ac;
1590: struct order_spec *ord;
1.8 noro 1591:
1.11 noro 1592: do_weyl = 0;
1.8 noro 1593: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1.46 noro 1594: f = (LIST)ARG0(arg);
1.25 noro 1595: f = remove_zero_from_list(f);
1596: if ( !BDY(f) ) {
1597: *rp = f; return;
1598: }
1.53 ! noro 1599: if ( (ac = argc(arg)) == 5 ) {
1.46 noro 1600: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
1601: asir_assert(ARG2(arg),O_N,"dp_gr_main");
1602: asir_assert(ARG3(arg),O_N,"dp_gr_main");
1.49 noro 1603: v = (LIST)ARG1(arg);
1.46 noro 1604: homo = (Num)ARG2(arg);
1605: m = (Q)ARG3(arg);
1606: if ( !m )
1607: modular = 0;
1608: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1609: error("dp_gr_main : too large modulus");
1610: else
1611: modular = QTOS(m);
1612: create_order_spec(0,ARG4(arg),&ord);
1.53 ! noro 1613: } else if ( current_option )
! 1614: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.46 noro 1615: else if ( ac == 1 )
1616: parse_gr_option(f,0,&v,&homo,&modular,&ord);
1.8 noro 1617: else
1.46 noro 1618: error("dp_gr_main : invalid argument");
1619: dp_gr_main(f,v,homo,modular,0,ord,rp);
1.16 noro 1620: }
1621:
1622: void Pdp_gr_f_main(arg,rp)
1623: NODE arg;
1624: LIST *rp;
1625: {
1626: LIST f,v;
1627: Num homo;
1.26 noro 1628: int m,field,t;
1.46 noro 1629: struct order_spec *ord;
1.26 noro 1630: NODE n;
1.16 noro 1631:
1632: do_weyl = 0;
1633: asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
1634: asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
1635: asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
1636: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1637: f = remove_zero_from_list(f);
1638: if ( !BDY(f) ) {
1639: *rp = f; return;
1640: }
1.16 noro 1641: homo = (Num)ARG2(arg);
1.27 noro 1642: #if 0
1643: asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
1.26 noro 1644: m = QTOS((Q)ARG3(arg));
1645: if ( m )
1646: error("dp_gr_f_main : trace lifting is not implemented yet");
1.46 noro 1647: create_order_spec(0,ARG4(arg),&ord);
1.27 noro 1648: #else
1649: m = 0;
1.46 noro 1650: create_order_spec(0,ARG3(arg),&ord);
1.27 noro 1651: #endif
1.26 noro 1652: field = 0;
1653: for ( n = BDY(f); n; n = NEXT(n) ) {
1654: t = get_field_type(BDY(n));
1655: if ( !t )
1656: continue;
1657: if ( t < 0 )
1658: error("dp_gr_f_main : incosistent coefficients");
1659: if ( !field )
1660: field = t;
1661: else if ( t != field )
1662: error("dp_gr_f_main : incosistent coefficients");
1663: }
1.46 noro 1664: dp_gr_main(f,v,homo,m?1:0,field,ord,rp);
1.1 noro 1665: }
1666:
1.8 noro 1667: void Pdp_f4_main(arg,rp)
1668: NODE arg;
1669: LIST *rp;
1.1 noro 1670: {
1.8 noro 1671: LIST f,v;
1.46 noro 1672: struct order_spec *ord;
1.1 noro 1673:
1.11 noro 1674: do_weyl = 0;
1.8 noro 1675: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1676: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1677: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1678: f = remove_zero_from_list(f);
1679: if ( !BDY(f) ) {
1680: *rp = f; return;
1681: }
1.46 noro 1682: create_order_spec(0,ARG2(arg),&ord);
1683: dp_f4_main(f,v,ord,rp);
1.22 noro 1684: }
1685:
1686: /* dp_gr_checklist(list of dp) */
1687:
1688: void Pdp_gr_checklist(arg,rp)
1689: NODE arg;
1690: LIST *rp;
1691: {
1692: VECT g;
1693: LIST dp;
1694: NODE r;
1.23 noro 1695: int n;
1.22 noro 1696:
1697: do_weyl = 0;
1698: asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
1.23 noro 1699: asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
1700: n = QTOS((Q)ARG1(arg));
1701: gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
1.22 noro 1702: r = mknode(2,g,dp);
1703: MKLIST(*rp,r);
1.1 noro 1704: }
1705:
1.8 noro 1706: void Pdp_f4_mod_main(arg,rp)
1707: NODE arg;
1708: LIST *rp;
1.1 noro 1709: {
1.8 noro 1710: LIST f,v;
1711: int m;
1.46 noro 1712: struct order_spec *ord;
1.8 noro 1713:
1.11 noro 1714: do_weyl = 0;
1.17 noro 1715: asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
1716: asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
1717: asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
1.8 noro 1718: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 1719: f = remove_zero_from_list(f);
1720: if ( !BDY(f) ) {
1721: *rp = f; return;
1722: }
1.20 noro 1723: if ( !m )
1724: error("dp_f4_mod_main : invalid argument");
1.46 noro 1725: create_order_spec(0,ARG3(arg),&ord);
1726: dp_f4_mod_main(f,v,m,ord,rp);
1.8 noro 1727: }
1.1 noro 1728:
1.8 noro 1729: void Pdp_gr_mod_main(arg,rp)
1730: NODE arg;
1731: LIST *rp;
1732: {
1733: LIST f,v;
1734: Num homo;
1735: int m;
1.46 noro 1736: struct order_spec *ord;
1.8 noro 1737:
1.11 noro 1738: do_weyl = 0;
1.8 noro 1739: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
1740: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
1741: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
1742: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1.11 noro 1743: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1744: f = remove_zero_from_list(f);
1745: if ( !BDY(f) ) {
1746: *rp = f; return;
1747: }
1.11 noro 1748: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 1749: if ( !m )
1750: error("dp_gr_mod_main : invalid argument");
1.46 noro 1751: create_order_spec(0,ARG4(arg),&ord);
1752: dp_gr_mod_main(f,v,homo,m,ord,rp);
1.33 noro 1753: }
1754:
1.40 noro 1755: void Pnd_f4(arg,rp)
1756: NODE arg;
1757: LIST *rp;
1758: {
1759: LIST f,v;
1760: int m,homo;
1.46 noro 1761: struct order_spec *ord;
1.40 noro 1762:
1763: do_weyl = 0;
1764: asir_assert(ARG0(arg),O_LIST,"nd_gr");
1765: asir_assert(ARG1(arg),O_LIST,"nd_gr");
1766: asir_assert(ARG2(arg),O_N,"nd_gr");
1767: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1768: f = remove_zero_from_list(f);
1769: if ( !BDY(f) ) {
1770: *rp = f; return;
1771: }
1772: m = QTOS((Q)ARG2(arg));
1.46 noro 1773: create_order_spec(0,ARG3(arg),&ord);
1774: nd_gr(f,v,m,1,ord,rp);
1.40 noro 1775: }
1776:
1.33 noro 1777: void Pnd_gr(arg,rp)
1778: NODE arg;
1779: LIST *rp;
1780: {
1781: LIST f,v;
1.36 noro 1782: int m,homo;
1.46 noro 1783: struct order_spec *ord;
1.33 noro 1784:
1785: do_weyl = 0;
1786: asir_assert(ARG0(arg),O_LIST,"nd_gr");
1787: asir_assert(ARG1(arg),O_LIST,"nd_gr");
1.36 noro 1788: asir_assert(ARG2(arg),O_N,"nd_gr");
1.33 noro 1789: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1790: f = remove_zero_from_list(f);
1791: if ( !BDY(f) ) {
1792: *rp = f; return;
1793: }
1794: m = QTOS((Q)ARG2(arg));
1.46 noro 1795: create_order_spec(0,ARG3(arg),&ord);
1796: nd_gr(f,v,m,0,ord,rp);
1.36 noro 1797: }
1798:
1799: void Pnd_gr_trace(arg,rp)
1800: NODE arg;
1801: LIST *rp;
1802: {
1803: LIST f,v;
1804: int m,homo;
1.46 noro 1805: struct order_spec *ord;
1.36 noro 1806:
1807: do_weyl = 0;
1808: asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
1809: asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
1810: asir_assert(ARG2(arg),O_N,"nd_gr_trace");
1811: asir_assert(ARG3(arg),O_N,"nd_gr_trace");
1812: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1813: f = remove_zero_from_list(f);
1814: if ( !BDY(f) ) {
1815: *rp = f; return;
1816: }
1817: homo = QTOS((Q)ARG2(arg));
1818: m = QTOS((Q)ARG3(arg));
1.46 noro 1819: create_order_spec(0,ARG4(arg),&ord);
1820: nd_gr_trace(f,v,m,homo,ord,rp);
1.11 noro 1821: }
1822:
1.38 noro 1823: void Pnd_weyl_gr(arg,rp)
1824: NODE arg;
1825: LIST *rp;
1826: {
1827: LIST f,v;
1828: int m,homo;
1.46 noro 1829: struct order_spec *ord;
1.38 noro 1830:
1831: do_weyl = 1;
1832: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr");
1833: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr");
1834: asir_assert(ARG2(arg),O_N,"nd_weyl_gr");
1835: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1836: f = remove_zero_from_list(f);
1837: if ( !BDY(f) ) {
1838: *rp = f; return;
1839: }
1840: m = QTOS((Q)ARG2(arg));
1.46 noro 1841: create_order_spec(0,ARG3(arg),&ord);
1842: nd_gr(f,v,m,0,ord,rp);
1.38 noro 1843: }
1844:
1845: void Pnd_weyl_gr_trace(arg,rp)
1846: NODE arg;
1847: LIST *rp;
1848: {
1849: LIST f,v;
1850: int m,homo;
1.46 noro 1851: struct order_spec *ord;
1.38 noro 1852:
1853: do_weyl = 1;
1854: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr_trace");
1855: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr_trace");
1856: asir_assert(ARG2(arg),O_N,"nd_weyl_gr_trace");
1857: asir_assert(ARG3(arg),O_N,"nd_weyl_gr_trace");
1858: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1859: f = remove_zero_from_list(f);
1860: if ( !BDY(f) ) {
1861: *rp = f; return;
1862: }
1863: homo = QTOS((Q)ARG2(arg));
1864: m = QTOS((Q)ARG3(arg));
1.46 noro 1865: create_order_spec(0,ARG4(arg),&ord);
1866: nd_gr_trace(f,v,m,homo,ord,rp);
1.38 noro 1867: }
1.39 noro 1868:
1869: void Pnd_nf(arg,rp)
1870: NODE arg;
1871: P *rp;
1872: {
1873: P f;
1874: LIST g,v;
1.46 noro 1875: struct order_spec *ord;
1.39 noro 1876:
1877: do_weyl = 0;
1878: asir_assert(ARG0(arg),O_P,"nd_nf");
1879: asir_assert(ARG1(arg),O_LIST,"nd_nf");
1880: asir_assert(ARG2(arg),O_LIST,"nd_nf");
1881: asir_assert(ARG4(arg),O_N,"nd_nf");
1882: f = (P)ARG0(arg);
1883: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
1884: if ( !BDY(g) ) {
1885: *rp = f; return;
1886: }
1887: v = (LIST)ARG2(arg);
1.46 noro 1888: create_order_spec(0,ARG3(arg),&ord);
1889: nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),ord,rp);
1.39 noro 1890: }
1891:
1.11 noro 1892: /* for Weyl algebra */
1893:
1894: void Pdp_weyl_gr_main(arg,rp)
1895: NODE arg;
1896: LIST *rp;
1897: {
1898: LIST f,v;
1899: Num homo;
1900: Q m;
1.49 noro 1901: int modular,ac;
1.46 noro 1902: struct order_spec *ord;
1.11 noro 1903:
1.49 noro 1904:
1.11 noro 1905: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1.49 noro 1906: f = (LIST)ARG0(arg);
1.25 noro 1907: f = remove_zero_from_list(f);
1908: if ( !BDY(f) ) {
1909: *rp = f; return;
1910: }
1.53 ! noro 1911: if ( (ac = argc(arg)) == 5 ) {
1.49 noro 1912: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1913: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1914: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1915: v = (LIST)ARG1(arg);
1916: homo = (Num)ARG2(arg);
1917: m = (Q)ARG3(arg);
1918: if ( !m )
1919: modular = 0;
1920: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1921: error("dp_weyl_gr_main : too large modulus");
1922: else
1923: modular = QTOS(m);
1924: create_order_spec(0,ARG4(arg),&ord);
1.53 ! noro 1925: } else if ( current_option )
! 1926: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.49 noro 1927: else if ( ac == 1 )
1928: parse_gr_option(f,0,&v,&homo,&modular,&ord);
1.11 noro 1929: else
1.49 noro 1930: error("dp_weyl_gr_main : invalid argument");
1.12 noro 1931: do_weyl = 1;
1.46 noro 1932: dp_gr_main(f,v,homo,modular,0,ord,rp);
1.16 noro 1933: do_weyl = 0;
1934: }
1935:
1936: void Pdp_weyl_gr_f_main(arg,rp)
1937: NODE arg;
1938: LIST *rp;
1939: {
1940: LIST f,v;
1941: Num homo;
1.46 noro 1942: struct order_spec *ord;
1.16 noro 1943:
1944: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1945: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1946: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1947: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1948: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1949: f = remove_zero_from_list(f);
1950: if ( !BDY(f) ) {
1951: *rp = f; return;
1952: }
1.16 noro 1953: homo = (Num)ARG2(arg);
1.46 noro 1954: create_order_spec(0,ARG3(arg),&ord);
1.16 noro 1955: do_weyl = 1;
1.46 noro 1956: dp_gr_main(f,v,homo,0,1,ord,rp);
1.12 noro 1957: do_weyl = 0;
1.11 noro 1958: }
1959:
1960: void Pdp_weyl_f4_main(arg,rp)
1961: NODE arg;
1962: LIST *rp;
1963: {
1964: LIST f,v;
1.46 noro 1965: struct order_spec *ord;
1.11 noro 1966:
1967: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1968: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1969: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 1970: f = remove_zero_from_list(f);
1971: if ( !BDY(f) ) {
1972: *rp = f; return;
1973: }
1.46 noro 1974: create_order_spec(0,ARG2(arg),&ord);
1.12 noro 1975: do_weyl = 1;
1.46 noro 1976: dp_f4_main(f,v,ord,rp);
1.12 noro 1977: do_weyl = 0;
1.11 noro 1978: }
1979:
1980: void Pdp_weyl_f4_mod_main(arg,rp)
1981: NODE arg;
1982: LIST *rp;
1983: {
1984: LIST f,v;
1985: int m;
1.46 noro 1986: struct order_spec *ord;
1.11 noro 1987:
1988: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1989: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1990: asir_assert(ARG2(arg),O_N,"dp_f4_main");
1991: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 1992: f = remove_zero_from_list(f);
1993: if ( !BDY(f) ) {
1994: *rp = f; return;
1995: }
1.20 noro 1996: if ( !m )
1997: error("dp_weyl_f4_mod_main : invalid argument");
1.46 noro 1998: create_order_spec(0,ARG3(arg),&ord);
1.12 noro 1999: do_weyl = 1;
1.46 noro 2000: dp_f4_mod_main(f,v,m,ord,rp);
1.12 noro 2001: do_weyl = 0;
1.11 noro 2002: }
2003:
2004: void Pdp_weyl_gr_mod_main(arg,rp)
2005: NODE arg;
2006: LIST *rp;
2007: {
2008: LIST f,v;
2009: Num homo;
2010: int m;
1.46 noro 2011: struct order_spec *ord;
1.11 noro 2012:
2013: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
2014: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
2015: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
2016: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
1.8 noro 2017: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2018: f = remove_zero_from_list(f);
2019: if ( !BDY(f) ) {
2020: *rp = f; return;
2021: }
1.8 noro 2022: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 2023: if ( !m )
2024: error("dp_weyl_gr_mod_main : invalid argument");
1.46 noro 2025: create_order_spec(0,ARG4(arg),&ord);
1.12 noro 2026: do_weyl = 1;
1.46 noro 2027: dp_gr_mod_main(f,v,homo,m,ord,rp);
1.12 noro 2028: do_weyl = 0;
1.1 noro 2029: }
1.8 noro 2030:
1.24 noro 2031: static VECT current_dl_weight_vector_obj;
2032: int *current_dl_weight_vector;
2033:
2034: void Pdp_set_weight(arg,rp)
2035: NODE arg;
2036: VECT *rp;
2037: {
2038: VECT v;
2039: int i,n;
1.45 noro 2040: NODE node;
1.24 noro 2041:
2042: if ( !arg )
2043: *rp = current_dl_weight_vector_obj;
2044: else if ( !ARG0(arg) ) {
2045: current_dl_weight_vector_obj = 0;
2046: current_dl_weight_vector = 0;
2047: *rp = 0;
2048: } else {
1.45 noro 2049: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
2050: error("dp_set_weight : invalid argument");
2051: if ( OID(ARG0(arg)) == O_VECT )
2052: v = (VECT)ARG0(arg);
2053: else {
2054: node = (NODE)BDY((LIST)ARG0(arg));
2055: n = length(node);
2056: MKVECT(v,n);
2057: for ( i = 0; i < n; i++, node = NEXT(node) )
2058: BDY(v)[i] = BDY(node);
2059: }
1.24 noro 2060: current_dl_weight_vector_obj = v;
2061: n = v->len;
2062: current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
2063: for ( i = 0; i < n; i++ )
2064: current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
2065: *rp = v;
2066: }
2067: }
2068:
2069: static VECT current_weyl_weight_vector_obj;
2070: int *current_weyl_weight_vector;
1.15 noro 2071:
2072: void Pdp_weyl_set_weight(arg,rp)
2073: NODE arg;
2074: VECT *rp;
2075: {
2076: VECT v;
2077: int i,n;
2078:
2079: if ( !arg )
1.24 noro 2080: *rp = current_weyl_weight_vector_obj;
1.15 noro 2081: else {
2082: asir_assert(ARG0(arg),O_VECT,"dp_weyl_set_weight");
2083: v = (VECT)ARG0(arg);
1.24 noro 2084: current_weyl_weight_vector_obj = v;
1.15 noro 2085: n = v->len;
1.24 noro 2086: current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
1.15 noro 2087: for ( i = 0; i < n; i++ )
1.24 noro 2088: current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
1.15 noro 2089: *rp = v;
2090: }
1.25 noro 2091: }
2092:
2093: LIST remove_zero_from_list(LIST l)
2094: {
2095: NODE n,r0,r;
2096: LIST rl;
2097:
2098: asir_assert(l,O_LIST,"remove_zero_from_list");
2099: n = BDY(l);
2100: for ( r0 = 0; n; n = NEXT(n) )
2101: if ( BDY(n) ) {
2102: NEXTNODE(r0,r);
2103: BDY(r) = BDY(n);
2104: }
2105: if ( r0 )
2106: NEXT(r) = 0;
2107: MKLIST(rl,r0);
2108: return rl;
1.26 noro 2109: }
2110:
2111: int get_field_type(P p)
2112: {
2113: int type,t;
2114: DCP dc;
2115:
2116: if ( !p )
2117: return 0;
2118: else if ( NUM(p) )
2119: return NID((Num)p);
2120: else {
2121: type = 0;
2122: for ( dc = DC(p); dc; dc = NEXT(dc) ) {
2123: t = get_field_type(COEF(dc));
2124: if ( !t )
2125: continue;
2126: if ( t < 0 )
2127: return t;
2128: if ( !type )
2129: type = t;
2130: else if ( t != type )
2131: return -1;
2132: }
2133: return type;
1.52 noro 2134: }
2135: }
2136:
2137: void Pdpv_ord(NODE arg,Obj *rp)
2138: {
2139: int ac,id;
2140: LIST shift;
2141:
2142: ac = argc(arg);
2143: if ( ac ) {
2144: id = QTOS((Q)ARG0(arg));
2145: if ( ac > 1 && ARG1(arg) && OID((Obj)ARG1(arg))==O_LIST )
2146: shift = (LIST)ARG1(arg);
2147: else
2148: shift = 0;
2149: create_modorder_spec(id,shift,&dp_current_modspec);
2150: }
2151: *rp = dp_current_modspec->obj;
2152: }
2153:
2154: void Pdpv_ht(NODE arg,LIST *rp)
2155: {
2156: NODE n;
2157: DP ht;
2158: int pos;
2159: DPV p;
2160: Q q;
2161:
2162: asir_assert(ARG0(arg),O_DPV,"dpv_ht");
2163: p = (DPV)ARG0(arg);
2164: pos = dpv_hp(p);
2165: if ( pos < 0 )
2166: ht = 0;
2167: else
2168: dp_ht(BDY(p)[pos],&ht);
2169: STOQ(pos,q);
2170: n = mknode(2,q,ht);
2171: MKLIST(*rp,n);
2172: }
2173:
2174: void Pdpv_hm(NODE arg,LIST *rp)
2175: {
2176: NODE n;
2177: DP ht;
2178: int pos;
2179: DPV p;
2180: Q q;
2181:
2182: asir_assert(ARG0(arg),O_DPV,"dpv_hm");
2183: p = (DPV)ARG0(arg);
2184: pos = dpv_hp(p);
2185: if ( pos < 0 )
2186: ht = 0;
2187: else
2188: dp_hm(BDY(p)[pos],&ht);
2189: STOQ(pos,q);
2190: n = mknode(2,q,ht);
2191: MKLIST(*rp,n);
2192: }
2193:
2194: void Pdpv_hc(NODE arg,LIST *rp)
2195: {
2196: NODE n;
2197: P hc;
2198: int pos;
2199: DPV p;
2200: Q q;
2201:
2202: asir_assert(ARG0(arg),O_DPV,"dpv_hc");
2203: p = (DPV)ARG0(arg);
2204: pos = dpv_hp(p);
2205: if ( pos < 0 )
2206: hc = 0;
2207: else
2208: hc = BDY(BDY(p)[pos])->c;
2209: STOQ(pos,q);
2210: n = mknode(2,q,hc);
2211: MKLIST(*rp,n);
2212: }
2213:
2214: int dpv_hp(DPV p)
2215: {
2216: int len,i,maxp,maxw,w,slen;
2217: int *shift;
2218: DP *e;
2219:
2220: len = p->len;
2221: e = p->body;
2222: slen = dp_current_modspec->len;
2223: shift = dp_current_modspec->degree_shift;
2224: switch ( dp_current_modspec->id ) {
2225: case ORD_REVGRADLEX:
2226: for ( maxp = -1, i = 0; i < len; i++ )
2227: if ( !e[i] ) continue;
2228: else if ( maxp < 0 ) {
2229: maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
2230: } else {
2231: w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
2232: if ( w >= maxw ) {
2233: maxw = w; maxp = i;
2234: }
2235: }
2236: return maxp;
2237: case ORD_GRADLEX:
2238: for ( maxp = -1, i = 0; i < len; i++ )
2239: if ( !e[i] ) continue;
2240: else if ( maxp < 0 ) {
2241: maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
2242: } else {
2243: w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
2244: if ( w > maxw ) {
2245: maxw = w; maxp = i;
2246: }
2247: }
2248: return maxp;
2249: break;
2250: case ORD_LEX:
2251: for ( i = 0; i < len; i++ )
2252: if ( e[i] ) return i;
2253: return -1;
2254: break;
1.26 noro 2255: }
1.15 noro 2256: }
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