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