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