Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.15
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.15 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.14 2000/12/14 08:43:47 noro Exp $
1.5 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "base.h"
52: #include "parse.h"
53:
54: extern int dp_fcoeffs;
1.8 noro 55: extern int dp_nelim;
56: extern int dp_order_pair_length;
57: extern struct order_pair *dp_order_pair;
58: extern struct order_spec dp_current_spec;
59:
1.11 noro 60: int do_weyl;
1.1 noro 61:
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();
65: void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv();
66: void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat();
1.9 noro 67: void Pdp_nf(),Pdp_true_nf();
1.1 noro 68: void Pdp_nf_mod(),Pdp_true_nf_mod();
69: void Pdp_criB(),Pdp_nelim();
1.9 noro 70: void Pdp_minp(),Pdp_sp_mod();
1.1 noro 71: void Pdp_homo(),Pdp_dehomo();
72: void Pdp_gr_mod_main();
73: void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags();
74: void Pdp_f4_main(),Pdp_f4_mod_main();
75: void Pdp_gr_print();
1.8 noro 76: void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_mdtod();
77: void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
78: void Pdp_cont();
1.1 noro 79:
1.13 noro 80: void Pdp_weyl_red();
81: void Pdp_weyl_sp();
82: void Pdp_weyl_nf(),Pdp_weyl_nf_mod();
1.11 noro 83: void Pdp_weyl_gr_main(),Pdp_weyl_gr_mod_main();
84: void Pdp_weyl_f4_main(),Pdp_weyl_f4_mod_main();
1.13 noro 85: void Pdp_weyl_mul(),Pdp_weyl_mul_mod();
1.15 ! noro 86: void Pdp_weyl_set_weight();
1.11 noro 87:
1.1 noro 88: struct ftab dp_tab[] = {
1.8 noro 89: /* content reduction */
1.1 noro 90: {"dp_ptozp",Pdp_ptozp,1},
91: {"dp_ptozp2",Pdp_ptozp2,2},
92: {"dp_prim",Pdp_prim,1},
1.8 noro 93: {"dp_red_coef",Pdp_red_coef,2},
94: {"dp_cont",Pdp_cont,1},
95:
1.11 noro 96: /* polynomial ring */
1.8 noro 97: /* s-poly */
98: {"dp_sp",Pdp_sp,2},
99: {"dp_sp_mod",Pdp_sp_mod,3},
100:
101: /* m-reduction */
1.1 noro 102: {"dp_red",Pdp_red,3},
103: {"dp_red_mod",Pdp_red_mod,4},
1.8 noro 104:
105: /* normal form */
1.1 noro 106: {"dp_nf",Pdp_nf,4},
107: {"dp_true_nf",Pdp_true_nf,4},
108: {"dp_nf_mod",Pdp_nf_mod,5},
109: {"dp_true_nf_mod",Pdp_true_nf_mod,5},
1.8 noro 110: {"dp_lnf_mod",Pdp_lnf_mod,3},
111: {"dp_nf_tab_mod",Pdp_nf_tab_mod,3},
112:
113: /* Buchberger algorithm */
1.1 noro 114: {"dp_gr_main",Pdp_gr_main,5},
115: {"dp_gr_mod_main",Pdp_gr_mod_main,5},
1.8 noro 116:
117: /* F4 algorithm */
1.1 noro 118: {"dp_f4_main",Pdp_f4_main,3},
119: {"dp_f4_mod_main",Pdp_f4_mod_main,4},
1.8 noro 120:
1.11 noro 121: /* weyl algebra */
1.12 noro 122: /* multiplication */
123: {"dp_weyl_mul",Pdp_weyl_mul,2},
1.13 noro 124: {"dp_weyl_mul_mod",Pdp_weyl_mul_mod,3},
1.12 noro 125:
1.11 noro 126: /* s-poly */
127: {"dp_weyl_sp",Pdp_weyl_sp,2},
128:
129: /* m-reduction */
130: {"dp_weyl_red",Pdp_weyl_red,3},
131:
132: /* normal form */
133: {"dp_weyl_nf",Pdp_weyl_nf,4},
1.13 noro 134: {"dp_weyl_nf_mod",Pdp_weyl_nf_mod,5},
1.11 noro 135:
136: /* Buchberger algorithm */
137: {"dp_weyl_gr_main",Pdp_weyl_gr_main,5},
138: {"dp_weyl_gr_mod_main",Pdp_weyl_gr_mod_main,5},
139:
140: /* F4 algorithm */
141: {"dp_weyl_f4_main",Pdp_weyl_f4_main,3},
142: {"dp_weyl_f4_mod_main",Pdp_weyl_f4_mod_main,4},
143:
1.15 ! noro 144: /* misc */
! 145: {"dp_weyl_set_weight",Pdp_weyl_set_weight,-1},
1.8 noro 146: {0,0,0},
147: };
148:
149: struct ftab dp_supp_tab[] = {
150: /* setting flags */
151: {"dp_ord",Pdp_ord,-1},
152: {"dp_set_kara",Pdp_set_kara,-1},
153: {"dp_nelim",Pdp_nelim,-1},
1.1 noro 154: {"dp_gr_flags",Pdp_gr_flags,-1},
155: {"dp_gr_print",Pdp_gr_print,-1},
1.8 noro 156:
157: /* converters */
158: {"dp_ptod",Pdp_ptod,2},
159: {"dp_dtop",Pdp_dtop,2},
160: {"dp_homo",Pdp_homo,1},
161: {"dp_dehomo",Pdp_dehomo,1},
162: {"dp_etov",Pdp_etov,1},
163: {"dp_vtoe",Pdp_vtoe,1},
164: {"dp_dtov",Pdp_dtov,1},
165: {"dp_mdtod",Pdp_mdtod,1},
166: {"dp_mod",Pdp_mod,3},
167: {"dp_rat",Pdp_rat,1},
168:
169: /* criteria */
170: {"dp_cri1",Pdp_cri1,2},
171: {"dp_cri2",Pdp_cri2,2},
172: {"dp_criB",Pdp_criB,3},
173:
174: /* simple operation */
175: {"dp_subd",Pdp_subd,2},
176: {"dp_lcm",Pdp_lcm,2},
177: {"dp_hm",Pdp_hm,1},
178: {"dp_ht",Pdp_ht,1},
179: {"dp_hc",Pdp_hc,1},
180: {"dp_rest",Pdp_rest,1},
181:
182: /* degree and size */
183: {"dp_td",Pdp_td,1},
184: {"dp_mag",Pdp_mag,1},
185: {"dp_sugar",Pdp_sugar,1},
186:
187: /* misc */
188: {"dp_mbase",Pdp_mbase,1},
189: {"dp_redble",Pdp_redble,2},
190: {"dp_sep",Pdp_sep,2},
191: {"dp_idiv",Pdp_idiv,2},
192: {"dp_tdiv",Pdp_tdiv,2},
193: {"dp_minp",Pdp_minp,2},
194:
195: {0,0,0}
1.1 noro 196: };
197:
1.8 noro 198: void Pdp_mdtod(arg,rp)
199: NODE arg;
200: DP *rp;
201: {
202: MP m,mr,mr0;
203: DP p;
204: P t;
205:
206: p = (DP)ARG0(arg);
207: if ( !p )
208: *rp = 0;
209: else {
210: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
211: mptop(m->c,&t); NEXTMP(mr0,mr); mr->c = t; mr->dl = m->dl;
212: }
213: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
214: }
215: }
216:
217: void Pdp_sep(arg,rp)
218: NODE arg;
219: VECT *rp;
220: {
221: DP p,r;
222: MP m,t;
223: MP *w0,*w;
224: int i,n,d,nv,sugar;
225: VECT v;
226: pointer *pv;
227:
228: p = (DP)ARG0(arg); m = BDY(p);
229: d = QTOS((Q)ARG1(arg));
230: for ( t = m, n = 0; t; t = NEXT(t), n++ );
231: if ( d > n )
232: d = n;
233: MKVECT(v,d); *rp = v;
234: pv = BDY(v); nv = p->nv; sugar = p->sugar;
235: w0 = (MP *)MALLOC(d*sizeof(MP)); bzero(w0,d*sizeof(MP));
236: w = (MP *)MALLOC(d*sizeof(MP)); bzero(w,d*sizeof(MP));
237: for ( t = BDY(p), i = 0; t; t = NEXT(t), i++, i %= d ) {
238: NEXTMP(w0[i],w[i]); w[i]->c = t->c; w[i]->dl = t->dl;
239: }
240: for ( i = 0; i < d; i++ ) {
241: NEXT(w[i]) = 0; MKDP(nv,w0[i],r); r->sugar = sugar;
242: pv[i] = (pointer)r;
243: }
244: }
245:
246: void Pdp_idiv(arg,rp)
247: NODE arg;
248: DP *rp;
249: {
250: dp_idiv((DP)ARG0(arg),(Q)ARG1(arg),rp);
251: }
252:
253: void Pdp_cont(arg,rp)
254: NODE arg;
255: Q *rp;
256: {
257: dp_cont((DP)ARG0(arg),rp);
258: }
259:
260: void Pdp_dtov(arg,rp)
261: NODE arg;
262: VECT *rp;
263: {
264: dp_dtov((DP)ARG0(arg),rp);
265: }
266:
267: void Pdp_mbase(arg,rp)
268: NODE arg;
269: LIST *rp;
270: {
271: NODE mb;
272:
273: asir_assert(ARG0(arg),O_LIST,"dp_mbase");
274: dp_mbase(BDY((LIST)ARG0(arg)),&mb);
275: MKLIST(*rp,mb);
276: }
277:
278: void Pdp_etov(arg,rp)
279: NODE arg;
280: VECT *rp;
281: {
282: DP dp;
283: int n,i;
284: int *d;
285: VECT v;
286: Q t;
287:
288: dp = (DP)ARG0(arg);
289: asir_assert(dp,O_DP,"dp_etov");
290: n = dp->nv; d = BDY(dp)->dl->d;
291: MKVECT(v,n);
292: for ( i = 0; i < n; i++ ) {
293: STOQ(d[i],t); v->body[i] = (pointer)t;
294: }
295: *rp = v;
296: }
297:
298: void Pdp_vtoe(arg,rp)
299: NODE arg;
300: DP *rp;
301: {
302: DP dp;
303: DL dl;
304: MP m;
305: int n,i,td;
306: int *d;
307: VECT v;
308:
309: v = (VECT)ARG0(arg);
310: asir_assert(v,O_VECT,"dp_vtoe");
311: n = v->len;
312: NEWDL(dl,n); d = dl->d;
313: for ( i = 0, td = 0; i < n; i++ ) {
314: d[i] = QTOS((Q)(v->body[i])); td += d[i];
315: }
316: dl->td = td;
317: NEWMP(m); m->dl = dl; m->c = (P)ONE; NEXT(m) = 0;
318: MKDP(n,m,dp); dp->sugar = td;
319: *rp = dp;
320: }
321:
322: void Pdp_lnf_mod(arg,rp)
323: NODE arg;
324: LIST *rp;
325: {
326: DP r1,r2;
327: NODE b,g,n;
328: int mod;
329:
330: asir_assert(ARG0(arg),O_LIST,"dp_lnf_mod");
331: asir_assert(ARG1(arg),O_LIST,"dp_lnf_mod");
332: asir_assert(ARG2(arg),O_N,"dp_lnf_mod");
333: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
334: mod = QTOS((Q)ARG2(arg));
335: dp_lnf_mod((DP)BDY(b),(DP)BDY(NEXT(b)),g,mod,&r1,&r2);
336: NEWNODE(n); BDY(n) = (pointer)r1;
337: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
338: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
339: }
340:
341: void Pdp_nf_tab_mod(arg,rp)
342: NODE arg;
343: DP *rp;
344: {
345: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_mod");
346: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_mod");
347: asir_assert(ARG2(arg),O_N,"dp_nf_tab_mod");
348: dp_nf_tab_mod((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),
349: QTOS((Q)ARG2(arg)),rp);
350: }
1.1 noro 351:
352: void Pdp_ord(arg,rp)
353: NODE arg;
354: Obj *rp;
355: {
356: struct order_spec spec;
357:
358: if ( !arg )
359: *rp = dp_current_spec.obj;
360: else if ( !create_order_spec((Obj)ARG0(arg),&spec) )
361: error("dp_ord : invalid order specification");
362: else {
363: initd(&spec); *rp = spec.obj;
364: }
365: }
366:
367: void Pdp_ptod(arg,rp)
368: NODE arg;
369: DP *rp;
370: {
371: NODE n;
372: VL vl,tvl;
373:
374: asir_assert(ARG0(arg),O_P,"dp_ptod");
375: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
376: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
377: if ( !vl ) {
378: NEWVL(vl); tvl = vl;
379: } else {
380: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
381: }
382: VR(tvl) = VR((P)BDY(n));
383: }
384: if ( vl )
385: NEXT(tvl) = 0;
386: ptod(CO,vl,(P)ARG0(arg),rp);
387: }
388:
389: void Pdp_dtop(arg,rp)
390: NODE arg;
391: P *rp;
392: {
393: NODE n;
394: VL vl,tvl;
395:
396: asir_assert(ARG0(arg),O_DP,"dp_dtop");
397: asir_assert(ARG1(arg),O_LIST,"dp_dtop");
398: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
399: if ( !vl ) {
400: NEWVL(vl); tvl = vl;
401: } else {
402: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
403: }
404: VR(tvl) = VR((P)BDY(n));
405: }
406: if ( vl )
407: NEXT(tvl) = 0;
408: dtop(CO,vl,(DP)ARG0(arg),rp);
409: }
410:
411: extern LIST Dist;
412:
413: void Pdp_ptozp(arg,rp)
414: NODE arg;
415: DP *rp;
416: {
417: asir_assert(ARG0(arg),O_DP,"dp_ptozp");
1.10 noro 418: dp_ptozp((DP)ARG0(arg),rp);
1.1 noro 419: }
420:
421: void Pdp_ptozp2(arg,rp)
422: NODE arg;
423: LIST *rp;
424: {
425: DP p0,p1,h,r;
426: NODE n0;
427:
428: p0 = (DP)ARG0(arg); p1 = (DP)ARG1(arg);
429: asir_assert(p0,O_DP,"dp_ptozp2");
430: asir_assert(p1,O_DP,"dp_ptozp2");
1.10 noro 431: dp_ptozp2(p0,p1,&h,&r);
1.1 noro 432: NEWNODE(n0); BDY(n0) = (pointer)h;
433: NEWNODE(NEXT(n0)); BDY(NEXT(n0)) = (pointer)r;
434: NEXT(NEXT(n0)) = 0;
435: MKLIST(*rp,n0);
436: }
437:
438: void Pdp_prim(arg,rp)
439: NODE arg;
440: DP *rp;
441: {
442: DP t;
443:
444: asir_assert(ARG0(arg),O_DP,"dp_prim");
445: dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
446: }
447:
448: void Pdp_mod(arg,rp)
449: NODE arg;
450: DP *rp;
451: {
452: DP p;
453: int mod;
454: NODE subst;
455:
456: asir_assert(ARG0(arg),O_DP,"dp_mod");
457: asir_assert(ARG1(arg),O_N,"dp_mod");
458: asir_assert(ARG2(arg),O_LIST,"dp_mod");
459: p = (DP)ARG0(arg); mod = QTOS((Q)ARG1(arg));
460: subst = BDY((LIST)ARG2(arg));
461: dp_mod(p,mod,subst,rp);
462: }
463:
464: void Pdp_rat(arg,rp)
465: NODE arg;
466: DP *rp;
467: {
468: asir_assert(ARG0(arg),O_DP,"dp_rat");
469: dp_rat((DP)ARG0(arg),rp);
470: }
471:
1.9 noro 472: extern int DP_Multiple;
473:
1.1 noro 474: void Pdp_nf(arg,rp)
475: NODE arg;
476: DP *rp;
477: {
478: NODE b;
479: DP *ps;
480: DP g;
481: int full;
482:
1.11 noro 483: do_weyl = 0;
1.1 noro 484: asir_assert(ARG0(arg),O_LIST,"dp_nf");
485: asir_assert(ARG1(arg),O_DP,"dp_nf");
486: asir_assert(ARG2(arg),O_VECT,"dp_nf");
487: asir_assert(ARG3(arg),O_N,"dp_nf");
488: if ( !(g = (DP)ARG1(arg)) ) {
489: *rp = 0; return;
490: }
491: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
492: full = (Q)ARG3(arg) ? 1 : 0;
1.9 noro 493: dp_nf_ptozp(b,g,ps,full,DP_Multiple,rp);
1.1 noro 494: }
495:
1.11 noro 496: void Pdp_weyl_nf(arg,rp)
497: NODE arg;
498: DP *rp;
499: {
500: NODE b;
501: DP *ps;
502: DP g;
503: int full;
504:
505: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf");
506: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf");
507: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf");
508: asir_assert(ARG3(arg),O_N,"dp_weyl_nf");
509: if ( !(g = (DP)ARG1(arg)) ) {
510: *rp = 0; return;
511: }
512: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
513: full = (Q)ARG3(arg) ? 1 : 0;
1.12 noro 514: do_weyl = 1;
1.11 noro 515: dp_nf_ptozp(b,g,ps,full,DP_Multiple,rp);
1.12 noro 516: do_weyl = 0;
1.11 noro 517: }
518:
1.13 noro 519: void Pdp_nf_mod(arg,rp)
520: NODE arg;
521: DP *rp;
522: {
523: NODE b;
524: DP g;
525: DP *ps;
526: int mod,full,ac;
527: NODE n,n0;
528:
1.14 noro 529: do_weyl = 0;
1.13 noro 530: ac = argc(arg);
1.14 noro 531: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
532: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
533: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
534: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
535: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
1.13 noro 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 = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
541: for ( n0 = n = 0; b; b = NEXT(b) ) {
542: NEXTNODE(n0,n);
543: BDY(n) = (pointer)QTOS((Q)BDY(b));
544: }
545: if ( n0 )
546: NEXT(n) = 0;
547: dp_nf_mod(n0,g,ps,mod,full,rp);
548: }
549:
1.1 noro 550: void Pdp_true_nf(arg,rp)
551: NODE arg;
552: LIST *rp;
553: {
554: NODE b,n;
555: DP *ps;
556: DP g;
557: DP nm;
558: P dn;
559: int full;
560:
1.11 noro 561: do_weyl = 0;
1.1 noro 562: asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
563: asir_assert(ARG1(arg),O_DP,"dp_true_nf");
564: asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
565: asir_assert(ARG3(arg),O_N,"dp_nf");
566: if ( !(g = (DP)ARG1(arg)) ) {
567: nm = 0; dn = (P)ONE;
568: } else {
569: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
570: full = (Q)ARG3(arg) ? 1 : 0;
571: dp_true_nf(b,g,ps,full,&nm,&dn);
572: }
573: NEWNODE(n); BDY(n) = (pointer)nm;
574: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
575: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
576: }
577:
1.13 noro 578: void Pdp_weyl_nf_mod(arg,rp)
1.8 noro 579: NODE arg;
580: DP *rp;
581: {
582: NODE b;
583: DP g;
584: DP *ps;
585: int mod,full,ac;
1.9 noro 586: NODE n,n0;
1.8 noro 587:
588: ac = argc(arg);
1.14 noro 589: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_mod");
590: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_mod");
591: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_mod");
592: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_mod");
593: asir_assert(ARG4(arg),O_N,"dp_weyl_nf_mod");
1.8 noro 594: if ( !(g = (DP)ARG1(arg)) ) {
595: *rp = 0; return;
596: }
597: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
598: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
1.9 noro 599: for ( n0 = n = 0; b; b = NEXT(b) ) {
600: NEXTNODE(n0,n);
601: BDY(n) = (pointer)QTOS((Q)BDY(b));
602: }
603: if ( n0 )
604: NEXT(n) = 0;
1.13 noro 605: do_weyl = 1;
606: dp_nf_mod(n0,g,ps,mod,full,rp);
607: do_weyl = 0;
1.8 noro 608: }
609:
610: void Pdp_true_nf_mod(arg,rp)
611: NODE arg;
612: LIST *rp;
613: {
614: NODE b;
615: DP g,nm;
616: P dn;
617: DP *ps;
618: int mod,full;
619: NODE n;
620:
1.11 noro 621: do_weyl = 0;
1.8 noro 622: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
623: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
624: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
625: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
626: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
627: if ( !(g = (DP)ARG1(arg)) ) {
628: nm = 0; dn = (P)ONEM;
629: } else {
630: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
631: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
632: dp_true_nf_mod(b,g,ps,mod,full,&nm,&dn);
633: }
634: NEWNODE(n); BDY(n) = (pointer)nm;
635: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
636: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.1 noro 637: }
638:
639: void Pdp_tdiv(arg,rp)
640: NODE arg;
641: DP *rp;
642: {
643: MP m,mr,mr0;
644: DP p;
645: Q c;
646: N d,q,r;
647: int sgn;
648:
649: asir_assert(ARG0(arg),O_DP,"dp_tdiv");
650: asir_assert(ARG1(arg),O_N,"dp_tdiv");
651: p = (DP)ARG0(arg); d = NM((Q)ARG1(arg)); sgn = SGN((Q)ARG1(arg));
652: if ( !p )
653: *rp = 0;
654: else {
655: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
656: divn(NM((Q)m->c),d,&q,&r);
657: if ( r ) {
658: *rp = 0; return;
659: } else {
660: NEXTMP(mr0,mr); NTOQ(q,SGN((Q)m->c)*sgn,c);
661: mr->c = (P)c; mr->dl = m->dl;
662: }
663: }
664: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
665: }
666: }
667:
668: void Pdp_red_coef(arg,rp)
669: NODE arg;
670: DP *rp;
671: {
672: MP m,mr,mr0;
673: P q,r;
674: DP p;
675: P mod;
676:
677: p = (DP)ARG0(arg); mod = (P)ARG1(arg);
678: asir_assert(p,O_DP,"dp_red_coef");
679: asir_assert(mod,O_P,"dp_red_coef");
680: if ( !p )
681: *rp = 0;
682: else {
683: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
684: divsrp(CO,m->c,mod,&q,&r);
685: if ( r ) {
686: NEXTMP(mr0,mr); mr->c = r; mr->dl = m->dl;
687: }
688: }
689: if ( mr0 ) {
690: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
691: } else
692: *rp = 0;
693: }
694: }
695:
696: void Pdp_redble(arg,rp)
697: NODE arg;
698: Q *rp;
699: {
700: asir_assert(ARG0(arg),O_DP,"dp_redble");
701: asir_assert(ARG1(arg),O_DP,"dp_redble");
702: if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
703: *rp = ONE;
704: else
705: *rp = 0;
706: }
707:
708: void Pdp_red_mod(arg,rp)
709: NODE arg;
710: LIST *rp;
711: {
712: DP h,r;
713: P dmy;
714: NODE n;
715:
1.11 noro 716: do_weyl = 0;
1.1 noro 717: asir_assert(ARG0(arg),O_DP,"dp_red_mod");
718: asir_assert(ARG1(arg),O_DP,"dp_red_mod");
719: asir_assert(ARG2(arg),O_DP,"dp_red_mod");
720: asir_assert(ARG3(arg),O_N,"dp_red_mod");
721: dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),QTOS((Q)ARG3(arg)),
722: &h,&r,&dmy);
723: NEWNODE(n); BDY(n) = (pointer)h;
724: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
725: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
726: }
1.13 noro 727:
1.1 noro 728: void Pdp_subd(arg,rp)
729: NODE arg;
730: DP *rp;
731: {
732: DP p1,p2;
733:
734: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
735: asir_assert(p1,O_DP,"dp_subd");
736: asir_assert(p2,O_DP,"dp_subd");
737: dp_subd(p1,p2,rp);
738: }
739:
1.12 noro 740: void Pdp_weyl_mul(arg,rp)
741: NODE arg;
742: DP *rp;
743: {
744: DP p1,p2;
745:
746: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
747: asir_assert(p1,O_DP,"dp_weyl_mul"); asir_assert(p2,O_DP,"dp_mul");
748: do_weyl = 1;
749: muld(CO,p1,p2,rp);
1.13 noro 750: do_weyl = 0;
751: }
752:
753: void Pdp_weyl_mul_mod(arg,rp)
754: NODE arg;
755: DP *rp;
756: {
757: DP p1,p2;
758: Q m;
759:
760: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); m = (Q)ARG2(arg);
761: asir_assert(p1,O_DP,"dp_weyl_mul_mod");
762: asir_assert(p2,O_DP,"dp_mul_mod");
763: asir_assert(m,O_N,"dp_mul_mod");
764: do_weyl = 1;
765: mulmd(CO,QTOS(m),p1,p2,rp);
1.12 noro 766: do_weyl = 0;
767: }
768:
1.1 noro 769: void Pdp_red(arg,rp)
770: NODE arg;
771: LIST *rp;
772: {
773: NODE n;
1.4 noro 774: DP head,rest,dmy1;
1.1 noro 775: P dmy;
776:
1.11 noro 777: do_weyl = 0;
1.1 noro 778: asir_assert(ARG0(arg),O_DP,"dp_red");
779: asir_assert(ARG1(arg),O_DP,"dp_red");
780: asir_assert(ARG2(arg),O_DP,"dp_red");
1.4 noro 781: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.1 noro 782: NEWNODE(n); BDY(n) = (pointer)head;
783: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
784: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
785: }
786:
1.11 noro 787: void Pdp_weyl_red(arg,rp)
788: NODE arg;
789: LIST *rp;
790: {
791: NODE n;
792: DP head,rest,dmy1;
793: P dmy;
794:
795: asir_assert(ARG0(arg),O_DP,"dp_weyl_red");
796: asir_assert(ARG1(arg),O_DP,"dp_weyl_red");
797: asir_assert(ARG2(arg),O_DP,"dp_weyl_red");
1.12 noro 798: do_weyl = 1;
1.11 noro 799: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.12 noro 800: do_weyl = 0;
1.11 noro 801: NEWNODE(n); BDY(n) = (pointer)head;
802: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
803: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
804: }
805:
1.1 noro 806: void Pdp_sp(arg,rp)
807: NODE arg;
808: DP *rp;
809: {
810: DP p1,p2;
811:
1.11 noro 812: do_weyl = 0;
1.1 noro 813: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
814: asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
815: dp_sp(p1,p2,rp);
816: }
817:
1.11 noro 818: void Pdp_weyl_sp(arg,rp)
819: NODE arg;
820: DP *rp;
821: {
822: DP p1,p2;
823:
824: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
825: asir_assert(p1,O_DP,"dp_weyl_sp"); asir_assert(p2,O_DP,"dp_sp");
1.12 noro 826: do_weyl = 1;
1.11 noro 827: dp_sp(p1,p2,rp);
1.12 noro 828: do_weyl = 0;
1.11 noro 829: }
830:
1.1 noro 831: void Pdp_sp_mod(arg,rp)
832: NODE arg;
833: DP *rp;
834: {
835: DP p1,p2;
836: int mod;
837:
1.11 noro 838: do_weyl = 0;
1.1 noro 839: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
840: asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
841: asir_assert(ARG2(arg),O_N,"dp_sp_mod");
842: mod = QTOS((Q)ARG2(arg));
843: dp_sp_mod(p1,p2,mod,rp);
844: }
845:
846: void Pdp_lcm(arg,rp)
847: NODE arg;
848: DP *rp;
849: {
850: int i,n,td;
851: DL d1,d2,d;
852: MP m;
853: DP p1,p2;
854:
855: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
856: asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
857: n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
858: NEWDL(d,n);
859: for ( i = 0, td = 0; i < n; i++ ) {
860: d->d[i] = MAX(d1->d[i],d2->d[i]); td += d->d[i];
861: }
862: d->td = td;
863: NEWMP(m); m->dl = d; m->c = (P)ONE; NEXT(m) = 0;
864: MKDP(n,m,*rp); (*rp)->sugar = td; /* XXX */
865: }
866:
867: void Pdp_hm(arg,rp)
868: NODE arg;
869: DP *rp;
870: {
871: DP p;
872:
873: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
874: dp_hm(p,rp);
875: }
876:
877: void Pdp_ht(arg,rp)
878: NODE arg;
879: DP *rp;
880: {
881: DP p;
882: MP m,mr;
883:
884: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
885: if ( !p )
886: *rp = 0;
887: else {
888: m = BDY(p);
889: NEWMP(mr); mr->dl = m->dl; mr->c = (P)ONE; NEXT(mr) = 0;
890: MKDP(p->nv,mr,*rp); (*rp)->sugar = mr->dl->td; /* XXX */
891: }
892: }
893:
894: void Pdp_hc(arg,rp)
895: NODE arg;
896: P *rp;
897: {
898: asir_assert(ARG0(arg),O_DP,"dp_hc");
899: if ( !ARG0(arg) )
900: *rp = 0;
901: else
902: *rp = BDY((DP)ARG0(arg))->c;
903: }
904:
905: void Pdp_rest(arg,rp)
906: NODE arg;
907: DP *rp;
908: {
909: asir_assert(ARG0(arg),O_DP,"dp_rest");
910: if ( !ARG0(arg) )
911: *rp = 0;
912: else
913: dp_rest((DP)ARG0(arg),rp);
914: }
915:
916: void Pdp_td(arg,rp)
917: NODE arg;
918: Q *rp;
919: {
920: DP p;
921:
922: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
923: if ( !p )
924: *rp = 0;
925: else
926: STOQ(BDY(p)->dl->td,*rp);
927: }
928:
929: void Pdp_sugar(arg,rp)
930: NODE arg;
931: Q *rp;
932: {
933: DP p;
934:
935: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
936: if ( !p )
937: *rp = 0;
938: else
939: STOQ(p->sugar,*rp);
940: }
941:
942: void Pdp_cri1(arg,rp)
943: NODE arg;
944: Q *rp;
945: {
946: DP p1,p2;
947: int *d1,*d2;
948: int i,n;
949:
950: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
951: asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
952: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
953: for ( i = 0; i < n; i++ )
954: if ( d1[i] > d2[i] )
955: break;
956: *rp = i == n ? ONE : 0;
957: }
958:
959: void Pdp_cri2(arg,rp)
960: NODE arg;
961: Q *rp;
962: {
963: DP p1,p2;
964: int *d1,*d2;
965: int i,n;
966:
967: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
968: asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
969: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
970: for ( i = 0; i < n; i++ )
971: if ( MIN(d1[i],d2[i]) >= 1 )
972: break;
973: *rp = i == n ? ONE : 0;
974: }
975:
976: void Pdp_minp(arg,rp)
977: NODE arg;
978: LIST *rp;
979: {
980: NODE tn,tn1,d,dd,dd0,p,tp;
981: LIST l,minp;
982: DP lcm,tlcm;
983: int s,ts;
984:
985: asir_assert(ARG0(arg),O_LIST,"dp_minp");
986: d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
987: p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
988: if ( !ARG1(arg) ) {
989: s = QTOS((Q)BDY(p)); p = NEXT(p);
990: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
991: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
992: tlcm = (DP)BDY(tp); tp = NEXT(tp);
993: ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
994: NEXTNODE(dd0,dd);
995: if ( ts < s ) {
996: BDY(dd) = (pointer)minp;
997: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
998: } else if ( ts == s ) {
999: if ( compd(CO,lcm,tlcm) > 0 ) {
1000: BDY(dd) = (pointer)minp;
1001: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1002: } else
1003: BDY(dd) = BDY(d);
1004: } else
1005: BDY(dd) = BDY(d);
1006: }
1007: } else {
1008: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1009: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1010: tlcm = (DP)BDY(tp);
1011: NEXTNODE(dd0,dd);
1012: if ( compd(CO,lcm,tlcm) > 0 ) {
1013: BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
1014: } else
1015: BDY(dd) = BDY(d);
1016: }
1017: }
1018: if ( dd0 )
1019: NEXT(dd) = 0;
1020: MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
1021: }
1022:
1023: void Pdp_criB(arg,rp)
1024: NODE arg;
1025: LIST *rp;
1026: {
1027: NODE d,ij,dd,ddd;
1028: int i,j,s,n;
1029: DP *ps;
1030: DL ts,ti,tj,lij,tdl;
1031:
1032: asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
1033: asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
1034: asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
1035: if ( !d )
1036: *rp = (LIST)ARG0(arg);
1037: else {
1038: ts = BDY(ps[s])->dl;
1039: n = ps[s]->nv;
1040: NEWDL(tdl,n);
1041: for ( dd = 0; d; d = NEXT(d) ) {
1042: ij = BDY((LIST)BDY(d));
1043: i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1044: j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1045: lij = BDY((DP)BDY(ij))->dl;
1046: ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
1047: if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
1048: || !dl_equal(n,lij,tdl)
1049: || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
1050: && dl_equal(n,tdl,lij))
1051: || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
1052: && dl_equal(n,tdl,lij)) ) {
1053: MKNODE(ddd,BDY(d),dd);
1054: dd = ddd;
1055: }
1056: }
1057: MKLIST(*rp,dd);
1058: }
1059: }
1060:
1061: void Pdp_nelim(arg,rp)
1062: NODE arg;
1063: Q *rp;
1064: {
1065: if ( arg ) {
1066: asir_assert(ARG0(arg),O_N,"dp_nelim");
1067: dp_nelim = QTOS((Q)ARG0(arg));
1068: }
1069: STOQ(dp_nelim,*rp);
1070: }
1071:
1072: void Pdp_mag(arg,rp)
1073: NODE arg;
1074: Q *rp;
1075: {
1076: DP p;
1077: int s;
1078: MP m;
1079:
1080: p = (DP)ARG0(arg);
1081: asir_assert(p,O_DP,"dp_mag");
1082: if ( !p )
1083: *rp = 0;
1084: else {
1085: for ( s = 0, m = BDY(p); m; m = NEXT(m) )
1086: s += p_mag(m->c);
1087: STOQ(s,*rp);
1088: }
1089: }
1090:
1091: extern int kara_mag;
1092:
1093: void Pdp_set_kara(arg,rp)
1094: NODE arg;
1095: Q *rp;
1096: {
1097: if ( arg ) {
1098: asir_assert(ARG0(arg),O_N,"dp_set_kara");
1099: kara_mag = QTOS((Q)ARG0(arg));
1100: }
1101: STOQ(kara_mag,*rp);
1102: }
1103:
1104: void Pdp_homo(arg,rp)
1105: NODE arg;
1106: DP *rp;
1107: {
1108: asir_assert(ARG0(arg),O_DP,"dp_homo");
1109: dp_homo((DP)ARG0(arg),rp);
1110: }
1111:
1.8 noro 1112: void Pdp_dehomo(arg,rp)
1113: NODE arg;
1.1 noro 1114: DP *rp;
1115: {
1.8 noro 1116: asir_assert(ARG0(arg),O_DP,"dp_dehomo");
1117: dp_dehomo((DP)ARG0(arg),rp);
1118: }
1119:
1120: void Pdp_gr_flags(arg,rp)
1121: NODE arg;
1122: LIST *rp;
1123: {
1124: Obj name,value;
1125: NODE n;
1.1 noro 1126:
1.8 noro 1127: if ( arg ) {
1128: asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
1129: n = BDY((LIST)ARG0(arg));
1130: while ( n ) {
1131: name = (Obj)BDY(n); n = NEXT(n);
1132: if ( !n )
1133: break;
1134: else {
1135: value = (Obj)BDY(n); n = NEXT(n);
1136: }
1137: dp_set_flag(name,value);
1.1 noro 1138: }
1139: }
1.8 noro 1140: dp_make_flaglist(rp);
1141: }
1142:
1143: extern int DP_Print;
1144:
1145: void Pdp_gr_print(arg,rp)
1146: NODE arg;
1147: Q *rp;
1148: {
1149: Q q;
1150:
1151: if ( arg ) {
1152: asir_assert(ARG0(arg),O_N,"dp_gr_print");
1153: q = (Q)ARG0(arg); DP_Print = QTOS(q);
1154: } else
1155: STOQ(DP_Print,q);
1156: *rp = q;
1.1 noro 1157: }
1158:
1.8 noro 1159: void Pdp_gr_main(arg,rp)
1.1 noro 1160: NODE arg;
1.8 noro 1161: LIST *rp;
1.1 noro 1162: {
1.8 noro 1163: LIST f,v;
1164: Num homo;
1165: Q m;
1166: int modular;
1167: struct order_spec ord;
1168:
1.11 noro 1169: do_weyl = 0;
1.8 noro 1170: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1171: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
1172: asir_assert(ARG2(arg),O_N,"dp_gr_main");
1173: asir_assert(ARG3(arg),O_N,"dp_gr_main");
1174: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1175: homo = (Num)ARG2(arg);
1176: m = (Q)ARG3(arg);
1177: if ( !m )
1178: modular = 0;
1179: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1180: error("dp_gr_main : too large modulus");
1181: else
1182: modular = QTOS(m);
1183: create_order_spec(ARG4(arg),&ord);
1184: dp_gr_main(f,v,homo,modular,&ord,rp);
1.1 noro 1185: }
1186:
1.8 noro 1187: void Pdp_f4_main(arg,rp)
1188: NODE arg;
1189: LIST *rp;
1.1 noro 1190: {
1.8 noro 1191: LIST f,v;
1192: struct order_spec ord;
1.1 noro 1193:
1.11 noro 1194: do_weyl = 0;
1.8 noro 1195: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1196: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1197: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1198: create_order_spec(ARG2(arg),&ord);
1199: dp_f4_main(f,v,&ord,rp);
1.1 noro 1200: }
1201:
1.8 noro 1202: void Pdp_f4_mod_main(arg,rp)
1203: NODE arg;
1204: LIST *rp;
1.1 noro 1205: {
1.8 noro 1206: LIST f,v;
1207: int m;
1208: struct order_spec ord;
1209:
1.11 noro 1210: do_weyl = 0;
1.8 noro 1211: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
1212: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
1213: asir_assert(ARG2(arg),O_N,"dp_f4_main");
1214: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1215: create_order_spec(ARG3(arg),&ord);
1216: dp_f4_mod_main(f,v,m,&ord,rp);
1217: }
1.1 noro 1218:
1.8 noro 1219: void Pdp_gr_mod_main(arg,rp)
1220: NODE arg;
1221: LIST *rp;
1222: {
1223: LIST f,v;
1224: Num homo;
1225: int m;
1226: struct order_spec ord;
1227:
1.11 noro 1228: do_weyl = 0;
1.8 noro 1229: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
1230: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
1231: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
1232: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1.11 noro 1233: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1234: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1235: create_order_spec(ARG4(arg),&ord);
1236: dp_gr_mod_main(f,v,homo,m,&ord,rp);
1237: }
1238:
1239: /* for Weyl algebra */
1240:
1241: void Pdp_weyl_gr_main(arg,rp)
1242: NODE arg;
1243: LIST *rp;
1244: {
1245: LIST f,v;
1246: Num homo;
1247: Q m;
1248: int modular;
1249: struct order_spec ord;
1250:
1251: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1252: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
1253: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
1254: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
1255: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1256: homo = (Num)ARG2(arg);
1257: m = (Q)ARG3(arg);
1258: if ( !m )
1259: modular = 0;
1260: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1261: error("dp_gr_main : too large modulus");
1262: else
1263: modular = QTOS(m);
1264: create_order_spec(ARG4(arg),&ord);
1.12 noro 1265: do_weyl = 1;
1.11 noro 1266: dp_gr_main(f,v,homo,modular,&ord,rp);
1.12 noro 1267: do_weyl = 0;
1.11 noro 1268: }
1269:
1270: void Pdp_weyl_f4_main(arg,rp)
1271: NODE arg;
1272: LIST *rp;
1273: {
1274: LIST f,v;
1275: struct order_spec ord;
1276:
1277: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1278: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1279: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1280: create_order_spec(ARG2(arg),&ord);
1.12 noro 1281: do_weyl = 1;
1.11 noro 1282: dp_f4_main(f,v,&ord,rp);
1.12 noro 1283: do_weyl = 0;
1.11 noro 1284: }
1285:
1286: void Pdp_weyl_f4_mod_main(arg,rp)
1287: NODE arg;
1288: LIST *rp;
1289: {
1290: LIST f,v;
1291: int m;
1292: struct order_spec ord;
1293:
1294: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
1295: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
1296: asir_assert(ARG2(arg),O_N,"dp_f4_main");
1297: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1298: create_order_spec(ARG3(arg),&ord);
1.12 noro 1299: do_weyl = 1;
1.11 noro 1300: dp_f4_mod_main(f,v,m,&ord,rp);
1.12 noro 1301: do_weyl = 0;
1.11 noro 1302: }
1303:
1304: void Pdp_weyl_gr_mod_main(arg,rp)
1305: NODE arg;
1306: LIST *rp;
1307: {
1308: LIST f,v;
1309: Num homo;
1310: int m;
1311: struct order_spec ord;
1312:
1313: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
1314: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
1315: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
1316: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
1.8 noro 1317: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1318: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1319: create_order_spec(ARG4(arg),&ord);
1.12 noro 1320: do_weyl = 1;
1.8 noro 1321: dp_gr_mod_main(f,v,homo,m,&ord,rp);
1.12 noro 1322: do_weyl = 0;
1.1 noro 1323: }
1.8 noro 1324:
1.15 ! noro 1325: static VECT current_weight_vector_obj;
! 1326: int *current_weight_vector;
! 1327:
! 1328: void Pdp_weyl_set_weight(arg,rp)
! 1329: NODE arg;
! 1330: VECT *rp;
! 1331: {
! 1332: VECT v;
! 1333: int i,n;
! 1334:
! 1335: if ( !arg )
! 1336: *rp = current_weight_vector_obj;
! 1337: else {
! 1338: asir_assert(ARG0(arg),O_VECT,"dp_weyl_set_weight");
! 1339: v = (VECT)ARG0(arg);
! 1340: current_weight_vector_obj = v;
! 1341: n = v->len;
! 1342: current_weight_vector = (int *)CALLOC(n,sizeof(int));
! 1343: for ( i = 0; i < n; i++ )
! 1344: current_weight_vector[i] = QTOS((Q)v->body[i]);
! 1345: *rp = v;
! 1346: }
! 1347: }
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