Annotation of OpenXM_contrib2/asir2000/builtin/dp.c, Revision 1.83
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
1.68 noro 9: * conditions of this Agreement. For the avoidance of doubt, you acquire * only a limited right to use the SOFTWARE hereunder, and FLL or any
1.5 noro 10: * third party developer retains all rights, including but not limited to
11: * copyrights, in and to the SOFTWARE.
12: *
13: * (1) FLL does not grant you a license in any way for commercial
14: * purposes. You may use the SOFTWARE only for non-commercial and
15: * non-profit purposes only, such as academic, research and internal
16: * business use.
17: * (2) The SOFTWARE is protected by the Copyright Law of Japan and
18: * international copyright treaties. If you make copies of the SOFTWARE,
19: * with or without modification, as permitted hereunder, you shall affix
20: * to all such copies of the SOFTWARE the above copyright notice.
21: * (3) An explicit reference to this SOFTWARE and its copyright owner
22: * shall be made on your publication or presentation in any form of the
23: * results obtained by use of the SOFTWARE.
24: * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.6 noro 25: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.5 noro 26: * for such modification or the source code of the modified part of the
27: * SOFTWARE.
28: *
29: * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
30: * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
31: * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
32: * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
33: * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
34: * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
35: * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
36: * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
37: * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
38: * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
39: * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
40: * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
41: * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
42: * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
43: * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
44: * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
45: * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
46: *
1.83 ! noro 47: * $OpenXM: OpenXM_contrib2/asir2000/builtin/dp.c,v 1.82 2010/05/01 02:17:49 noro Exp $
1.5 noro 48: */
1.1 noro 49: #include "ca.h"
50: #include "base.h"
51: #include "parse.h"
52:
1.61 noro 53: extern int dp_fcoeffs;
1.8 noro 54: extern int dp_nelim;
55: extern int dp_order_pair_length;
56: extern struct order_pair *dp_order_pair;
1.46 noro 57: extern struct order_spec *dp_current_spec;
1.52 noro 58: extern struct modorder_spec *dp_current_modspec;
1.8 noro 59:
1.11 noro 60: int do_weyl;
1.1 noro 61:
1.44 noro 62: void Pdp_sort();
1.32 noro 63: void Pdp_mul_trunc(),Pdp_quo();
1.64 noro 64: void Pdp_ord(), Pdp_ptod(), Pdp_dtop(), Phomogenize();
1.1 noro 65: void Pdp_ptozp(), Pdp_ptozp2(), Pdp_red(), Pdp_red2(), Pdp_lcm(), Pdp_redble();
66: void Pdp_sp(), Pdp_hm(), Pdp_ht(), Pdp_hc(), Pdp_rest(), Pdp_td(), Pdp_sugar();
1.30 ohara 67: void Pdp_set_sugar();
1.1 noro 68: void Pdp_cri1(),Pdp_cri2(),Pdp_subd(),Pdp_mod(),Pdp_red_mod(),Pdp_tdiv();
69: void Pdp_prim(),Pdp_red_coef(),Pdp_mag(),Pdp_set_kara(),Pdp_rat();
1.70 noro 70: void Pdp_nf(),Pdp_true_nf(),Pdp_true_nf_marked(),Pdp_true_nf_marked_mod();
1.79 noro 71: void Pdp_true_nf_and_quotient_marked(),Pdp_true_nf_and_quotient_marked_mod();
1.1 noro 72: void Pdp_nf_mod(),Pdp_true_nf_mod();
73: void Pdp_criB(),Pdp_nelim();
1.9 noro 74: void Pdp_minp(),Pdp_sp_mod();
1.1 noro 75: void Pdp_homo(),Pdp_dehomo();
1.16 noro 76: void Pdp_gr_mod_main(),Pdp_gr_f_main();
1.1 noro 77: void Pdp_gr_main(),Pdp_gr_hm_main(),Pdp_gr_d_main(),Pdp_gr_flags();
1.63 noro 78: void Pdp_interreduce();
1.16 noro 79: void Pdp_f4_main(),Pdp_f4_mod_main(),Pdp_f4_f_main();
1.1 noro 80: void Pdp_gr_print();
1.28 noro 81: void Pdp_mbase(),Pdp_lnf_mod(),Pdp_nf_tab_mod(),Pdp_mdtod(), Pdp_nf_tab_f();
1.8 noro 82: void Pdp_vtoe(), Pdp_etov(), Pdp_dtov(), Pdp_idiv(), Pdp_sep();
83: void Pdp_cont();
1.22 noro 84: void Pdp_gr_checklist();
1.52 noro 85: void Pdp_ltod(),Pdpv_ord(),Pdpv_ht(),Pdpv_hm(),Pdpv_hc();
1.1 noro 86:
1.13 noro 87: void Pdp_weyl_red();
88: void Pdp_weyl_sp();
89: void Pdp_weyl_nf(),Pdp_weyl_nf_mod();
1.16 noro 90: void Pdp_weyl_gr_main(),Pdp_weyl_gr_mod_main(),Pdp_weyl_gr_f_main();
91: void Pdp_weyl_f4_main(),Pdp_weyl_f4_mod_main(),Pdp_weyl_f4_f_main();
1.13 noro 92: void Pdp_weyl_mul(),Pdp_weyl_mul_mod();
1.15 noro 93: void Pdp_weyl_set_weight();
1.77 noro 94: void Pdp_set_weight(),Pdp_set_top_weight(),Pdp_set_module_weight();
1.16 noro 95: void Pdp_nf_f(),Pdp_weyl_nf_f();
96: void Pdp_lnf_f();
1.62 noro 97: void Pnd_gr(),Pnd_gr_trace(),Pnd_f4(),Pnd_f4_trace();
1.75 noro 98: void Pnd_gr_postproc(), Pnd_weyl_gr_postproc();
1.38 noro 99: void Pnd_weyl_gr(),Pnd_weyl_gr_trace();
1.83 ! noro 100: void Pnd_nf(),Pnd_weyl_nf();
1.49 noro 101: void Pdp_initial_term();
102: void Pdp_order();
1.66 noro 103: void Pdp_inv_or_split();
1.74 noro 104: void Pdp_compute_last_t();
1.68 noro 105: void Pdp_compute_last_w();
1.70 noro 106: void Pdp_compute_essential_df();
1.72 noro 107: void Pdp_get_denomlist();
1.80 noro 108: void Pdp_symb_add();
1.82 noro 109: void Pdp_mono_raddec();
1.49 noro 110:
111: LIST dp_initial_term();
112: LIST dp_order();
113: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
114: int *modular,struct order_spec **ord);
1.11 noro 115:
1.25 noro 116: LIST remove_zero_from_list(LIST);
117:
1.1 noro 118: struct ftab dp_tab[] = {
1.8 noro 119: /* content reduction */
1.1 noro 120: {"dp_ptozp",Pdp_ptozp,1},
121: {"dp_ptozp2",Pdp_ptozp2,2},
122: {"dp_prim",Pdp_prim,1},
1.8 noro 123: {"dp_red_coef",Pdp_red_coef,2},
124: {"dp_cont",Pdp_cont,1},
125:
1.11 noro 126: /* polynomial ring */
1.32 noro 127: /* special operations */
128: {"dp_mul_trunc",Pdp_mul_trunc,3},
129: {"dp_quo",Pdp_quo,2},
130:
1.8 noro 131: /* s-poly */
132: {"dp_sp",Pdp_sp,2},
133: {"dp_sp_mod",Pdp_sp_mod,3},
134:
135: /* m-reduction */
1.1 noro 136: {"dp_red",Pdp_red,3},
137: {"dp_red_mod",Pdp_red_mod,4},
1.8 noro 138:
139: /* normal form */
1.1 noro 140: {"dp_nf",Pdp_nf,4},
1.16 noro 141: {"dp_nf_f",Pdp_nf_f,4},
1.1 noro 142: {"dp_true_nf",Pdp_true_nf,4},
1.67 noro 143: {"dp_true_nf_marked",Pdp_true_nf_marked,4},
1.73 noro 144: {"dp_true_nf_and_quotient_marked",Pdp_true_nf_and_quotient_marked,4},
1.79 noro 145: {"dp_true_nf_and_quotient_marked_mod",Pdp_true_nf_and_quotient_marked_mod,5},
1.70 noro 146: {"dp_true_nf_marked_mod",Pdp_true_nf_marked_mod,5},
1.1 noro 147: {"dp_nf_mod",Pdp_nf_mod,5},
148: {"dp_true_nf_mod",Pdp_true_nf_mod,5},
1.8 noro 149: {"dp_lnf_mod",Pdp_lnf_mod,3},
1.28 noro 150: {"dp_nf_tab_f",Pdp_nf_tab_f,2},
1.8 noro 151: {"dp_nf_tab_mod",Pdp_nf_tab_mod,3},
1.16 noro 152: {"dp_lnf_f",Pdp_lnf_f,2},
1.8 noro 153:
154: /* Buchberger algorithm */
1.46 noro 155: {"dp_gr_main",Pdp_gr_main,-5},
1.63 noro 156: {"dp_interreduce",Pdp_interreduce,3},
1.1 noro 157: {"dp_gr_mod_main",Pdp_gr_mod_main,5},
1.27 noro 158: {"dp_gr_f_main",Pdp_gr_f_main,4},
1.23 noro 159: {"dp_gr_checklist",Pdp_gr_checklist,2},
1.40 noro 160: {"nd_f4",Pnd_f4,4},
1.33 noro 161: {"nd_gr",Pnd_gr,4},
1.36 noro 162: {"nd_gr_trace",Pnd_gr_trace,5},
1.62 noro 163: {"nd_f4_trace",Pnd_f4_trace,5},
1.58 noro 164: {"nd_gr_postproc",Pnd_gr_postproc,5},
1.75 noro 165: {"nd_weyl_gr_postproc",Pnd_weyl_gr_postproc,5},
1.38 noro 166: {"nd_weyl_gr",Pnd_weyl_gr,4},
167: {"nd_weyl_gr_trace",Pnd_weyl_gr_trace,5},
1.39 noro 168: {"nd_nf",Pnd_nf,5},
1.83 ! noro 169: {"nd_weyl_nf",Pnd_weyl_nf,5},
1.8 noro 170:
171: /* F4 algorithm */
1.1 noro 172: {"dp_f4_main",Pdp_f4_main,3},
173: {"dp_f4_mod_main",Pdp_f4_mod_main,4},
1.8 noro 174:
1.11 noro 175: /* weyl algebra */
1.12 noro 176: /* multiplication */
177: {"dp_weyl_mul",Pdp_weyl_mul,2},
1.13 noro 178: {"dp_weyl_mul_mod",Pdp_weyl_mul_mod,3},
1.12 noro 179:
1.11 noro 180: /* s-poly */
181: {"dp_weyl_sp",Pdp_weyl_sp,2},
182:
183: /* m-reduction */
184: {"dp_weyl_red",Pdp_weyl_red,3},
185:
186: /* normal form */
187: {"dp_weyl_nf",Pdp_weyl_nf,4},
1.13 noro 188: {"dp_weyl_nf_mod",Pdp_weyl_nf_mod,5},
1.16 noro 189: {"dp_weyl_nf_f",Pdp_weyl_nf_f,4},
1.11 noro 190:
191: /* Buchberger algorithm */
1.50 noro 192: {"dp_weyl_gr_main",Pdp_weyl_gr_main,-5},
1.11 noro 193: {"dp_weyl_gr_mod_main",Pdp_weyl_gr_mod_main,5},
1.16 noro 194: {"dp_weyl_gr_f_main",Pdp_weyl_gr_f_main,4},
1.11 noro 195:
196: /* F4 algorithm */
197: {"dp_weyl_f4_main",Pdp_weyl_f4_main,3},
1.19 noro 198: {"dp_weyl_f4_mod_main",Pdp_weyl_f4_mod_main,4},
1.11 noro 199:
1.15 noro 200: /* misc */
1.66 noro 201: {"dp_inv_or_split",Pdp_inv_or_split,3},
1.24 noro 202: {"dp_set_weight",Pdp_set_weight,-1},
1.77 noro 203: {"dp_set_module_weight",Pdp_set_module_weight,-1},
1.71 noro 204: {"dp_set_top_weight",Pdp_set_top_weight,-1},
1.15 noro 205: {"dp_weyl_set_weight",Pdp_weyl_set_weight,-1},
1.72 noro 206:
207: {"dp_get_denomlist",Pdp_get_denomlist,0},
1.8 noro 208: {0,0,0},
209: };
210:
211: struct ftab dp_supp_tab[] = {
212: /* setting flags */
1.44 noro 213: {"dp_sort",Pdp_sort,1},
1.8 noro 214: {"dp_ord",Pdp_ord,-1},
1.52 noro 215: {"dpv_ord",Pdpv_ord,-2},
1.8 noro 216: {"dp_set_kara",Pdp_set_kara,-1},
217: {"dp_nelim",Pdp_nelim,-1},
1.1 noro 218: {"dp_gr_flags",Pdp_gr_flags,-1},
219: {"dp_gr_print",Pdp_gr_print,-1},
1.8 noro 220:
221: /* converters */
1.64 noro 222: {"homogenize",Phomogenize,3},
1.53 noro 223: {"dp_ptod",Pdp_ptod,-2},
1.8 noro 224: {"dp_dtop",Pdp_dtop,2},
225: {"dp_homo",Pdp_homo,1},
226: {"dp_dehomo",Pdp_dehomo,1},
227: {"dp_etov",Pdp_etov,1},
228: {"dp_vtoe",Pdp_vtoe,1},
229: {"dp_dtov",Pdp_dtov,1},
230: {"dp_mdtod",Pdp_mdtod,1},
231: {"dp_mod",Pdp_mod,3},
232: {"dp_rat",Pdp_rat,1},
1.53 noro 233: {"dp_ltod",Pdp_ltod,-2},
1.8 noro 234:
235: /* criteria */
236: {"dp_cri1",Pdp_cri1,2},
237: {"dp_cri2",Pdp_cri2,2},
238: {"dp_criB",Pdp_criB,3},
239:
240: /* simple operation */
241: {"dp_subd",Pdp_subd,2},
242: {"dp_lcm",Pdp_lcm,2},
243: {"dp_hm",Pdp_hm,1},
244: {"dp_ht",Pdp_ht,1},
245: {"dp_hc",Pdp_hc,1},
1.52 noro 246: {"dpv_hm",Pdpv_hm,1},
247: {"dpv_ht",Pdpv_ht,1},
248: {"dpv_hc",Pdpv_hc,1},
1.8 noro 249: {"dp_rest",Pdp_rest,1},
1.49 noro 250: {"dp_initial_term",Pdp_initial_term,1},
251: {"dp_order",Pdp_order,1},
1.80 noro 252: {"dp_symb_add",Pdp_symb_add,2},
1.8 noro 253:
254: /* degree and size */
255: {"dp_td",Pdp_td,1},
256: {"dp_mag",Pdp_mag,1},
257: {"dp_sugar",Pdp_sugar,1},
1.30 ohara 258: {"dp_set_sugar",Pdp_set_sugar,2},
1.8 noro 259:
260: /* misc */
261: {"dp_mbase",Pdp_mbase,1},
262: {"dp_redble",Pdp_redble,2},
263: {"dp_sep",Pdp_sep,2},
264: {"dp_idiv",Pdp_idiv,2},
265: {"dp_tdiv",Pdp_tdiv,2},
266: {"dp_minp",Pdp_minp,2},
1.68 noro 267: {"dp_compute_last_w",Pdp_compute_last_w,5},
1.74 noro 268: {"dp_compute_last_t",Pdp_compute_last_t,5},
1.70 noro 269: {"dp_compute_essential_df",Pdp_compute_essential_df,2},
1.82 noro 270: {"dp_mono_raddec",Pdp_mono_raddec,2},
1.8 noro 271:
272: {0,0,0}
1.1 noro 273: };
1.44 noro 274:
1.68 noro 275: NODE compute_last_w(NODE g,NODE gh,int n,int **v,int row1,int **m1,int row2,int **m2);
1.74 noro 276: Q compute_last_t(NODE g,NODE gh,Q t,VECT w1,VECT w2,NODE *homo,VECT *wp);
277:
278: void Pdp_compute_last_t(NODE arg,LIST *rp)
279: {
280: NODE g,gh,homo,n;
281: LIST hlist;
282: VECT v1,v2,w;
283: Q t;
284:
285: g = (NODE)BDY((LIST)ARG0(arg));
286: gh = (NODE)BDY((LIST)ARG1(arg));
287: t = (Q)ARG2(arg);
288: v1 = (VECT)ARG3(arg);
289: v2 = (VECT)ARG4(arg);
290: t = compute_last_t(g,gh,t,v1,v2,&homo,&w);
291: MKLIST(hlist,homo);
292: n = mknode(3,t,w,hlist);
293: MKLIST(*rp,n);
294: }
1.68 noro 295:
296: void Pdp_compute_last_w(NODE arg,LIST *rp)
297: {
298: NODE g,gh,r;
299: VECT w,rv;
300: LIST l;
301: MAT w1,w2;
302: int row1,row2,i,j,n;
303: int *v;
304: int **m1,**m2;
305: Q q;
306:
307: g = (NODE)BDY((LIST)ARG0(arg));
308: gh = (NODE)BDY((LIST)ARG1(arg));
309: w = (VECT)ARG2(arg);
310: w1 = (MAT)ARG3(arg);
311: w2 = (MAT)ARG4(arg);
312: n = w1->col;
313: row1 = w1->row;
314: row2 = w2->row;
315: if ( w ) {
316: v = W_ALLOC(n);
317: for ( i = 0; i < n; i++ ) v[i] = QTOS((Q)w->body[i]);
318: } else v = 0;
319: m1 = almat(row1,n);
320: for ( i = 0; i < row1; i++ )
321: for ( j = 0; j < n; j++ ) m1[i][j] = QTOS((Q)w1->body[i][j]);
322: m2 = almat(row2,n);
323: for ( i = 0; i < row2; i++ )
324: for ( j = 0; j < n; j++ ) m2[i][j] = QTOS((Q)w2->body[i][j]);
325: r = compute_last_w(g,gh,n,&v,row1,m1,row2,m2);
326: if ( !r ) *rp = 0;
327: else {
328: MKVECT(rv,n);
329: for ( i = 0; i < n; i++ ) {
330: STOQ(v[i],q); rv->body[i] = (pointer)q;
331: }
332: MKLIST(l,r);
333: r = mknode(2,rv,l);
334: MKLIST(*rp,r);
335: }
336: }
337:
1.70 noro 338: NODE compute_essential_df(DP *g,DP *gh,int n);
339:
340: void Pdp_compute_essential_df(NODE arg,LIST *rp)
341: {
342: VECT g,gh;
343: NODE r;
344:
345: g = (VECT)ARG0(arg);
346: gh = (VECT)ARG1(arg);
347: r = (NODE)compute_essential_df((DP *)BDY(g),(DP *)BDY(gh),g->len);
348: MKLIST(*rp,r);
349: }
350:
1.66 noro 351: void Pdp_inv_or_split(arg,rp)
352: NODE arg;
353: Obj *rp;
354: {
355: NODE gb,newgb;
356: DP f,inv;
357: struct order_spec *spec;
358: LIST list;
359:
360: do_weyl = 0; dp_fcoeffs = 0;
361: asir_assert(ARG0(arg),O_LIST,"dp_inv_or_split");
362: asir_assert(ARG1(arg),O_DP,"dp_inv_or_split");
363: if ( !create_order_spec(0,(Obj)ARG2(arg),&spec) )
364: error("dp_inv_or_split : invalid order specification");
365: gb = BDY((LIST)ARG0(arg));
366: f = (DP)ARG1(arg);
367: newgb = (NODE)dp_inv_or_split(gb,f,spec,&inv);
368: if ( !newgb ) {
369: /* invertible */
370: *rp = (Obj)inv;
371: } else {
372: MKLIST(list,newgb);
373: *rp = (Obj)list;
374: }
375: }
376:
1.44 noro 377: void Pdp_sort(arg,rp)
378: NODE arg;
379: DP *rp;
380: {
381: dp_sort((DP)ARG0(arg),rp);
382: }
1.1 noro 383:
1.8 noro 384: void Pdp_mdtod(arg,rp)
385: NODE arg;
386: DP *rp;
387: {
388: MP m,mr,mr0;
389: DP p;
390: P t;
391:
392: p = (DP)ARG0(arg);
393: if ( !p )
394: *rp = 0;
395: else {
396: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
397: mptop(m->c,&t); NEXTMP(mr0,mr); mr->c = t; mr->dl = m->dl;
398: }
399: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
400: }
401: }
402:
403: void Pdp_sep(arg,rp)
404: NODE arg;
405: VECT *rp;
406: {
407: DP p,r;
408: MP m,t;
409: MP *w0,*w;
410: int i,n,d,nv,sugar;
411: VECT v;
412: pointer *pv;
413:
414: p = (DP)ARG0(arg); m = BDY(p);
415: d = QTOS((Q)ARG1(arg));
416: for ( t = m, n = 0; t; t = NEXT(t), n++ );
417: if ( d > n )
418: d = n;
419: MKVECT(v,d); *rp = v;
420: pv = BDY(v); nv = p->nv; sugar = p->sugar;
421: w0 = (MP *)MALLOC(d*sizeof(MP)); bzero(w0,d*sizeof(MP));
422: w = (MP *)MALLOC(d*sizeof(MP)); bzero(w,d*sizeof(MP));
423: for ( t = BDY(p), i = 0; t; t = NEXT(t), i++, i %= d ) {
424: NEXTMP(w0[i],w[i]); w[i]->c = t->c; w[i]->dl = t->dl;
425: }
426: for ( i = 0; i < d; i++ ) {
427: NEXT(w[i]) = 0; MKDP(nv,w0[i],r); r->sugar = sugar;
428: pv[i] = (pointer)r;
429: }
430: }
431:
432: void Pdp_idiv(arg,rp)
433: NODE arg;
434: DP *rp;
435: {
436: dp_idiv((DP)ARG0(arg),(Q)ARG1(arg),rp);
437: }
438:
439: void Pdp_cont(arg,rp)
440: NODE arg;
441: Q *rp;
442: {
443: dp_cont((DP)ARG0(arg),rp);
444: }
445:
446: void Pdp_dtov(arg,rp)
447: NODE arg;
448: VECT *rp;
449: {
450: dp_dtov((DP)ARG0(arg),rp);
451: }
452:
453: void Pdp_mbase(arg,rp)
454: NODE arg;
455: LIST *rp;
456: {
457: NODE mb;
458:
459: asir_assert(ARG0(arg),O_LIST,"dp_mbase");
460: dp_mbase(BDY((LIST)ARG0(arg)),&mb);
461: MKLIST(*rp,mb);
462: }
463:
464: void Pdp_etov(arg,rp)
465: NODE arg;
466: VECT *rp;
467: {
468: DP dp;
469: int n,i;
470: int *d;
471: VECT v;
472: Q t;
473:
474: dp = (DP)ARG0(arg);
475: asir_assert(dp,O_DP,"dp_etov");
476: n = dp->nv; d = BDY(dp)->dl->d;
477: MKVECT(v,n);
478: for ( i = 0; i < n; i++ ) {
479: STOQ(d[i],t); v->body[i] = (pointer)t;
480: }
481: *rp = v;
482: }
483:
484: void Pdp_vtoe(arg,rp)
485: NODE arg;
486: DP *rp;
487: {
488: DP dp;
489: DL dl;
490: MP m;
491: int n,i,td;
492: int *d;
493: VECT v;
494:
495: v = (VECT)ARG0(arg);
496: asir_assert(v,O_VECT,"dp_vtoe");
497: n = v->len;
498: NEWDL(dl,n); d = dl->d;
499: for ( i = 0, td = 0; i < n; i++ ) {
1.24 noro 500: d[i] = QTOS((Q)(v->body[i])); td += MUL_WEIGHT(d[i],i);
1.8 noro 501: }
502: dl->td = td;
503: NEWMP(m); m->dl = dl; m->c = (P)ONE; NEXT(m) = 0;
504: MKDP(n,m,dp); dp->sugar = td;
505: *rp = dp;
506: }
507:
508: void Pdp_lnf_mod(arg,rp)
509: NODE arg;
510: LIST *rp;
511: {
512: DP r1,r2;
513: NODE b,g,n;
514: int mod;
515:
516: asir_assert(ARG0(arg),O_LIST,"dp_lnf_mod");
517: asir_assert(ARG1(arg),O_LIST,"dp_lnf_mod");
518: asir_assert(ARG2(arg),O_N,"dp_lnf_mod");
519: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
520: mod = QTOS((Q)ARG2(arg));
521: dp_lnf_mod((DP)BDY(b),(DP)BDY(NEXT(b)),g,mod,&r1,&r2);
522: NEWNODE(n); BDY(n) = (pointer)r1;
523: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
524: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
525: }
526:
1.16 noro 527: void Pdp_lnf_f(arg,rp)
528: NODE arg;
529: LIST *rp;
530: {
531: DP r1,r2;
532: NODE b,g,n;
533:
534: asir_assert(ARG0(arg),O_LIST,"dp_lnf_f");
535: asir_assert(ARG1(arg),O_LIST,"dp_lnf_f");
536: b = BDY((LIST)ARG0(arg)); g = BDY((LIST)ARG1(arg));
537: dp_lnf_f((DP)BDY(b),(DP)BDY(NEXT(b)),g,&r1,&r2);
538: NEWNODE(n); BDY(n) = (pointer)r1;
539: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r2;
540: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
541: }
542:
1.8 noro 543: void Pdp_nf_tab_mod(arg,rp)
544: NODE arg;
545: DP *rp;
546: {
547: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_mod");
548: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_mod");
549: asir_assert(ARG2(arg),O_N,"dp_nf_tab_mod");
550: dp_nf_tab_mod((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),
551: QTOS((Q)ARG2(arg)),rp);
1.28 noro 552: }
553:
554: void Pdp_nf_tab_f(arg,rp)
555: NODE arg;
556: DP *rp;
557: {
558: asir_assert(ARG0(arg),O_DP,"dp_nf_tab_f");
559: asir_assert(ARG1(arg),O_VECT,"dp_nf_tab_f");
560: dp_nf_tab_f((DP)ARG0(arg),(LIST *)BDY((VECT)ARG1(arg)),rp);
1.8 noro 561: }
1.1 noro 562:
563: void Pdp_ord(arg,rp)
564: NODE arg;
565: Obj *rp;
566: {
1.46 noro 567: struct order_spec *spec;
1.51 noro 568: LIST v;
569: struct oLIST f;
570: Num homo;
571: int modular;
572:
573: f.id = O_LIST; f.body = 0;
1.59 noro 574: if ( !arg && !current_option )
1.46 noro 575: *rp = dp_current_spec->obj;
1.1 noro 576: else {
1.53 noro 577: if ( current_option )
578: parse_gr_option(&f,current_option,&v,&homo,&modular,&spec);
1.51 noro 579: else if ( !create_order_spec(0,(Obj)ARG0(arg),&spec) )
580: error("dp_ord : invalid order specification");
1.46 noro 581: initd(spec); *rp = spec->obj;
1.1 noro 582: }
583: }
584:
585: void Pdp_ptod(arg,rp)
586: NODE arg;
587: DP *rp;
588: {
1.53 noro 589: P p;
1.1 noro 590: NODE n;
591: VL vl,tvl;
1.53 noro 592: struct oLIST f;
593: int ac;
594: LIST v;
595: Num homo;
596: int modular;
597: struct order_spec *ord;
1.1 noro 598:
599: asir_assert(ARG0(arg),O_P,"dp_ptod");
1.53 noro 600: p = (P)ARG0(arg);
601: ac = argc(arg);
602: if ( ac == 1 ) {
603: if ( current_option ) {
604: f.id = O_LIST; f.body = mknode(1,p);
605: parse_gr_option(&f,current_option,&v,&homo,&modular,&ord);
1.54 noro 606: initd(ord);
1.53 noro 607: } else
608: error("dp_ptod : invalid argument");
609: } else {
610: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
611: v = (LIST)ARG1(arg);
612: }
613: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
1.1 noro 614: if ( !vl ) {
615: NEWVL(vl); tvl = vl;
616: } else {
617: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
618: }
619: VR(tvl) = VR((P)BDY(n));
620: }
621: if ( vl )
622: NEXT(tvl) = 0;
1.53 noro 623: ptod(CO,vl,p,rp);
1.64 noro 624: }
625:
626: void Phomogenize(arg,rp)
627: NODE arg;
628: P *rp;
629: {
630: P p;
631: DP d,h;
632: NODE n;
633: V hv;
634: VL vl,tvl,last;
635: struct oLIST f;
636: LIST v;
637:
638: asir_assert(ARG0(arg),O_P,"homogenize");
639: p = (P)ARG0(arg);
640: asir_assert(ARG1(arg),O_LIST,"homogenize");
641: v = (LIST)ARG1(arg);
642: asir_assert(ARG2(arg),O_P,"homogenize");
643: hv = VR((P)ARG2(arg));
644: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
645: if ( !vl ) {
646: NEWVL(vl); tvl = vl;
647: } else {
648: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
649: }
650: VR(tvl) = VR((P)BDY(n));
651: }
652: if ( vl ) {
653: last = tvl;
654: NEXT(tvl) = 0;
655: }
656: ptod(CO,vl,p,&d);
657: dp_homo(d,&h);
658: NEWVL(NEXT(last)); last = NEXT(last);
659: VR(last) = hv; NEXT(last) = 0;
660: dtop(CO,vl,h,rp);
1.1 noro 661: }
662:
1.52 noro 663: void Pdp_ltod(arg,rp)
664: NODE arg;
665: DPV *rp;
666: {
667: NODE n;
668: VL vl,tvl;
1.53 noro 669: LIST f,v;
670: int sugar,i,len,ac,modular;
671: Num homo;
672: struct order_spec *ord;
1.52 noro 673: DP *e;
674: NODE nd,t;
675:
1.53 noro 676: ac = argc(arg);
1.52 noro 677: asir_assert(ARG0(arg),O_LIST,"dp_ptod");
1.53 noro 678: f = (LIST)ARG0(arg);
679: if ( ac == 1 ) {
680: if ( current_option ) {
681: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.54 noro 682: initd(ord);
1.53 noro 683: } else
684: error("dp_ltod : invalid argument");
685: } else {
686: asir_assert(ARG1(arg),O_LIST,"dp_ptod");
687: v = (LIST)ARG1(arg);
688: }
689: for ( vl = 0, n = BDY(v); n; n = NEXT(n) ) {
1.52 noro 690: if ( !vl ) {
691: NEWVL(vl); tvl = vl;
692: } else {
693: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
694: }
695: VR(tvl) = VR((P)BDY(n));
696: }
697: if ( vl )
698: NEXT(tvl) = 0;
1.53 noro 699:
700: nd = BDY(f);
1.52 noro 701: len = length(nd);
702: e = (DP *)MALLOC(len*sizeof(DP));
703: sugar = 0;
704: for ( i = 0, t = nd; i < len; i++, t = NEXT(t) ) {
705: ptod(CO,vl,(P)BDY(t),&e[i]);
706: if ( e[i] )
707: sugar = MAX(sugar,e[i]->sugar);
708: }
709: MKDPV(len,e,*rp);
710: }
711:
1.1 noro 712: void Pdp_dtop(arg,rp)
713: NODE arg;
714: P *rp;
715: {
716: NODE n;
717: VL vl,tvl;
718:
719: asir_assert(ARG0(arg),O_DP,"dp_dtop");
720: asir_assert(ARG1(arg),O_LIST,"dp_dtop");
721: for ( vl = 0, n = BDY((LIST)ARG1(arg)); n; n = NEXT(n) ) {
722: if ( !vl ) {
723: NEWVL(vl); tvl = vl;
724: } else {
725: NEWVL(NEXT(tvl)); tvl = NEXT(tvl);
726: }
727: VR(tvl) = VR((P)BDY(n));
728: }
729: if ( vl )
730: NEXT(tvl) = 0;
731: dtop(CO,vl,(DP)ARG0(arg),rp);
732: }
733:
734: extern LIST Dist;
735:
736: void Pdp_ptozp(arg,rp)
737: NODE arg;
1.60 ohara 738: Obj *rp;
1.1 noro 739: {
1.60 ohara 740: Q t;
741: NODE tt,p;
742: NODE n,n0;
743: char *key;
744: DP pp;
745: LIST list;
746: int get_factor=0;
747:
1.1 noro 748: asir_assert(ARG0(arg),O_DP,"dp_ptozp");
1.60 ohara 749:
750: /* analyze the option */
751: if ( current_option ) {
752: for ( tt = current_option; tt; tt = NEXT(tt) ) {
753: p = BDY((LIST)BDY(tt));
754: key = BDY((STRING)BDY(p));
755: /* value = (Obj)BDY(NEXT(p)); */
756: if ( !strcmp(key,"factor") ) get_factor=1;
757: else {
758: error("ptozp: unknown option.");
759: }
760: }
761: }
762:
763: dp_ptozp3((DP)ARG0(arg),&t,&pp);
764:
765: /* printexpr(NULL,t); */
766: /* if the option factor is given, then it returns the answer
767: in the format [zpoly, num] where num*zpoly is equal to the argument.*/
768: if (get_factor) {
769: n0 = mknode(2,pp,t);
770: MKLIST(list,n0);
771: *rp = (Obj)list;
772: } else
773: *rp = (Obj)pp;
1.1 noro 774: }
775:
776: void Pdp_ptozp2(arg,rp)
777: NODE arg;
778: LIST *rp;
779: {
780: DP p0,p1,h,r;
781: NODE n0;
782:
783: p0 = (DP)ARG0(arg); p1 = (DP)ARG1(arg);
784: asir_assert(p0,O_DP,"dp_ptozp2");
785: asir_assert(p1,O_DP,"dp_ptozp2");
1.10 noro 786: dp_ptozp2(p0,p1,&h,&r);
1.1 noro 787: NEWNODE(n0); BDY(n0) = (pointer)h;
788: NEWNODE(NEXT(n0)); BDY(NEXT(n0)) = (pointer)r;
789: NEXT(NEXT(n0)) = 0;
790: MKLIST(*rp,n0);
791: }
792:
793: void Pdp_prim(arg,rp)
794: NODE arg;
795: DP *rp;
796: {
797: DP t;
798:
799: asir_assert(ARG0(arg),O_DP,"dp_prim");
800: dp_prim((DP)ARG0(arg),&t); dp_ptozp(t,rp);
801: }
802:
803: void Pdp_mod(arg,rp)
804: NODE arg;
805: DP *rp;
806: {
807: DP p;
808: int mod;
809: NODE subst;
810:
811: asir_assert(ARG0(arg),O_DP,"dp_mod");
812: asir_assert(ARG1(arg),O_N,"dp_mod");
813: asir_assert(ARG2(arg),O_LIST,"dp_mod");
814: p = (DP)ARG0(arg); mod = QTOS((Q)ARG1(arg));
815: subst = BDY((LIST)ARG2(arg));
816: dp_mod(p,mod,subst,rp);
817: }
818:
819: void Pdp_rat(arg,rp)
820: NODE arg;
821: DP *rp;
822: {
823: asir_assert(ARG0(arg),O_DP,"dp_rat");
824: dp_rat((DP)ARG0(arg),rp);
825: }
826:
1.9 noro 827: extern int DP_Multiple;
828:
1.1 noro 829: void Pdp_nf(arg,rp)
830: NODE arg;
831: DP *rp;
832: {
833: NODE b;
834: DP *ps;
835: DP g;
836: int full;
837:
1.61 noro 838: do_weyl = 0; dp_fcoeffs = 0;
1.1 noro 839: asir_assert(ARG0(arg),O_LIST,"dp_nf");
840: asir_assert(ARG1(arg),O_DP,"dp_nf");
841: asir_assert(ARG2(arg),O_VECT,"dp_nf");
842: asir_assert(ARG3(arg),O_N,"dp_nf");
843: if ( !(g = (DP)ARG1(arg)) ) {
844: *rp = 0; return;
845: }
846: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
847: full = (Q)ARG3(arg) ? 1 : 0;
1.16 noro 848: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
1.1 noro 849: }
850:
1.11 noro 851: void Pdp_weyl_nf(arg,rp)
852: NODE arg;
853: DP *rp;
854: {
855: NODE b;
856: DP *ps;
857: DP g;
858: int full;
859:
860: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf");
861: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf");
862: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf");
863: asir_assert(ARG3(arg),O_N,"dp_weyl_nf");
864: if ( !(g = (DP)ARG1(arg)) ) {
865: *rp = 0; return;
866: }
867: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
868: full = (Q)ARG3(arg) ? 1 : 0;
1.12 noro 869: do_weyl = 1;
1.16 noro 870: dp_nf_z(b,g,ps,full,DP_Multiple,rp);
871: do_weyl = 0;
872: }
873:
874: /* nf computation using field operations */
875:
876: void Pdp_nf_f(arg,rp)
877: NODE arg;
878: DP *rp;
879: {
880: NODE b;
881: DP *ps;
882: DP g;
883: int full;
884:
885: do_weyl = 0;
886: asir_assert(ARG0(arg),O_LIST,"dp_nf_f");
887: asir_assert(ARG1(arg),O_DP,"dp_nf_f");
888: asir_assert(ARG2(arg),O_VECT,"dp_nf_f");
889: asir_assert(ARG3(arg),O_N,"dp_nf_f");
890: if ( !(g = (DP)ARG1(arg)) ) {
891: *rp = 0; return;
892: }
893: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
894: full = (Q)ARG3(arg) ? 1 : 0;
895: dp_nf_f(b,g,ps,full,rp);
896: }
897:
898: void Pdp_weyl_nf_f(arg,rp)
899: NODE arg;
900: DP *rp;
901: {
902: NODE b;
903: DP *ps;
904: DP g;
905: int full;
906:
907: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_f");
908: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_f");
909: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_f");
910: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_f");
911: if ( !(g = (DP)ARG1(arg)) ) {
912: *rp = 0; return;
913: }
914: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
915: full = (Q)ARG3(arg) ? 1 : 0;
916: do_weyl = 1;
917: dp_nf_f(b,g,ps,full,rp);
1.12 noro 918: do_weyl = 0;
1.11 noro 919: }
920:
1.13 noro 921: void Pdp_nf_mod(arg,rp)
922: NODE arg;
923: DP *rp;
924: {
925: NODE b;
926: DP g;
927: DP *ps;
928: int mod,full,ac;
929: NODE n,n0;
930:
1.14 noro 931: do_weyl = 0;
1.13 noro 932: ac = argc(arg);
1.14 noro 933: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
934: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
935: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
936: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
937: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
1.13 noro 938: if ( !(g = (DP)ARG1(arg)) ) {
939: *rp = 0; return;
940: }
941: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
942: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
943: for ( n0 = n = 0; b; b = NEXT(b) ) {
944: NEXTNODE(n0,n);
945: BDY(n) = (pointer)QTOS((Q)BDY(b));
946: }
947: if ( n0 )
948: NEXT(n) = 0;
949: dp_nf_mod(n0,g,ps,mod,full,rp);
950: }
951:
1.1 noro 952: void Pdp_true_nf(arg,rp)
953: NODE arg;
954: LIST *rp;
955: {
956: NODE b,n;
957: DP *ps;
958: DP g;
959: DP nm;
960: P dn;
961: int full;
962:
1.61 noro 963: do_weyl = 0; dp_fcoeffs = 0;
1.1 noro 964: asir_assert(ARG0(arg),O_LIST,"dp_true_nf");
965: asir_assert(ARG1(arg),O_DP,"dp_true_nf");
966: asir_assert(ARG2(arg),O_VECT,"dp_true_nf");
967: asir_assert(ARG3(arg),O_N,"dp_nf");
968: if ( !(g = (DP)ARG1(arg)) ) {
969: nm = 0; dn = (P)ONE;
970: } else {
971: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
972: full = (Q)ARG3(arg) ? 1 : 0;
973: dp_true_nf(b,g,ps,full,&nm,&dn);
974: }
975: NEWNODE(n); BDY(n) = (pointer)nm;
976: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
977: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
978: }
979:
1.67 noro 980: void Pdp_true_nf_marked(arg,rp)
981: NODE arg;
982: LIST *rp;
983: {
984: NODE b,n;
985: DP *ps,*hps;
986: DP g;
987: DP nm;
1.69 noro 988: Q cont;
1.67 noro 989: P dn;
990: int full;
991:
992: do_weyl = 0; dp_fcoeffs = 0;
993: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_marked");
994: asir_assert(ARG1(arg),O_DP,"dp_true_nf_marked");
995: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_marked");
996: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_marked");
997: if ( !(g = (DP)ARG1(arg)) ) {
998: nm = 0; dn = (P)ONE;
999: } else {
1000: b = BDY((LIST)ARG0(arg));
1001: ps = (DP *)BDY((VECT)ARG2(arg));
1002: hps = (DP *)BDY((VECT)ARG3(arg));
1.69 noro 1003: dp_true_nf_marked(b,g,ps,hps,&nm,&cont,&dn);
1.67 noro 1004: }
1.69 noro 1005: n = mknode(3,nm,cont,dn);
1006: MKLIST(*rp,n);
1.67 noro 1007: }
1008:
1.73 noro 1009: DP *dp_true_nf_and_quotient_marked (NODE b,DP g,DP *ps,DP *hps,DP *rp,P *dnp);
1010:
1011: void Pdp_true_nf_and_quotient_marked(arg,rp)
1012: NODE arg;
1013: LIST *rp;
1014: {
1015: NODE b,n;
1016: DP *ps,*hps;
1017: DP g;
1018: DP nm;
1019: VECT quo;
1020: P dn;
1021: int full;
1022:
1023: do_weyl = 0; dp_fcoeffs = 0;
1024: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_and_quotient_marked");
1025: asir_assert(ARG1(arg),O_DP,"dp_true_nf_and_quotient_marked");
1026: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_and_quotient_marked");
1027: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_and_quotient_marked");
1028: if ( !(g = (DP)ARG1(arg)) ) {
1029: nm = 0; dn = (P)ONE;
1030: } else {
1031: b = BDY((LIST)ARG0(arg));
1032: ps = (DP *)BDY((VECT)ARG2(arg));
1033: hps = (DP *)BDY((VECT)ARG3(arg));
1034: NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
1035: quo->body = (pointer *)dp_true_nf_and_quotient_marked(b,g,ps,hps,&nm,&dn);
1036: }
1037: n = mknode(3,nm,dn,quo);
1038: MKLIST(*rp,n);
1039: }
1040:
1.79 noro 1041: DP *dp_true_nf_and_quotient_marked_mod (NODE b,DP g,DP *ps,DP *hps,int mod,DP *rp,P *dnp);
1042:
1043: void Pdp_true_nf_and_quotient_marked_mod(arg,rp)
1044: NODE arg;
1045: LIST *rp;
1046: {
1047: NODE b,n;
1048: DP *ps,*hps;
1049: DP g;
1050: DP nm;
1051: VECT quo;
1052: P dn;
1053: int full,mod;
1054:
1055: do_weyl = 0; dp_fcoeffs = 0;
1056: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_and_quotient_marked_mod");
1057: asir_assert(ARG1(arg),O_DP,"dp_true_nf_and_quotient_marked_mod");
1058: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_and_quotient_marked_mod");
1059: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_and_quotient_marked_mod");
1060: asir_assert(ARG4(arg),O_N,"dp_true_nf_and_quotient_marked_mod");
1061: if ( !(g = (DP)ARG1(arg)) ) {
1062: nm = 0; dn = (P)ONE;
1063: } else {
1064: b = BDY((LIST)ARG0(arg));
1065: ps = (DP *)BDY((VECT)ARG2(arg));
1066: hps = (DP *)BDY((VECT)ARG3(arg));
1067: mod = QTOS((Q)ARG4(arg));
1068: NEWVECT(quo); quo->len = ((VECT)ARG2(arg))->len;
1069: quo->body = (pointer *)dp_true_nf_and_quotient_marked_mod(b,g,ps,hps,mod,&nm,&dn);
1070: }
1071: n = mknode(3,nm,dn,quo);
1072: MKLIST(*rp,n);
1073: }
1074:
1.70 noro 1075: void Pdp_true_nf_marked_mod(arg,rp)
1076: NODE arg;
1077: LIST *rp;
1078: {
1079: NODE b,n;
1080: DP *ps,*hps;
1081: DP g;
1082: DP nm;
1083: P dn;
1084: int mod;
1085:
1086: do_weyl = 0; dp_fcoeffs = 0;
1087: asir_assert(ARG0(arg),O_LIST,"dp_true_nf_marked_mod");
1088: asir_assert(ARG1(arg),O_DP,"dp_true_nf_marked_mod");
1089: asir_assert(ARG2(arg),O_VECT,"dp_true_nf_marked_mod");
1090: asir_assert(ARG3(arg),O_VECT,"dp_true_nf_marked_mod");
1091: asir_assert(ARG4(arg),O_N,"dp_true_nf_marked_mod");
1092: if ( !(g = (DP)ARG1(arg)) ) {
1093: nm = 0; dn = (P)ONE;
1094: } else {
1095: b = BDY((LIST)ARG0(arg));
1096: ps = (DP *)BDY((VECT)ARG2(arg));
1097: hps = (DP *)BDY((VECT)ARG3(arg));
1098: mod = QTOS((Q)ARG4(arg));
1099: dp_true_nf_marked_mod(b,g,ps,hps,mod,&nm,&dn);
1100: }
1101: n = mknode(2,nm,dn);
1102: MKLIST(*rp,n);
1103: }
1104:
1.13 noro 1105: void Pdp_weyl_nf_mod(arg,rp)
1.8 noro 1106: NODE arg;
1107: DP *rp;
1108: {
1109: NODE b;
1110: DP g;
1111: DP *ps;
1112: int mod,full,ac;
1.9 noro 1113: NODE n,n0;
1.8 noro 1114:
1115: ac = argc(arg);
1.14 noro 1116: asir_assert(ARG0(arg),O_LIST,"dp_weyl_nf_mod");
1117: asir_assert(ARG1(arg),O_DP,"dp_weyl_nf_mod");
1118: asir_assert(ARG2(arg),O_VECT,"dp_weyl_nf_mod");
1119: asir_assert(ARG3(arg),O_N,"dp_weyl_nf_mod");
1120: asir_assert(ARG4(arg),O_N,"dp_weyl_nf_mod");
1.8 noro 1121: if ( !(g = (DP)ARG1(arg)) ) {
1122: *rp = 0; return;
1123: }
1124: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
1125: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
1.9 noro 1126: for ( n0 = n = 0; b; b = NEXT(b) ) {
1127: NEXTNODE(n0,n);
1128: BDY(n) = (pointer)QTOS((Q)BDY(b));
1129: }
1130: if ( n0 )
1131: NEXT(n) = 0;
1.13 noro 1132: do_weyl = 1;
1133: dp_nf_mod(n0,g,ps,mod,full,rp);
1134: do_weyl = 0;
1.8 noro 1135: }
1136:
1137: void Pdp_true_nf_mod(arg,rp)
1138: NODE arg;
1139: LIST *rp;
1140: {
1141: NODE b;
1142: DP g,nm;
1143: P dn;
1144: DP *ps;
1145: int mod,full;
1146: NODE n;
1147:
1.11 noro 1148: do_weyl = 0;
1.8 noro 1149: asir_assert(ARG0(arg),O_LIST,"dp_nf_mod");
1150: asir_assert(ARG1(arg),O_DP,"dp_nf_mod");
1151: asir_assert(ARG2(arg),O_VECT,"dp_nf_mod");
1152: asir_assert(ARG3(arg),O_N,"dp_nf_mod");
1153: asir_assert(ARG4(arg),O_N,"dp_nf_mod");
1154: if ( !(g = (DP)ARG1(arg)) ) {
1155: nm = 0; dn = (P)ONEM;
1156: } else {
1157: b = BDY((LIST)ARG0(arg)); ps = (DP *)BDY((VECT)ARG2(arg));
1158: full = QTOS((Q)ARG3(arg)); mod = QTOS((Q)ARG4(arg));
1159: dp_true_nf_mod(b,g,ps,mod,full,&nm,&dn);
1160: }
1161: NEWNODE(n); BDY(n) = (pointer)nm;
1162: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)dn;
1163: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1.1 noro 1164: }
1165:
1166: void Pdp_tdiv(arg,rp)
1167: NODE arg;
1168: DP *rp;
1169: {
1170: MP m,mr,mr0;
1171: DP p;
1172: Q c;
1173: N d,q,r;
1174: int sgn;
1175:
1176: asir_assert(ARG0(arg),O_DP,"dp_tdiv");
1177: asir_assert(ARG1(arg),O_N,"dp_tdiv");
1178: p = (DP)ARG0(arg); d = NM((Q)ARG1(arg)); sgn = SGN((Q)ARG1(arg));
1179: if ( !p )
1180: *rp = 0;
1181: else {
1182: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
1183: divn(NM((Q)m->c),d,&q,&r);
1184: if ( r ) {
1185: *rp = 0; return;
1186: } else {
1187: NEXTMP(mr0,mr); NTOQ(q,SGN((Q)m->c)*sgn,c);
1188: mr->c = (P)c; mr->dl = m->dl;
1189: }
1190: }
1191: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
1192: }
1193: }
1194:
1195: void Pdp_red_coef(arg,rp)
1196: NODE arg;
1197: DP *rp;
1198: {
1199: MP m,mr,mr0;
1200: P q,r;
1201: DP p;
1202: P mod;
1203:
1204: p = (DP)ARG0(arg); mod = (P)ARG1(arg);
1205: asir_assert(p,O_DP,"dp_red_coef");
1206: asir_assert(mod,O_P,"dp_red_coef");
1207: if ( !p )
1208: *rp = 0;
1209: else {
1210: for ( mr0 = 0, m = BDY(p); m; m = NEXT(m) ) {
1211: divsrp(CO,m->c,mod,&q,&r);
1212: if ( r ) {
1213: NEXTMP(mr0,mr); mr->c = r; mr->dl = m->dl;
1214: }
1215: }
1216: if ( mr0 ) {
1217: NEXT(mr) = 0; MKDP(p->nv,mr0,*rp); (*rp)->sugar = p->sugar;
1218: } else
1219: *rp = 0;
1220: }
1221: }
1222:
1223: void Pdp_redble(arg,rp)
1224: NODE arg;
1225: Q *rp;
1226: {
1227: asir_assert(ARG0(arg),O_DP,"dp_redble");
1228: asir_assert(ARG1(arg),O_DP,"dp_redble");
1229: if ( dp_redble((DP)ARG0(arg),(DP)ARG1(arg)) )
1230: *rp = ONE;
1231: else
1232: *rp = 0;
1233: }
1234:
1235: void Pdp_red_mod(arg,rp)
1236: NODE arg;
1237: LIST *rp;
1238: {
1239: DP h,r;
1240: P dmy;
1241: NODE n;
1242:
1.11 noro 1243: do_weyl = 0;
1.1 noro 1244: asir_assert(ARG0(arg),O_DP,"dp_red_mod");
1245: asir_assert(ARG1(arg),O_DP,"dp_red_mod");
1246: asir_assert(ARG2(arg),O_DP,"dp_red_mod");
1247: asir_assert(ARG3(arg),O_N,"dp_red_mod");
1248: dp_red_mod((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),QTOS((Q)ARG3(arg)),
1249: &h,&r,&dmy);
1250: NEWNODE(n); BDY(n) = (pointer)h;
1251: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)r;
1252: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1253: }
1.13 noro 1254:
1.1 noro 1255: void Pdp_subd(arg,rp)
1256: NODE arg;
1257: DP *rp;
1258: {
1259: DP p1,p2;
1260:
1261: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1262: asir_assert(p1,O_DP,"dp_subd");
1263: asir_assert(p2,O_DP,"dp_subd");
1264: dp_subd(p1,p2,rp);
1265: }
1266:
1.80 noro 1267: void Pdp_symb_add(arg,rp)
1268: NODE arg;
1269: DP *rp;
1270: {
1271: DP p1,p2,r;
1272: NODE s0;
1273: MP mp0,mp;
1274: int nv;
1275:
1276: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1277: asir_assert(p1,O_DP,"dp_symb_add");
1278: asir_assert(p2,O_DP,"dp_symb_add");
1279: if ( p1->nv != p2->nv )
1280: error("dp_sumb_add : invalid input");
1281: nv = p1->nv;
1282: s0 = symb_merge(dp_dllist(p1),dp_dllist(p2),nv);
1283: for ( mp0 = 0; s0; s0 = NEXT(s0) ) {
1284: NEXTMP(mp0,mp); mp->dl = (DL)BDY(s0); mp->c = (P)ONE;
1285: }
1286: NEXT(mp) = 0;
1287: MKDP(nv,mp0,r); r->sugar = MAX(p1->sugar,p2->sugar);
1288: *rp = r;
1289: }
1290:
1.32 noro 1291: void Pdp_mul_trunc(arg,rp)
1292: NODE arg;
1293: DP *rp;
1294: {
1295: DP p1,p2,p;
1296:
1297: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); p = (DP)ARG2(arg);
1298: asir_assert(p1,O_DP,"dp_mul_trunc");
1299: asir_assert(p2,O_DP,"dp_mul_trunc");
1300: asir_assert(p,O_DP,"dp_mul_trunc");
1301: comm_muld_trunc(CO,p1,p2,BDY(p)->dl,rp);
1302: }
1303:
1304: void Pdp_quo(arg,rp)
1305: NODE arg;
1306: DP *rp;
1307: {
1308: DP p1,p2;
1309:
1310: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1311: asir_assert(p1,O_DP,"dp_quo");
1312: asir_assert(p2,O_DP,"dp_quo");
1313: comm_quod(CO,p1,p2,rp);
1314: }
1315:
1.12 noro 1316: void Pdp_weyl_mul(arg,rp)
1317: NODE arg;
1318: DP *rp;
1319: {
1320: DP p1,p2;
1321:
1322: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1.32 noro 1323: asir_assert(p1,O_DP,"dp_weyl_mul"); asir_assert(p2,O_DP,"dp_weyl_mul");
1.12 noro 1324: do_weyl = 1;
1325: muld(CO,p1,p2,rp);
1.13 noro 1326: do_weyl = 0;
1327: }
1328:
1329: void Pdp_weyl_mul_mod(arg,rp)
1330: NODE arg;
1331: DP *rp;
1332: {
1333: DP p1,p2;
1334: Q m;
1335:
1336: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg); m = (Q)ARG2(arg);
1337: asir_assert(p1,O_DP,"dp_weyl_mul_mod");
1338: asir_assert(p2,O_DP,"dp_mul_mod");
1339: asir_assert(m,O_N,"dp_mul_mod");
1340: do_weyl = 1;
1341: mulmd(CO,QTOS(m),p1,p2,rp);
1.12 noro 1342: do_weyl = 0;
1343: }
1344:
1.1 noro 1345: void Pdp_red(arg,rp)
1346: NODE arg;
1347: LIST *rp;
1348: {
1349: NODE n;
1.4 noro 1350: DP head,rest,dmy1;
1.1 noro 1351: P dmy;
1352:
1.11 noro 1353: do_weyl = 0;
1.1 noro 1354: asir_assert(ARG0(arg),O_DP,"dp_red");
1355: asir_assert(ARG1(arg),O_DP,"dp_red");
1356: asir_assert(ARG2(arg),O_DP,"dp_red");
1.4 noro 1357: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.1 noro 1358: NEWNODE(n); BDY(n) = (pointer)head;
1359: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
1360: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1361: }
1362:
1.11 noro 1363: void Pdp_weyl_red(arg,rp)
1364: NODE arg;
1365: LIST *rp;
1366: {
1367: NODE n;
1368: DP head,rest,dmy1;
1369: P dmy;
1370:
1371: asir_assert(ARG0(arg),O_DP,"dp_weyl_red");
1372: asir_assert(ARG1(arg),O_DP,"dp_weyl_red");
1373: asir_assert(ARG2(arg),O_DP,"dp_weyl_red");
1.12 noro 1374: do_weyl = 1;
1.11 noro 1375: dp_red((DP)ARG0(arg),(DP)ARG1(arg),(DP)ARG2(arg),&head,&rest,&dmy,&dmy1);
1.12 noro 1376: do_weyl = 0;
1.11 noro 1377: NEWNODE(n); BDY(n) = (pointer)head;
1378: NEWNODE(NEXT(n)); BDY(NEXT(n)) = (pointer)rest;
1379: NEXT(NEXT(n)) = 0; MKLIST(*rp,n);
1380: }
1381:
1.1 noro 1382: void Pdp_sp(arg,rp)
1383: NODE arg;
1384: DP *rp;
1385: {
1386: DP p1,p2;
1387:
1.11 noro 1388: do_weyl = 0;
1.1 noro 1389: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1390: asir_assert(p1,O_DP,"dp_sp"); asir_assert(p2,O_DP,"dp_sp");
1391: dp_sp(p1,p2,rp);
1392: }
1393:
1.11 noro 1394: void Pdp_weyl_sp(arg,rp)
1395: NODE arg;
1396: DP *rp;
1397: {
1398: DP p1,p2;
1399:
1400: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1401: asir_assert(p1,O_DP,"dp_weyl_sp"); asir_assert(p2,O_DP,"dp_sp");
1.12 noro 1402: do_weyl = 1;
1.11 noro 1403: dp_sp(p1,p2,rp);
1.12 noro 1404: do_weyl = 0;
1.11 noro 1405: }
1406:
1.1 noro 1407: void Pdp_sp_mod(arg,rp)
1408: NODE arg;
1409: DP *rp;
1410: {
1411: DP p1,p2;
1412: int mod;
1413:
1.11 noro 1414: do_weyl = 0;
1.1 noro 1415: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1416: asir_assert(p1,O_DP,"dp_sp_mod"); asir_assert(p2,O_DP,"dp_sp_mod");
1417: asir_assert(ARG2(arg),O_N,"dp_sp_mod");
1418: mod = QTOS((Q)ARG2(arg));
1419: dp_sp_mod(p1,p2,mod,rp);
1420: }
1421:
1422: void Pdp_lcm(arg,rp)
1423: NODE arg;
1424: DP *rp;
1425: {
1426: int i,n,td;
1427: DL d1,d2,d;
1428: MP m;
1429: DP p1,p2;
1430:
1431: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1432: asir_assert(p1,O_DP,"dp_lcm"); asir_assert(p2,O_DP,"dp_lcm");
1433: n = p1->nv; d1 = BDY(p1)->dl; d2 = BDY(p2)->dl;
1434: NEWDL(d,n);
1435: for ( i = 0, td = 0; i < n; i++ ) {
1.24 noro 1436: d->d[i] = MAX(d1->d[i],d2->d[i]); td += MUL_WEIGHT(d->d[i],i);
1.1 noro 1437: }
1438: d->td = td;
1439: NEWMP(m); m->dl = d; m->c = (P)ONE; NEXT(m) = 0;
1440: MKDP(n,m,*rp); (*rp)->sugar = td; /* XXX */
1441: }
1442:
1443: void Pdp_hm(arg,rp)
1444: NODE arg;
1445: DP *rp;
1446: {
1447: DP p;
1448:
1449: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_hm");
1450: dp_hm(p,rp);
1451: }
1452:
1453: void Pdp_ht(arg,rp)
1454: NODE arg;
1455: DP *rp;
1456: {
1457: DP p;
1458: MP m,mr;
1459:
1460: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_ht");
1.52 noro 1461: dp_ht(p,rp);
1.1 noro 1462: }
1463:
1464: void Pdp_hc(arg,rp)
1465: NODE arg;
1466: P *rp;
1467: {
1468: asir_assert(ARG0(arg),O_DP,"dp_hc");
1469: if ( !ARG0(arg) )
1470: *rp = 0;
1471: else
1472: *rp = BDY((DP)ARG0(arg))->c;
1473: }
1474:
1475: void Pdp_rest(arg,rp)
1476: NODE arg;
1477: DP *rp;
1478: {
1479: asir_assert(ARG0(arg),O_DP,"dp_rest");
1480: if ( !ARG0(arg) )
1481: *rp = 0;
1482: else
1483: dp_rest((DP)ARG0(arg),rp);
1484: }
1485:
1486: void Pdp_td(arg,rp)
1487: NODE arg;
1488: Q *rp;
1489: {
1490: DP p;
1491:
1492: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_td");
1493: if ( !p )
1494: *rp = 0;
1495: else
1496: STOQ(BDY(p)->dl->td,*rp);
1497: }
1498:
1499: void Pdp_sugar(arg,rp)
1500: NODE arg;
1501: Q *rp;
1502: {
1503: DP p;
1504:
1505: p = (DP)ARG0(arg); asir_assert(p,O_DP,"dp_sugar");
1506: if ( !p )
1507: *rp = 0;
1508: else
1509: STOQ(p->sugar,*rp);
1.30 ohara 1510: }
1511:
1.49 noro 1512: void Pdp_initial_term(arg,rp)
1513: NODE arg;
1514: Obj *rp;
1515: {
1516: struct order_spec *ord;
1517: Num homo;
1518: int modular,is_list;
1519: LIST v,f,l,initiallist;
1520: NODE n;
1521:
1522: f = (LIST)ARG0(arg);
1523: if ( f && OID(f) == O_LIST )
1524: is_list = 1;
1525: else {
1526: n = mknode(1,f); MKLIST(l,n); f = l;
1527: is_list = 0;
1528: }
1.54 noro 1529: if ( current_option ) {
1.53 noro 1530: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.54 noro 1531: initd(ord);
1532: } else
1.49 noro 1533: ord = dp_current_spec;
1534: initiallist = dp_initial_term(f,ord);
1535: if ( !is_list )
1536: *rp = (Obj)BDY(BDY(initiallist));
1537: else
1538: *rp = (Obj)initiallist;
1539: }
1540:
1541: void Pdp_order(arg,rp)
1542: NODE arg;
1543: Obj *rp;
1544: {
1545: struct order_spec *ord;
1546: Num homo;
1547: int modular,is_list;
1548: LIST v,f,l,ordlist;
1549: NODE n;
1550:
1551: f = (LIST)ARG0(arg);
1552: if ( f && OID(f) == O_LIST )
1553: is_list = 1;
1554: else {
1555: n = mknode(1,f); MKLIST(l,n); f = l;
1556: is_list = 0;
1557: }
1.54 noro 1558: if ( current_option ) {
1.53 noro 1559: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.54 noro 1560: initd(ord);
1561: } else
1.49 noro 1562: ord = dp_current_spec;
1563: ordlist = dp_order(f,ord);
1564: if ( !is_list )
1565: *rp = (Obj)BDY(BDY(ordlist));
1566: else
1567: *rp = (Obj)ordlist;
1568: }
1569:
1.30 ohara 1570: void Pdp_set_sugar(arg,rp)
1571: NODE arg;
1572: Q *rp;
1573: {
1574: DP p;
1575: Q q;
1576: int i;
1577:
1578: p = (DP)ARG0(arg);
1579: q = (Q)ARG1(arg);
1580: if ( p && q) {
1581: asir_assert(p,O_DP,"dp_set_sugar");
1582: asir_assert(q,O_N, "dp_set_sugar");
1583: i = QTOS(q);
1584: if (p->sugar < i) {
1585: p->sugar = i;
1586: }
1587: }
1588: *rp = 0;
1.1 noro 1589: }
1590:
1591: void Pdp_cri1(arg,rp)
1592: NODE arg;
1593: Q *rp;
1594: {
1595: DP p1,p2;
1596: int *d1,*d2;
1597: int i,n;
1598:
1599: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1600: asir_assert(p1,O_DP,"dp_cri1"); asir_assert(p2,O_DP,"dp_cri1");
1601: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
1602: for ( i = 0; i < n; i++ )
1603: if ( d1[i] > d2[i] )
1604: break;
1605: *rp = i == n ? ONE : 0;
1606: }
1607:
1608: void Pdp_cri2(arg,rp)
1609: NODE arg;
1610: Q *rp;
1611: {
1612: DP p1,p2;
1613: int *d1,*d2;
1614: int i,n;
1615:
1616: p1 = (DP)ARG0(arg); p2 = (DP)ARG1(arg);
1617: asir_assert(p1,O_DP,"dp_cri2"); asir_assert(p2,O_DP,"dp_cri2");
1618: n = p1->nv; d1 = BDY(p1)->dl->d; d2 = BDY(p2)->dl->d;
1619: for ( i = 0; i < n; i++ )
1620: if ( MIN(d1[i],d2[i]) >= 1 )
1621: break;
1622: *rp = i == n ? ONE : 0;
1623: }
1624:
1625: void Pdp_minp(arg,rp)
1626: NODE arg;
1627: LIST *rp;
1628: {
1629: NODE tn,tn1,d,dd,dd0,p,tp;
1630: LIST l,minp;
1631: DP lcm,tlcm;
1632: int s,ts;
1633:
1634: asir_assert(ARG0(arg),O_LIST,"dp_minp");
1635: d = BDY((LIST)ARG0(arg)); minp = (LIST)BDY(d);
1636: p = BDY(minp); p = NEXT(NEXT(p)); lcm = (DP)BDY(p); p = NEXT(p);
1637: if ( !ARG1(arg) ) {
1638: s = QTOS((Q)BDY(p)); p = NEXT(p);
1639: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1640: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1641: tlcm = (DP)BDY(tp); tp = NEXT(tp);
1642: ts = QTOS((Q)BDY(tp)); tp = NEXT(tp);
1643: NEXTNODE(dd0,dd);
1644: if ( ts < s ) {
1645: BDY(dd) = (pointer)minp;
1646: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1647: } else if ( ts == s ) {
1648: if ( compd(CO,lcm,tlcm) > 0 ) {
1649: BDY(dd) = (pointer)minp;
1650: minp = (LIST)BDY(d); lcm = tlcm; s = ts;
1651: } else
1652: BDY(dd) = BDY(d);
1653: } else
1654: BDY(dd) = BDY(d);
1655: }
1656: } else {
1657: for ( dd0 = 0, d = NEXT(d); d; d = NEXT(d) ) {
1658: tp = BDY((LIST)BDY(d)); tp = NEXT(NEXT(tp));
1659: tlcm = (DP)BDY(tp);
1660: NEXTNODE(dd0,dd);
1661: if ( compd(CO,lcm,tlcm) > 0 ) {
1662: BDY(dd) = (pointer)minp; minp = (LIST)BDY(d); lcm = tlcm;
1663: } else
1664: BDY(dd) = BDY(d);
1665: }
1666: }
1667: if ( dd0 )
1668: NEXT(dd) = 0;
1669: MKLIST(l,dd0); MKNODE(tn,l,0); MKNODE(tn1,minp,tn); MKLIST(*rp,tn1);
1670: }
1671:
1672: void Pdp_criB(arg,rp)
1673: NODE arg;
1674: LIST *rp;
1675: {
1676: NODE d,ij,dd,ddd;
1677: int i,j,s,n;
1678: DP *ps;
1679: DL ts,ti,tj,lij,tdl;
1680:
1681: asir_assert(ARG0(arg),O_LIST,"dp_criB"); d = BDY((LIST)ARG0(arg));
1682: asir_assert(ARG1(arg),O_N,"dp_criB"); s = QTOS((Q)ARG1(arg));
1683: asir_assert(ARG2(arg),O_VECT,"dp_criB"); ps = (DP *)BDY((VECT)ARG2(arg));
1684: if ( !d )
1685: *rp = (LIST)ARG0(arg);
1686: else {
1687: ts = BDY(ps[s])->dl;
1688: n = ps[s]->nv;
1689: NEWDL(tdl,n);
1690: for ( dd = 0; d; d = NEXT(d) ) {
1691: ij = BDY((LIST)BDY(d));
1692: i = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1693: j = QTOS((Q)BDY(ij)); ij = NEXT(ij);
1694: lij = BDY((DP)BDY(ij))->dl;
1695: ti = BDY(ps[i])->dl; tj = BDY(ps[j])->dl;
1696: if ( lij->td != lcm_of_DL(n,lij,ts,tdl)->td
1697: || !dl_equal(n,lij,tdl)
1698: || (lij->td == lcm_of_DL(n,ti,ts,tdl)->td
1699: && dl_equal(n,tdl,lij))
1700: || (lij->td == lcm_of_DL(n,tj,ts,tdl)->td
1701: && dl_equal(n,tdl,lij)) ) {
1702: MKNODE(ddd,BDY(d),dd);
1703: dd = ddd;
1704: }
1705: }
1706: MKLIST(*rp,dd);
1707: }
1708: }
1709:
1710: void Pdp_nelim(arg,rp)
1711: NODE arg;
1712: Q *rp;
1713: {
1714: if ( arg ) {
1715: asir_assert(ARG0(arg),O_N,"dp_nelim");
1716: dp_nelim = QTOS((Q)ARG0(arg));
1717: }
1718: STOQ(dp_nelim,*rp);
1719: }
1720:
1721: void Pdp_mag(arg,rp)
1722: NODE arg;
1723: Q *rp;
1724: {
1725: DP p;
1726: int s;
1727: MP m;
1728:
1729: p = (DP)ARG0(arg);
1730: asir_assert(p,O_DP,"dp_mag");
1731: if ( !p )
1732: *rp = 0;
1733: else {
1734: for ( s = 0, m = BDY(p); m; m = NEXT(m) )
1735: s += p_mag(m->c);
1736: STOQ(s,*rp);
1737: }
1738: }
1739:
1740: extern int kara_mag;
1741:
1742: void Pdp_set_kara(arg,rp)
1743: NODE arg;
1744: Q *rp;
1745: {
1746: if ( arg ) {
1747: asir_assert(ARG0(arg),O_N,"dp_set_kara");
1748: kara_mag = QTOS((Q)ARG0(arg));
1749: }
1750: STOQ(kara_mag,*rp);
1751: }
1752:
1753: void Pdp_homo(arg,rp)
1754: NODE arg;
1755: DP *rp;
1756: {
1757: asir_assert(ARG0(arg),O_DP,"dp_homo");
1758: dp_homo((DP)ARG0(arg),rp);
1759: }
1760:
1.8 noro 1761: void Pdp_dehomo(arg,rp)
1762: NODE arg;
1.1 noro 1763: DP *rp;
1764: {
1.8 noro 1765: asir_assert(ARG0(arg),O_DP,"dp_dehomo");
1766: dp_dehomo((DP)ARG0(arg),rp);
1767: }
1768:
1769: void Pdp_gr_flags(arg,rp)
1770: NODE arg;
1771: LIST *rp;
1772: {
1773: Obj name,value;
1774: NODE n;
1.1 noro 1775:
1.8 noro 1776: if ( arg ) {
1777: asir_assert(ARG0(arg),O_LIST,"dp_gr_flags");
1778: n = BDY((LIST)ARG0(arg));
1779: while ( n ) {
1780: name = (Obj)BDY(n); n = NEXT(n);
1781: if ( !n )
1782: break;
1783: else {
1784: value = (Obj)BDY(n); n = NEXT(n);
1785: }
1786: dp_set_flag(name,value);
1.1 noro 1787: }
1788: }
1.8 noro 1789: dp_make_flaglist(rp);
1790: }
1791:
1.29 noro 1792: extern int DP_Print, DP_PrintShort;
1.8 noro 1793:
1794: void Pdp_gr_print(arg,rp)
1795: NODE arg;
1796: Q *rp;
1797: {
1798: Q q;
1.29 noro 1799: int s;
1.8 noro 1800:
1801: if ( arg ) {
1802: asir_assert(ARG0(arg),O_N,"dp_gr_print");
1.29 noro 1803: q = (Q)ARG0(arg);
1804: s = QTOS(q);
1805: switch ( s ) {
1806: case 0:
1807: DP_Print = 0; DP_PrintShort = 0;
1808: break;
1809: case 1:
1810: DP_Print = 1;
1811: break;
1.41 noro 1812: case 2:
1.29 noro 1813: DP_Print = 0; DP_PrintShort = 1;
1.43 noro 1814: break;
1.41 noro 1815: default:
1816: DP_Print = s; DP_PrintShort = 0;
1.29 noro 1817: break;
1818: }
1819: } else {
1820: if ( DP_Print ) {
1821: STOQ(1,q);
1822: } else if ( DP_PrintShort ) {
1823: STOQ(2,q);
1824: } else
1825: q = 0;
1826: }
1.8 noro 1827: *rp = q;
1.1 noro 1828: }
1829:
1.46 noro 1830: void parse_gr_option(LIST f,NODE opt,LIST *v,Num *homo,
1831: int *modular,struct order_spec **ord)
1832: {
1833: NODE t,p;
1834: Q m;
1835: char *key;
1836: Obj value,dmy;
1837: int ord_is_set = 0;
1838: int modular_is_set = 0;
1839: int homo_is_set = 0;
1.47 noro 1840: VL vl,vl0;
1.46 noro 1841: LIST vars;
1.47 noro 1842: char xiname[BUFSIZ];
1843: NODE x0,x;
1844: DP d;
1845: P xi;
1846: int nv,i;
1.46 noro 1847:
1848: /* extract vars */
1849: vars = 0;
1850: for ( t = opt; t; t = NEXT(t) ) {
1851: p = BDY((LIST)BDY(t));
1852: key = BDY((STRING)BDY(p));
1853: value = (Obj)BDY(NEXT(p));
1854: if ( !strcmp(key,"v") ) {
1855: /* variable list */
1856: vars = (LIST)value;
1857: break;
1858: }
1859: }
1.48 noro 1860: if ( vars ) {
1861: *v = vars; pltovl(vars,&vl);
1862: } else {
1863: for ( t = BDY(f); t; t = NEXT(t) )
1864: if ( BDY(t) && OID((Obj)BDY(t))==O_DP )
1865: break;
1866: if ( t ) {
1867: /* f is DP list */
1868: /* create dummy var list */
1869: d = (DP)BDY(t);
1870: nv = NV(d);
1871: for ( i = 0, vl0 = 0, x0 = 0; i < nv; i++ ) {
1872: NEXTVL(vl0,vl);
1873: NEXTNODE(x0,x);
1874: sprintf(xiname,"x%d",i);
1875: makevar(xiname,&xi);
1876: x->body = (pointer)xi;
1877: vl->v = VR((P)xi);
1878: }
1879: if ( vl0 ) {
1880: NEXT(vl) = 0;
1881: NEXT(x) = 0;
1882: }
1883: MKLIST(vars,x0);
1884: *v = vars;
1885: vl = vl0;
1886: } else {
1887: get_vars((Obj)f,&vl); vltopl(vl,v);
1.47 noro 1888: }
1.46 noro 1889: }
1890:
1891: for ( t = opt; t; t = NEXT(t) ) {
1892: p = BDY((LIST)BDY(t));
1893: key = BDY((STRING)BDY(p));
1894: value = (Obj)BDY(NEXT(p));
1895: if ( !strcmp(key,"v") ) {
1896: /* variable list; ignore */
1897: } else if ( !strcmp(key,"order") ) {
1898: /* order spec */
1.51 noro 1899: if ( !vl )
1900: error("parse_gr_option : variables must be specified");
1.46 noro 1901: create_order_spec(vl,value,ord);
1902: ord_is_set = 1;
1903: } else if ( !strcmp(key,"block") ) {
1904: create_order_spec(0,value,ord);
1.51 noro 1905: ord_is_set = 1;
1.46 noro 1906: } else if ( !strcmp(key,"matrix") ) {
1907: create_order_spec(0,value,ord);
1.51 noro 1908: ord_is_set = 1;
1.46 noro 1909: } else if ( !strcmp(key,"sugarweight") ) {
1910: /* weight */
1911: Pdp_set_weight(NEXT(p),&dmy);
1912: } else if ( !strcmp(key,"homo") ) {
1913: *homo = (Num)value;
1914: homo_is_set = 1;
1915: } else if ( !strcmp(key,"trace") ) {
1916: m = (Q)value;
1917: if ( !m )
1918: *modular = 0;
1919: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1
1920: && BD(NM(m))[0] >= 0x80000000) )
1921: error("parse_gr_option : too large modulus");
1922: else
1923: *modular = QTOS(m);
1924: modular_is_set = 1;
1925: } else
1926: error("parse_gr_option : not implemented");
1927: }
1928: if ( !ord_is_set ) create_order_spec(0,0,ord);
1929: if ( !modular_is_set ) *modular = 0;
1930: if ( !homo_is_set ) *homo = 0;
1931: }
1932:
1.8 noro 1933: void Pdp_gr_main(arg,rp)
1.1 noro 1934: NODE arg;
1.8 noro 1935: LIST *rp;
1.1 noro 1936: {
1.8 noro 1937: LIST f,v;
1.46 noro 1938: VL vl;
1.8 noro 1939: Num homo;
1940: Q m;
1.46 noro 1941: int modular,ac;
1942: struct order_spec *ord;
1.8 noro 1943:
1.11 noro 1944: do_weyl = 0;
1.8 noro 1945: asir_assert(ARG0(arg),O_LIST,"dp_gr_main");
1.46 noro 1946: f = (LIST)ARG0(arg);
1.25 noro 1947: f = remove_zero_from_list(f);
1948: if ( !BDY(f) ) {
1949: *rp = f; return;
1950: }
1.53 noro 1951: if ( (ac = argc(arg)) == 5 ) {
1.46 noro 1952: asir_assert(ARG1(arg),O_LIST,"dp_gr_main");
1953: asir_assert(ARG2(arg),O_N,"dp_gr_main");
1954: asir_assert(ARG3(arg),O_N,"dp_gr_main");
1.49 noro 1955: v = (LIST)ARG1(arg);
1.46 noro 1956: homo = (Num)ARG2(arg);
1957: m = (Q)ARG3(arg);
1958: if ( !m )
1959: modular = 0;
1960: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
1961: error("dp_gr_main : too large modulus");
1962: else
1963: modular = QTOS(m);
1964: create_order_spec(0,ARG4(arg),&ord);
1.53 noro 1965: } else if ( current_option )
1966: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.46 noro 1967: else if ( ac == 1 )
1968: parse_gr_option(f,0,&v,&homo,&modular,&ord);
1.8 noro 1969: else
1.46 noro 1970: error("dp_gr_main : invalid argument");
1971: dp_gr_main(f,v,homo,modular,0,ord,rp);
1.63 noro 1972: }
1973:
1974: void Pdp_interreduce(arg,rp)
1975: NODE arg;
1976: LIST *rp;
1977: {
1978: LIST f,v;
1979: VL vl;
1980: int ac;
1981: struct order_spec *ord;
1982:
1983: do_weyl = 0;
1984: asir_assert(ARG0(arg),O_LIST,"dp_interreduce");
1985: f = (LIST)ARG0(arg);
1986: f = remove_zero_from_list(f);
1987: if ( !BDY(f) ) {
1988: *rp = f; return;
1989: }
1990: if ( (ac = argc(arg)) == 3 ) {
1991: asir_assert(ARG1(arg),O_LIST,"dp_interreduce");
1992: v = (LIST)ARG1(arg);
1993: create_order_spec(0,ARG2(arg),&ord);
1994: }
1995: dp_interreduce(f,v,0,ord,rp);
1.16 noro 1996: }
1997:
1998: void Pdp_gr_f_main(arg,rp)
1999: NODE arg;
2000: LIST *rp;
2001: {
2002: LIST f,v;
2003: Num homo;
1.26 noro 2004: int m,field,t;
1.46 noro 2005: struct order_spec *ord;
1.26 noro 2006: NODE n;
1.16 noro 2007:
2008: do_weyl = 0;
2009: asir_assert(ARG0(arg),O_LIST,"dp_gr_f_main");
2010: asir_assert(ARG1(arg),O_LIST,"dp_gr_f_main");
2011: asir_assert(ARG2(arg),O_N,"dp_gr_f_main");
2012: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2013: f = remove_zero_from_list(f);
2014: if ( !BDY(f) ) {
2015: *rp = f; return;
2016: }
1.16 noro 2017: homo = (Num)ARG2(arg);
1.27 noro 2018: #if 0
2019: asir_assert(ARG3(arg),O_N,"dp_gr_f_main");
1.26 noro 2020: m = QTOS((Q)ARG3(arg));
2021: if ( m )
2022: error("dp_gr_f_main : trace lifting is not implemented yet");
1.46 noro 2023: create_order_spec(0,ARG4(arg),&ord);
1.27 noro 2024: #else
2025: m = 0;
1.46 noro 2026: create_order_spec(0,ARG3(arg),&ord);
1.27 noro 2027: #endif
1.26 noro 2028: field = 0;
2029: for ( n = BDY(f); n; n = NEXT(n) ) {
2030: t = get_field_type(BDY(n));
2031: if ( !t )
2032: continue;
2033: if ( t < 0 )
2034: error("dp_gr_f_main : incosistent coefficients");
2035: if ( !field )
2036: field = t;
2037: else if ( t != field )
2038: error("dp_gr_f_main : incosistent coefficients");
2039: }
1.46 noro 2040: dp_gr_main(f,v,homo,m?1:0,field,ord,rp);
1.1 noro 2041: }
2042:
1.8 noro 2043: void Pdp_f4_main(arg,rp)
2044: NODE arg;
2045: LIST *rp;
1.1 noro 2046: {
1.8 noro 2047: LIST f,v;
1.46 noro 2048: struct order_spec *ord;
1.1 noro 2049:
1.11 noro 2050: do_weyl = 0;
1.8 noro 2051: asir_assert(ARG0(arg),O_LIST,"dp_f4_main");
2052: asir_assert(ARG1(arg),O_LIST,"dp_f4_main");
2053: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2054: f = remove_zero_from_list(f);
2055: if ( !BDY(f) ) {
2056: *rp = f; return;
2057: }
1.46 noro 2058: create_order_spec(0,ARG2(arg),&ord);
2059: dp_f4_main(f,v,ord,rp);
1.22 noro 2060: }
2061:
2062: /* dp_gr_checklist(list of dp) */
2063:
2064: void Pdp_gr_checklist(arg,rp)
2065: NODE arg;
2066: LIST *rp;
2067: {
2068: VECT g;
2069: LIST dp;
2070: NODE r;
1.23 noro 2071: int n;
1.22 noro 2072:
2073: do_weyl = 0;
2074: asir_assert(ARG0(arg),O_LIST,"dp_gr_checklist");
1.23 noro 2075: asir_assert(ARG1(arg),O_N,"dp_gr_checklist");
2076: n = QTOS((Q)ARG1(arg));
2077: gbcheck_list(BDY((LIST)ARG0(arg)),n,&g,&dp);
1.22 noro 2078: r = mknode(2,g,dp);
2079: MKLIST(*rp,r);
1.1 noro 2080: }
2081:
1.8 noro 2082: void Pdp_f4_mod_main(arg,rp)
2083: NODE arg;
2084: LIST *rp;
1.1 noro 2085: {
1.8 noro 2086: LIST f,v;
2087: int m;
1.46 noro 2088: struct order_spec *ord;
1.8 noro 2089:
1.11 noro 2090: do_weyl = 0;
1.17 noro 2091: asir_assert(ARG0(arg),O_LIST,"dp_f4_mod_main");
2092: asir_assert(ARG1(arg),O_LIST,"dp_f4_mod_main");
2093: asir_assert(ARG2(arg),O_N,"dp_f4_mod_main");
1.8 noro 2094: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 2095: f = remove_zero_from_list(f);
2096: if ( !BDY(f) ) {
2097: *rp = f; return;
2098: }
1.20 noro 2099: if ( !m )
2100: error("dp_f4_mod_main : invalid argument");
1.46 noro 2101: create_order_spec(0,ARG3(arg),&ord);
2102: dp_f4_mod_main(f,v,m,ord,rp);
1.8 noro 2103: }
1.1 noro 2104:
1.8 noro 2105: void Pdp_gr_mod_main(arg,rp)
2106: NODE arg;
2107: LIST *rp;
2108: {
2109: LIST f,v;
2110: Num homo;
2111: int m;
1.46 noro 2112: struct order_spec *ord;
1.8 noro 2113:
1.11 noro 2114: do_weyl = 0;
1.8 noro 2115: asir_assert(ARG0(arg),O_LIST,"dp_gr_mod_main");
2116: asir_assert(ARG1(arg),O_LIST,"dp_gr_mod_main");
2117: asir_assert(ARG2(arg),O_N,"dp_gr_mod_main");
2118: asir_assert(ARG3(arg),O_N,"dp_gr_mod_main");
1.11 noro 2119: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2120: f = remove_zero_from_list(f);
2121: if ( !BDY(f) ) {
2122: *rp = f; return;
2123: }
1.11 noro 2124: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 2125: if ( !m )
2126: error("dp_gr_mod_main : invalid argument");
1.46 noro 2127: create_order_spec(0,ARG4(arg),&ord);
2128: dp_gr_mod_main(f,v,homo,m,ord,rp);
1.33 noro 2129: }
2130:
1.40 noro 2131: void Pnd_f4(arg,rp)
2132: NODE arg;
2133: LIST *rp;
2134: {
2135: LIST f,v;
1.81 noro 2136: int m,find;
2137: Obj homo;
1.46 noro 2138: struct order_spec *ord;
1.40 noro 2139:
2140: do_weyl = 0;
1.76 noro 2141: asir_assert(ARG0(arg),O_LIST,"nd_f4");
2142: asir_assert(ARG1(arg),O_LIST,"nd_f4");
2143: asir_assert(ARG2(arg),O_N,"nd_f4");
1.40 noro 2144: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2145: f = remove_zero_from_list(f);
2146: if ( !BDY(f) ) {
2147: *rp = f; return;
2148: }
2149: m = QTOS((Q)ARG2(arg));
1.46 noro 2150: create_order_spec(0,ARG3(arg),&ord);
1.81 noro 2151: find = get_opt("homo",&homo);
2152: nd_gr(f,v,m,find&&homo,1,ord,rp);
1.40 noro 2153: }
2154:
1.33 noro 2155: void Pnd_gr(arg,rp)
2156: NODE arg;
2157: LIST *rp;
2158: {
2159: LIST f,v;
1.81 noro 2160: int m,find;
2161: Obj homo;
1.46 noro 2162: struct order_spec *ord;
1.33 noro 2163:
2164: do_weyl = 0;
2165: asir_assert(ARG0(arg),O_LIST,"nd_gr");
2166: asir_assert(ARG1(arg),O_LIST,"nd_gr");
1.36 noro 2167: asir_assert(ARG2(arg),O_N,"nd_gr");
1.33 noro 2168: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2169: f = remove_zero_from_list(f);
2170: if ( !BDY(f) ) {
2171: *rp = f; return;
2172: }
2173: m = QTOS((Q)ARG2(arg));
1.46 noro 2174: create_order_spec(0,ARG3(arg),&ord);
1.81 noro 2175: find = get_opt("homo",&homo);
2176: nd_gr(f,v,m,find&&homo,0,ord,rp);
1.58 noro 2177: }
2178:
2179: void Pnd_gr_postproc(arg,rp)
2180: NODE arg;
2181: LIST *rp;
2182: {
2183: LIST f,v;
2184: int m,do_check;
2185: struct order_spec *ord;
2186:
2187: do_weyl = 0;
2188: asir_assert(ARG0(arg),O_LIST,"nd_gr");
2189: asir_assert(ARG1(arg),O_LIST,"nd_gr");
2190: asir_assert(ARG2(arg),O_N,"nd_gr");
2191: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2192: f = remove_zero_from_list(f);
2193: if ( !BDY(f) ) {
2194: *rp = f; return;
2195: }
2196: m = QTOS((Q)ARG2(arg));
2197: create_order_spec(0,ARG3(arg),&ord);
2198: do_check = ARG4(arg) ? 1 : 0;
2199: nd_gr_postproc(f,v,m,ord,do_check,rp);
1.36 noro 2200: }
2201:
1.75 noro 2202: void Pnd_weyl_gr_postproc(arg,rp)
2203: NODE arg;
2204: LIST *rp;
2205: {
2206: LIST f,v;
2207: int m,do_check;
2208: struct order_spec *ord;
2209:
2210: do_weyl = 1;
2211: asir_assert(ARG0(arg),O_LIST,"nd_gr");
2212: asir_assert(ARG1(arg),O_LIST,"nd_gr");
2213: asir_assert(ARG2(arg),O_N,"nd_gr");
2214: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2215: f = remove_zero_from_list(f);
2216: if ( !BDY(f) ) {
1.80 noro 2217: *rp = f; do_weyl = 0; return;
1.75 noro 2218: }
2219: m = QTOS((Q)ARG2(arg));
2220: create_order_spec(0,ARG3(arg),&ord);
2221: do_check = ARG4(arg) ? 1 : 0;
2222: nd_gr_postproc(f,v,m,ord,do_check,rp);
1.80 noro 2223: do_weyl = 0;
1.75 noro 2224: }
2225:
1.36 noro 2226: void Pnd_gr_trace(arg,rp)
2227: NODE arg;
2228: LIST *rp;
2229: {
2230: LIST f,v;
2231: int m,homo;
1.46 noro 2232: struct order_spec *ord;
1.36 noro 2233:
2234: do_weyl = 0;
2235: asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
2236: asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
2237: asir_assert(ARG2(arg),O_N,"nd_gr_trace");
2238: asir_assert(ARG3(arg),O_N,"nd_gr_trace");
2239: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2240: f = remove_zero_from_list(f);
2241: if ( !BDY(f) ) {
2242: *rp = f; return;
2243: }
2244: homo = QTOS((Q)ARG2(arg));
2245: m = QTOS((Q)ARG3(arg));
1.46 noro 2246: create_order_spec(0,ARG4(arg),&ord);
1.62 noro 2247: nd_gr_trace(f,v,m,homo,0,ord,rp);
2248: }
2249:
2250: void Pnd_f4_trace(arg,rp)
2251: NODE arg;
2252: LIST *rp;
2253: {
2254: LIST f,v;
2255: int m,homo;
2256: struct order_spec *ord;
2257:
2258: do_weyl = 0;
2259: asir_assert(ARG0(arg),O_LIST,"nd_gr_trace");
2260: asir_assert(ARG1(arg),O_LIST,"nd_gr_trace");
2261: asir_assert(ARG2(arg),O_N,"nd_gr_trace");
2262: asir_assert(ARG3(arg),O_N,"nd_gr_trace");
2263: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2264: f = remove_zero_from_list(f);
2265: if ( !BDY(f) ) {
2266: *rp = f; return;
2267: }
2268: homo = QTOS((Q)ARG2(arg));
2269: m = QTOS((Q)ARG3(arg));
2270: create_order_spec(0,ARG4(arg),&ord);
2271: nd_gr_trace(f,v,m,homo,1,ord,rp);
1.11 noro 2272: }
2273:
1.38 noro 2274: void Pnd_weyl_gr(arg,rp)
2275: NODE arg;
2276: LIST *rp;
2277: {
2278: LIST f,v;
1.81 noro 2279: int m,find;
2280: Obj homo;
1.46 noro 2281: struct order_spec *ord;
1.38 noro 2282:
2283: do_weyl = 1;
2284: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr");
2285: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr");
2286: asir_assert(ARG2(arg),O_N,"nd_weyl_gr");
2287: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2288: f = remove_zero_from_list(f);
2289: if ( !BDY(f) ) {
1.80 noro 2290: *rp = f; do_weyl = 0; return;
1.38 noro 2291: }
2292: m = QTOS((Q)ARG2(arg));
1.46 noro 2293: create_order_spec(0,ARG3(arg),&ord);
1.81 noro 2294: find = get_opt("homo",&homo);
2295: nd_gr(f,v,m,find&&homo,0,ord,rp);
1.80 noro 2296: do_weyl = 0;
1.38 noro 2297: }
2298:
2299: void Pnd_weyl_gr_trace(arg,rp)
2300: NODE arg;
2301: LIST *rp;
2302: {
2303: LIST f,v;
2304: int m,homo;
1.46 noro 2305: struct order_spec *ord;
1.38 noro 2306:
2307: do_weyl = 1;
2308: asir_assert(ARG0(arg),O_LIST,"nd_weyl_gr_trace");
2309: asir_assert(ARG1(arg),O_LIST,"nd_weyl_gr_trace");
2310: asir_assert(ARG2(arg),O_N,"nd_weyl_gr_trace");
2311: asir_assert(ARG3(arg),O_N,"nd_weyl_gr_trace");
2312: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
2313: f = remove_zero_from_list(f);
2314: if ( !BDY(f) ) {
1.80 noro 2315: *rp = f; do_weyl = 0; return;
1.38 noro 2316: }
2317: homo = QTOS((Q)ARG2(arg));
2318: m = QTOS((Q)ARG3(arg));
1.46 noro 2319: create_order_spec(0,ARG4(arg),&ord);
1.65 noro 2320: nd_gr_trace(f,v,m,homo,0,ord,rp);
1.80 noro 2321: do_weyl = 0;
1.38 noro 2322: }
1.39 noro 2323:
1.83 ! noro 2324: void Pnd_nf(NODE arg,Obj *rp)
1.39 noro 2325: {
1.83 ! noro 2326: Obj f;
1.39 noro 2327: LIST g,v;
1.46 noro 2328: struct order_spec *ord;
1.39 noro 2329:
2330: do_weyl = 0;
2331: asir_assert(ARG1(arg),O_LIST,"nd_nf");
2332: asir_assert(ARG2(arg),O_LIST,"nd_nf");
2333: asir_assert(ARG4(arg),O_N,"nd_nf");
1.83 ! noro 2334: f = (Obj)ARG0(arg);
! 2335: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
! 2336: if ( !BDY(g) ) {
! 2337: *rp = f; return;
! 2338: }
! 2339: v = (LIST)ARG2(arg);
! 2340: create_order_spec(0,ARG3(arg),&ord);
! 2341: nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),ord,rp);
! 2342: }
! 2343:
! 2344: void Pnd_weyl_nf(NODE arg,Obj *rp)
! 2345: {
! 2346: Obj f;
! 2347: LIST g,v;
! 2348: struct order_spec *ord;
! 2349:
! 2350: do_weyl = 1;
! 2351: asir_assert(ARG1(arg),O_LIST,"nd_weyl_nf");
! 2352: asir_assert(ARG2(arg),O_LIST,"nd_weyl_nf");
! 2353: asir_assert(ARG4(arg),O_N,"nd_weyl_nf");
! 2354: f = (Obj)ARG0(arg);
1.39 noro 2355: g = (LIST)ARG1(arg); g = remove_zero_from_list(g);
2356: if ( !BDY(g) ) {
2357: *rp = f; return;
2358: }
2359: v = (LIST)ARG2(arg);
1.46 noro 2360: create_order_spec(0,ARG3(arg),&ord);
2361: nd_nf_p(f,g,v,QTOS((Q)ARG4(arg)),ord,rp);
1.39 noro 2362: }
2363:
1.11 noro 2364: /* for Weyl algebra */
2365:
2366: void Pdp_weyl_gr_main(arg,rp)
2367: NODE arg;
2368: LIST *rp;
2369: {
2370: LIST f,v;
2371: Num homo;
2372: Q m;
1.49 noro 2373: int modular,ac;
1.46 noro 2374: struct order_spec *ord;
1.11 noro 2375:
1.49 noro 2376:
1.11 noro 2377: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
1.49 noro 2378: f = (LIST)ARG0(arg);
1.25 noro 2379: f = remove_zero_from_list(f);
2380: if ( !BDY(f) ) {
2381: *rp = f; return;
2382: }
1.53 noro 2383: if ( (ac = argc(arg)) == 5 ) {
1.49 noro 2384: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
2385: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
2386: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
2387: v = (LIST)ARG1(arg);
2388: homo = (Num)ARG2(arg);
2389: m = (Q)ARG3(arg);
2390: if ( !m )
2391: modular = 0;
2392: else if ( PL(NM(m))>1 || (PL(NM(m)) == 1 && BD(NM(m))[0] >= 0x80000000) )
2393: error("dp_weyl_gr_main : too large modulus");
2394: else
2395: modular = QTOS(m);
2396: create_order_spec(0,ARG4(arg),&ord);
1.53 noro 2397: } else if ( current_option )
2398: parse_gr_option(f,current_option,&v,&homo,&modular,&ord);
1.49 noro 2399: else if ( ac == 1 )
2400: parse_gr_option(f,0,&v,&homo,&modular,&ord);
1.11 noro 2401: else
1.49 noro 2402: error("dp_weyl_gr_main : invalid argument");
1.12 noro 2403: do_weyl = 1;
1.46 noro 2404: dp_gr_main(f,v,homo,modular,0,ord,rp);
1.16 noro 2405: do_weyl = 0;
2406: }
2407:
2408: void Pdp_weyl_gr_f_main(arg,rp)
2409: NODE arg;
2410: LIST *rp;
2411: {
2412: LIST f,v;
2413: Num homo;
1.46 noro 2414: struct order_spec *ord;
1.16 noro 2415:
2416: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_main");
2417: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_main");
2418: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_main");
2419: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_main");
2420: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2421: f = remove_zero_from_list(f);
2422: if ( !BDY(f) ) {
2423: *rp = f; return;
2424: }
1.16 noro 2425: homo = (Num)ARG2(arg);
1.46 noro 2426: create_order_spec(0,ARG3(arg),&ord);
1.16 noro 2427: do_weyl = 1;
1.46 noro 2428: dp_gr_main(f,v,homo,0,1,ord,rp);
1.12 noro 2429: do_weyl = 0;
1.11 noro 2430: }
2431:
2432: void Pdp_weyl_f4_main(arg,rp)
2433: NODE arg;
2434: LIST *rp;
2435: {
2436: LIST f,v;
1.46 noro 2437: struct order_spec *ord;
1.11 noro 2438:
2439: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
2440: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
2441: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2442: f = remove_zero_from_list(f);
2443: if ( !BDY(f) ) {
2444: *rp = f; return;
2445: }
1.46 noro 2446: create_order_spec(0,ARG2(arg),&ord);
1.12 noro 2447: do_weyl = 1;
1.46 noro 2448: dp_f4_main(f,v,ord,rp);
1.12 noro 2449: do_weyl = 0;
1.11 noro 2450: }
2451:
2452: void Pdp_weyl_f4_mod_main(arg,rp)
2453: NODE arg;
2454: LIST *rp;
2455: {
2456: LIST f,v;
2457: int m;
1.46 noro 2458: struct order_spec *ord;
1.11 noro 2459:
2460: asir_assert(ARG0(arg),O_LIST,"dp_weyl_f4_main");
2461: asir_assert(ARG1(arg),O_LIST,"dp_weyl_f4_main");
2462: asir_assert(ARG2(arg),O_N,"dp_f4_main");
2463: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg); m = QTOS((Q)ARG2(arg));
1.25 noro 2464: f = remove_zero_from_list(f);
2465: if ( !BDY(f) ) {
2466: *rp = f; return;
2467: }
1.20 noro 2468: if ( !m )
2469: error("dp_weyl_f4_mod_main : invalid argument");
1.46 noro 2470: create_order_spec(0,ARG3(arg),&ord);
1.12 noro 2471: do_weyl = 1;
1.46 noro 2472: dp_f4_mod_main(f,v,m,ord,rp);
1.12 noro 2473: do_weyl = 0;
1.11 noro 2474: }
2475:
2476: void Pdp_weyl_gr_mod_main(arg,rp)
2477: NODE arg;
2478: LIST *rp;
2479: {
2480: LIST f,v;
2481: Num homo;
2482: int m;
1.46 noro 2483: struct order_spec *ord;
1.11 noro 2484:
2485: asir_assert(ARG0(arg),O_LIST,"dp_weyl_gr_mod_main");
2486: asir_assert(ARG1(arg),O_LIST,"dp_weyl_gr_mod_main");
2487: asir_assert(ARG2(arg),O_N,"dp_weyl_gr_mod_main");
2488: asir_assert(ARG3(arg),O_N,"dp_weyl_gr_mod_main");
1.8 noro 2489: f = (LIST)ARG0(arg); v = (LIST)ARG1(arg);
1.25 noro 2490: f = remove_zero_from_list(f);
2491: if ( !BDY(f) ) {
2492: *rp = f; return;
2493: }
1.8 noro 2494: homo = (Num)ARG2(arg); m = QTOS((Q)ARG3(arg));
1.20 noro 2495: if ( !m )
2496: error("dp_weyl_gr_mod_main : invalid argument");
1.46 noro 2497: create_order_spec(0,ARG4(arg),&ord);
1.12 noro 2498: do_weyl = 1;
1.46 noro 2499: dp_gr_mod_main(f,v,homo,m,ord,rp);
1.12 noro 2500: do_weyl = 0;
1.1 noro 2501: }
1.8 noro 2502:
1.57 noro 2503: VECT current_dl_weight_vector_obj;
1.24 noro 2504: int *current_dl_weight_vector;
2505:
2506: void Pdp_set_weight(arg,rp)
2507: NODE arg;
2508: VECT *rp;
2509: {
2510: VECT v;
2511: int i,n;
1.45 noro 2512: NODE node;
1.24 noro 2513:
2514: if ( !arg )
2515: *rp = current_dl_weight_vector_obj;
2516: else if ( !ARG0(arg) ) {
2517: current_dl_weight_vector_obj = 0;
2518: current_dl_weight_vector = 0;
2519: *rp = 0;
2520: } else {
1.45 noro 2521: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
2522: error("dp_set_weight : invalid argument");
2523: if ( OID(ARG0(arg)) == O_VECT )
2524: v = (VECT)ARG0(arg);
2525: else {
2526: node = (NODE)BDY((LIST)ARG0(arg));
2527: n = length(node);
2528: MKVECT(v,n);
2529: for ( i = 0; i < n; i++, node = NEXT(node) )
2530: BDY(v)[i] = BDY(node);
2531: }
1.24 noro 2532: current_dl_weight_vector_obj = v;
2533: n = v->len;
2534: current_dl_weight_vector = (int *)CALLOC(n,sizeof(int));
2535: for ( i = 0; i < n; i++ )
2536: current_dl_weight_vector[i] = QTOS((Q)v->body[i]);
2537: *rp = v;
2538: }
2539: }
2540:
1.77 noro 2541: VECT current_module_weight_vector_obj;
2542: int *current_module_weight_vector;
2543:
2544: void Pdp_set_module_weight(arg,rp)
2545: NODE arg;
2546: VECT *rp;
2547: {
2548: VECT v;
2549: int i,n;
2550: NODE node;
2551:
2552: if ( !arg )
2553: *rp = current_module_weight_vector_obj;
2554: else if ( !ARG0(arg) ) {
2555: current_module_weight_vector_obj = 0;
2556: current_module_weight_vector = 0;
2557: *rp = 0;
2558: } else {
2559: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
2560: error("dp_module_set_weight : invalid argument");
2561: if ( OID(ARG0(arg)) == O_VECT )
2562: v = (VECT)ARG0(arg);
2563: else {
2564: node = (NODE)BDY((LIST)ARG0(arg));
2565: n = length(node);
2566: MKVECT(v,n);
2567: for ( i = 0; i < n; i++, node = NEXT(node) )
2568: BDY(v)[i] = BDY(node);
2569: }
2570: current_module_weight_vector_obj = v;
2571: n = v->len;
2572: current_module_weight_vector = (int *)CALLOC(n,sizeof(int));
2573: for ( i = 0; i < n; i++ )
2574: current_module_weight_vector[i] = QTOS((Q)v->body[i]);
2575: *rp = v;
2576: }
2577: }
2578:
1.71 noro 2579: VECT current_top_weight_vector_obj;
2580: N *current_top_weight_vector;
2581:
2582: void Pdp_set_top_weight(arg,rp)
2583: NODE arg;
2584: VECT *rp;
2585: {
2586: VECT v;
2587: int i,n;
2588: NODE node;
2589:
2590: if ( !arg )
2591: *rp = current_top_weight_vector_obj;
2592: else if ( !ARG0(arg) ) {
2593: current_top_weight_vector = 0;
2594: current_top_weight_vector_obj = 0;
2595: *rp = 0;
2596: } else {
2597: if ( OID(ARG0(arg)) != O_VECT && OID(ARG0(arg)) != O_LIST )
2598: error("dp_set_top_weight : invalid argument");
2599: if ( OID(ARG0(arg)) == O_VECT )
2600: v = (VECT)ARG0(arg);
2601: else {
2602: node = (NODE)BDY((LIST)ARG0(arg));
2603: n = length(node);
2604: MKVECT(v,n);
2605: for ( i = 0; i < n; i++, node = NEXT(node) )
2606: BDY(v)[i] = BDY(node);
2607: }
2608: for ( i = 0; i < v->len; i++ )
1.74 noro 2609: if ( !INT(BDY(v)[i]) || (BDY(v)[i] && SGN((Q)BDY(v)[i]) < 0) )
1.71 noro 2610: error("dp_set_top_weight : each element must be a non-negative integer");
2611: current_top_weight_vector_obj = v;
2612: current_top_weight_vector = (N *)MALLOC(v->len*sizeof(N));
2613: for ( i = 0; i < v->len; i++ ) {
1.74 noro 2614: current_top_weight_vector[i] = !BDY(v)[i]?0:NM((Q)BDY(v)[i]);
1.71 noro 2615: }
2616: *rp = current_top_weight_vector_obj;
2617: }
2618: }
2619:
1.72 noro 2620: LIST get_denomlist();
2621:
2622: void Pdp_get_denomlist(LIST *rp)
2623: {
2624: *rp = get_denomlist();
2625: }
2626:
1.24 noro 2627: static VECT current_weyl_weight_vector_obj;
2628: int *current_weyl_weight_vector;
1.15 noro 2629:
2630: void Pdp_weyl_set_weight(arg,rp)
2631: NODE arg;
2632: VECT *rp;
2633: {
2634: VECT v;
2635: int i,n;
2636:
2637: if ( !arg )
1.24 noro 2638: *rp = current_weyl_weight_vector_obj;
1.78 noro 2639: else if ( !ARG0(arg) ) {
2640: current_weyl_weight_vector_obj = 0;
2641: current_weyl_weight_vector = 0;
2642: *rp = 0;
2643: } else {
1.15 noro 2644: asir_assert(ARG0(arg),O_VECT,"dp_weyl_set_weight");
2645: v = (VECT)ARG0(arg);
1.24 noro 2646: current_weyl_weight_vector_obj = v;
1.15 noro 2647: n = v->len;
1.24 noro 2648: current_weyl_weight_vector = (int *)CALLOC(n,sizeof(int));
1.15 noro 2649: for ( i = 0; i < n; i++ )
1.24 noro 2650: current_weyl_weight_vector[i] = QTOS((Q)v->body[i]);
1.15 noro 2651: *rp = v;
2652: }
1.25 noro 2653: }
2654:
1.82 noro 2655: NODE mono_raddec(NODE ideal);
2656:
2657: void Pdp_mono_raddec(NODE arg,LIST *rp)
2658: {
2659: NODE ideal,rd,t,t1,r,r1,u;
2660: VL vl0,vl;
2661: int nv,i,bpi;
2662: int *s;
2663: DP dp;
2664: P *v;
2665: LIST l;
2666:
2667: ideal = BDY((LIST)ARG0(arg));
2668: if ( !ideal ) *rp = (LIST)ARG0(arg);
2669: else {
2670: t = BDY((LIST)ARG1(arg));
2671: nv = length(t);
2672: v = (P)MALLOC(nv*sizeof(P));
2673: for ( vl0 = 0, i = 0; t; t = NEXT(t), i++ ) {
2674: NEXTVL(vl0,vl); VR(vl) = VR((P)BDY(t));
2675: MKV(VR(vl),v[i]);
2676: }
2677: if ( vl0 ) NEXT(vl) = 0;
2678: for ( t = 0, r = ideal; r; r = NEXT(r) ) {
2679: ptod(CO,vl0,BDY(r),&dp); MKNODE(t1,dp,t); t = t1;
2680: }
2681: rd = mono_raddec(t);
2682: r = 0;
2683: bpi = (sizeof(int)/sizeof(char))*8;
2684: for ( u = rd; u; u = NEXT(u) ) {
2685: s = (int *)BDY(u);
2686: for ( i = nv-1, t = 0; i >= 0; i-- )
2687: if ( s[i/bpi]&(1<<(i%bpi)) ) {
2688: MKNODE(t1,v[i],t); t = t1;
2689: }
2690: MKLIST(l,t); MKNODE(r1,l,r); r = r1;
2691: }
2692: MKLIST(*rp,r);
2693: }
2694: }
2695:
1.25 noro 2696: LIST remove_zero_from_list(LIST l)
2697: {
2698: NODE n,r0,r;
2699: LIST rl;
2700:
2701: asir_assert(l,O_LIST,"remove_zero_from_list");
2702: n = BDY(l);
2703: for ( r0 = 0; n; n = NEXT(n) )
2704: if ( BDY(n) ) {
2705: NEXTNODE(r0,r);
2706: BDY(r) = BDY(n);
2707: }
2708: if ( r0 )
2709: NEXT(r) = 0;
2710: MKLIST(rl,r0);
2711: return rl;
1.26 noro 2712: }
2713:
2714: int get_field_type(P p)
2715: {
2716: int type,t;
2717: DCP dc;
2718:
2719: if ( !p )
2720: return 0;
2721: else if ( NUM(p) )
2722: return NID((Num)p);
2723: else {
2724: type = 0;
2725: for ( dc = DC(p); dc; dc = NEXT(dc) ) {
2726: t = get_field_type(COEF(dc));
2727: if ( !t )
2728: continue;
2729: if ( t < 0 )
2730: return t;
2731: if ( !type )
2732: type = t;
2733: else if ( t != type )
2734: return -1;
2735: }
2736: return type;
1.52 noro 2737: }
2738: }
2739:
2740: void Pdpv_ord(NODE arg,Obj *rp)
2741: {
2742: int ac,id;
2743: LIST shift;
2744:
2745: ac = argc(arg);
2746: if ( ac ) {
2747: id = QTOS((Q)ARG0(arg));
2748: if ( ac > 1 && ARG1(arg) && OID((Obj)ARG1(arg))==O_LIST )
2749: shift = (LIST)ARG1(arg);
2750: else
2751: shift = 0;
2752: create_modorder_spec(id,shift,&dp_current_modspec);
2753: }
2754: *rp = dp_current_modspec->obj;
2755: }
2756:
2757: void Pdpv_ht(NODE arg,LIST *rp)
2758: {
2759: NODE n;
2760: DP ht;
2761: int pos;
2762: DPV p;
2763: Q q;
2764:
2765: asir_assert(ARG0(arg),O_DPV,"dpv_ht");
2766: p = (DPV)ARG0(arg);
2767: pos = dpv_hp(p);
2768: if ( pos < 0 )
2769: ht = 0;
2770: else
2771: dp_ht(BDY(p)[pos],&ht);
2772: STOQ(pos,q);
2773: n = mknode(2,q,ht);
2774: MKLIST(*rp,n);
2775: }
2776:
2777: void Pdpv_hm(NODE arg,LIST *rp)
2778: {
2779: NODE n;
2780: DP ht;
2781: int pos;
2782: DPV p;
2783: Q q;
2784:
2785: asir_assert(ARG0(arg),O_DPV,"dpv_hm");
2786: p = (DPV)ARG0(arg);
2787: pos = dpv_hp(p);
2788: if ( pos < 0 )
2789: ht = 0;
2790: else
2791: dp_hm(BDY(p)[pos],&ht);
2792: STOQ(pos,q);
2793: n = mknode(2,q,ht);
2794: MKLIST(*rp,n);
2795: }
2796:
2797: void Pdpv_hc(NODE arg,LIST *rp)
2798: {
2799: NODE n;
2800: P hc;
2801: int pos;
2802: DPV p;
2803: Q q;
2804:
2805: asir_assert(ARG0(arg),O_DPV,"dpv_hc");
2806: p = (DPV)ARG0(arg);
2807: pos = dpv_hp(p);
2808: if ( pos < 0 )
2809: hc = 0;
2810: else
2811: hc = BDY(BDY(p)[pos])->c;
2812: STOQ(pos,q);
2813: n = mknode(2,q,hc);
2814: MKLIST(*rp,n);
2815: }
2816:
2817: int dpv_hp(DPV p)
2818: {
2819: int len,i,maxp,maxw,w,slen;
2820: int *shift;
2821: DP *e;
2822:
2823: len = p->len;
2824: e = p->body;
2825: slen = dp_current_modspec->len;
2826: shift = dp_current_modspec->degree_shift;
2827: switch ( dp_current_modspec->id ) {
2828: case ORD_REVGRADLEX:
2829: for ( maxp = -1, i = 0; i < len; i++ )
2830: if ( !e[i] ) continue;
2831: else if ( maxp < 0 ) {
2832: maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
2833: } else {
2834: w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
2835: if ( w >= maxw ) {
2836: maxw = w; maxp = i;
2837: }
2838: }
2839: return maxp;
2840: case ORD_GRADLEX:
2841: for ( maxp = -1, i = 0; i < len; i++ )
2842: if ( !e[i] ) continue;
2843: else if ( maxp < 0 ) {
2844: maxw = BDY(e[i])->dl->td+(i<slen?shift[i]:0); maxp = i;
2845: } else {
2846: w = BDY(e[i])->dl->td+(i<slen?shift[i]:0);
2847: if ( w > maxw ) {
2848: maxw = w; maxp = i;
2849: }
2850: }
2851: return maxp;
2852: break;
2853: case ORD_LEX:
2854: for ( i = 0; i < len; i++ )
2855: if ( e[i] ) return i;
2856: return -1;
2857: break;
1.26 noro 2858: }
1.15 noro 2859: }
1.81 noro 2860:
2861: int get_opt(char *key0,Obj *r) {
2862: NODE tt,p;
2863: char *key;
2864:
2865: if ( current_option ) {
2866: for ( tt = current_option; tt; tt = NEXT(tt) ) {
2867: p = BDY((LIST)BDY(tt));
2868: key = BDY((STRING)BDY(p));
2869: /* value = (Obj)BDY(NEXT(p)); */
2870: if ( !strcmp(key,key0) ) {
2871: *r = (Obj)BDY(NEXT(p));
2872: return 1;
2873: }
2874: }
2875: }
2876: return 0;
2877: }
2878:
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