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