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