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