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