![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to strobj.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / builtin|
Return to strobj.c CVS log | Up to [local] / OpenXM_contrib2 / asir2000 / builtin |
1.6 noro 1: /*
2: * Copyright (c) 1994-2000 FUJITSU LABORATORIES LIMITED
3: * All rights reserved.
4: *
5: * FUJITSU LABORATORIES LIMITED ("FLL") hereby grants you a limited,
6: * non-exclusive and royalty-free license to use, copy, modify and
7: * redistribute, solely for non-commercial and non-profit purposes, the
8: * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and
9: * conditions of this Agreement. For the avoidance of doubt, you acquire
10: * only a limited right to use the SOFTWARE hereunder, and FLL or any
11: * third party developer retains all rights, including but not limited to
12: * copyrights, in and to the SOFTWARE.
13: *
14: * (1) FLL does not grant you a license in any way for commercial
15: * purposes. You may use the SOFTWARE only for non-commercial and
16: * non-profit purposes only, such as academic, research and internal
17: * business use.
18: * (2) The SOFTWARE is protected by the Copyright Law of Japan and
19: * international copyright treaties. If you make copies of the SOFTWARE,
20: * with or without modification, as permitted hereunder, you shall affix
21: * to all such copies of the SOFTWARE the above copyright notice.
22: * (3) An explicit reference to this SOFTWARE and its copyright owner
23: * shall be made on your publication or presentation in any form of the
24: * results obtained by use of the SOFTWARE.
25: * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.7 noro 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.6 noro 27: * for such modification or the source code of the modified part of the
28: * SOFTWARE.
29: *
30: * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
31: * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
32: * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
33: * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
34: * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
35: * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
36: * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
37: * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
38: * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
39: * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
40: * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
41: * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
42: * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
43: * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
44: * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
45: * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
46: * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
47: *
1.108 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.107 2005/12/11 05:27:30 noro Exp $
1.6 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "parse.h"
52: #include "ctype.h"
1.10 ohara 53: #if defined(PARI)
1.1 noro 54: #include "genpari.h"
1.11 saito 55: # if !(PARI_VERSION_CODE > 131588)
1.1 noro 56: extern jmp_buf environnement;
1.11 saito 57: # endif
1.1 noro 58: #endif
1.5 noro 59: #include <string.h>
60:
1.89 noro 61: #if defined(__GNUC__)
62: #define INLINE inline
63: #elif defined(VISUAL)
64: #define INLINE __inline
65: #else
66: #define INLINE
67: #endif
68:
1.18 noro 69: struct TeXSymbol {
70: char *text;
71: char *symbol;
72: };
73:
1.71 noro 74: #define OPNAME(f) (((ARF)FA0(f))->name[0])
1.77 noro 75: #define IS_ZERO(f) (((f)->id==I_FORMULA) && FA0(f)==0 )
1.75 noro 76: #define IS_BINARYPWR(f) (((f)->id==I_BOP) &&(OPNAME(f)=='^'))
77: #define IS_NARYADD(f) (((f)->id==I_NARYOP) &&(OPNAME(f)=='+'))
78: #define IS_NARYMUL(f) (((f)->id==I_NARYOP) &&(OPNAME(f)=='*'))
1.71 noro 79:
1.1 noro 80: extern char *parse_strp;
81:
1.50 ohara 82: void Psprintf();
1.1 noro 83: void Prtostr(), Pstrtov(), Peval_str();
1.3 noro 84: void Pstrtoascii(), Pasciitostr();
1.5 noro 85: void Pstr_len(), Pstr_chr(), Psub_str();
1.14 noro 86: void Pwrite_to_tb();
87: void Ptb_to_string();
88: void Pclear_tb();
89: void Pstring_to_tb();
90: void Pquotetotex_tb();
91: void Pquotetotex();
1.24 noro 92: void Pquotetotex_env();
1.47 noro 93: void Pflatten_quote();
1.69 noro 94:
1.108 ! noro 95: void Pqt_is_integer(),Pqt_is_rational(),Pqt_is_number(),Pqt_is_coef();
! 96: void Pqt_is_dependent(),Pqt_is_function(),Pqt_is_var();
! 97: void Pqt_set_ord(),Pqt_set_coef();
1.105 noro 98: void Pqt_normalize();
99: void Pnqt_comp();
100: void Pnqt_match();
1.106 noro 101: void Pnqt_match_rewrite();
1.69 noro 102:
1.105 noro 103: void Pqt_to_nbp();
1.101 noro 104: void Pshuffle_mul(), Pharmonic_mul();
1.102 noro 105: void Pnbp_hm(), Pnbp_ht(), Pnbp_hc(), Pnbp_rest();
106: void Pnbm_deg();
107: void Pnbm_hp_rest();
108: void Pnbm_hxky(), Pnbm_xky_rest();
109: void Pnbm_hv(), Pnbm_rest();
1.98 noro 110:
1.52 noro 111: void Pquote_to_funargs(),Pfunargs_to_quote(),Pget_function_name();
1.107 noro 112: void Pqt_match(),Pget_quote_id();
1.105 noro 113: void Pqt_to_nary(),Pqt_to_bin();
1.88 noro 114: void fnode_do_assign(NODE arg);
1.58 ohara 115: void do_assign(NODE arg);
1.14 noro 116: void fnodetotex_tb(FNODE f,TB tb);
117: char *symbol_name(char *name);
1.28 noro 118: char *conv_rule(char *name);
1.38 noro 119: char *conv_subs(char *name);
1.28 noro 120: char *call_convfunc(char *name);
1.14 noro 121: void tb_to_string(TB tb,STRING *rp);
122: void fnodenodetotex_tb(NODE n,TB tb);
123: void fargstotex_tb(char *opname,FNODE f,TB tb);
1.35 noro 124: int top_is_minus(FNODE f);
1.105 noro 125: int qt_match(Obj f,Obj pat,NODE *rp);
1.106 noro 126: FNODE partial_eval(FNODE), fnode_to_nary(FNODE), fnode_to_bin(FNODE,int);
127: FNODE nfnode_add(FNODE a1,FNODE a2,int expand);
128: FNODE nfnode_mul(FNODE a1,FNODE a2,int expand);
129: FNODE nfnode_pwr(FNODE a1,FNODE a2,int expand);
1.108 ! noro 130: FNODE nfnode_mul_coef(Obj c,FNODE f,int expand);
1.106 noro 131: FNODE fnode_expand_pwr(FNODE f,int n,int expand);
132: FNODE to_narymul(FNODE f);
133: FNODE to_naryadd(FNODE f);
134: FNODE fnode_node_to_nary(ARF op,NODE n);
135: void fnode_base_exp(FNODE f,FNODE *bp,FNODE *ep);
1.108 ! noro 136: void fnode_coef_body(FNODE f,Obj *cp,FNODE *bp);
1.106 noro 137: FNODE nfnode_match_rewrite(FNODE f,FNODE p,FNODE c,FNODE a,int mode);
138: FNODE fnode_apply(FNODE f,FNODE (*func)(),int expand);
139: FNODE fnode_normalize(FNODE f,int expand);
1.107 noro 140: FNODE rewrite_fnode(FNODE f,NODE arg,int qarg);
1.1 noro 141:
142: struct ftab str_tab[] = {
1.50 ohara 143: {"sprintf",Psprintf,-99999999},
1.1 noro 144: {"rtostr",Prtostr,1},
145: {"strtov",Pstrtov,1},
146: {"eval_str",Peval_str,1},
1.3 noro 147: {"strtoascii",Pstrtoascii,1},
148: {"asciitostr",Pasciitostr,1},
1.5 noro 149: {"str_len",Pstr_len,1},
150: {"str_chr",Pstr_chr,3},
151: {"sub_str",Psub_str,3},
1.14 noro 152: {"write_to_tb",Pwrite_to_tb,2},
153: {"clear_tb",Pclear_tb,1},
154: {"tb_to_string",Ptb_to_string,1},
155: {"string_to_tb",Pstring_to_tb,1},
1.63 noro 156: {"get_quote_id",Pget_quote_id,1},
1.69 noro 157:
1.108 ! noro 158: {"qt_is_var",Pqt_is_var,1},
! 159: {"qt_is_coef",Pqt_is_coef,1},
1.105 noro 160: {"qt_is_number",Pqt_is_number,1},
161: {"qt_is_rational",Pqt_is_rational,1},
162: {"qt_is_integer",Pqt_is_integer,1},
163: {"qt_is_function",Pqt_is_function,1},
164: {"qt_is_dependent",Pqt_is_dependent,2},
165:
1.108 ! noro 166: {"qt_set_coef",Pqt_set_coef,-1},
1.105 noro 167: {"qt_set_ord",Pqt_set_ord,-1},
168: {"qt_normalize",Pqt_normalize,-2},
169: {"qt_match",Pqt_match,2},
1.106 noro 170: {"nqt_match_rewrite",Pnqt_match_rewrite,3},
1.105 noro 171:
172: {"nqt_comp",Pnqt_comp,2},
173: {"nqt_match",Pnqt_match,-3},
174: {"qt_to_nbp",Pqt_to_nbp,1},
1.101 noro 175: {"shuffle_mul",Pshuffle_mul,2},
176: {"harmonic_mul",Pharmonic_mul,2},
1.70 noro 177:
1.100 noro 178: {"nbp_hm", Pnbp_hm,1},
179: {"nbp_ht", Pnbp_ht,1},
180: {"nbp_hc", Pnbp_hc,1},
181: {"nbp_rest", Pnbp_rest,1},
1.102 noro 182: {"nbm_deg", Pnbm_deg,1},
183: {"nbm_hxky", Pnbm_hxky,1},
184: {"nbm_xky_rest", Pnbm_xky_rest,1},
185: {"nbm_hp_rest", Pnbm_hp_rest,1},
186: {"nbm_hv", Pnbm_hv,1},
1.100 noro 187: {"nbm_rest", Pnbm_rest,1},
188:
1.105 noro 189: {"qt_to_nary",Pqt_to_nary,1},
190: {"qt_to_bin",Pqt_to_bin,2},
1.95 noro 191:
1.60 noro 192: {"quotetotex_tb",Pquotetotex_tb,2},
193: {"quotetotex",Pquotetotex,1},
194: {"quotetotex_env",Pquotetotex_env,-99999999},
1.65 noro 195: {"flatten_quote",Pflatten_quote,-2},
1.60 noro 196: {"quote_to_funargs",Pquote_to_funargs,1},
1.48 noro 197: {"funargs_to_quote",Pfunargs_to_quote,1},
1.52 noro 198: {"get_function_name",Pget_function_name,1},
1.1 noro 199: {0,0,0},
200: };
1.13 noro 201:
1.14 noro 202: void write_tb(char *s,TB tb)
203: {
204: if ( tb->next == tb->size ) {
205: tb->size *= 2;
206: tb->body = (char **)REALLOC(tb->body,tb->size*sizeof(char *));
207: }
208: tb->body[tb->next] = s;
209: tb->next++;
210: }
1.13 noro 211:
1.18 noro 212: int register_symbol_table(Obj arg);
213: int register_conv_rule(Obj arg);
1.38 noro 214: int register_conv_func(Obj arg);
1.23 noro 215: int register_dp_vars(Obj arg);
1.46 noro 216: int register_dp_vars_origin(Obj arg);
217: int register_dp_dvars_origin(Obj arg);
218: int register_dp_dvars_prefix(Obj arg);
1.25 noro 219: int register_dp_vars_prefix(Obj arg);
1.31 noro 220: int register_dp_vars_hweyl(Obj arg);
1.27 noro 221: int register_show_lt(Obj arg);
1.40 noro 222: char *objtostr(Obj obj);
1.18 noro 223: static struct TeXSymbol *user_texsymbol;
1.23 noro 224: static char **dp_vars;
1.25 noro 225: static int dp_vars_len;
226: static char *dp_vars_prefix;
1.46 noro 227: static char *dp_dvars_prefix;
228: static int dp_vars_origin;
229: static int dp_dvars_origin;
1.27 noro 230: static int show_lt;
1.26 noro 231: static FUNC convfunc;
1.27 noro 232: static int is_lt;
1.28 noro 233: static int conv_flag;
1.31 noro 234: static int dp_vars_hweyl;
1.28 noro 235:
1.38 noro 236: #define CONV_TABLE (1U<<0)
237: #define CONV_SUBS (1U<<1)
238: #define CONV_DMODE (1U<<2)
1.18 noro 239:
240: static struct {
241: char *name;
242: Obj value;
243: int (*reg)();
244: } qtot_env[] = {
245: {"symbol_table",0,register_symbol_table},
246: {"conv_rule",0,register_conv_rule},
1.38 noro 247: {"conv_func",0,register_conv_func},
1.23 noro 248: {"dp_vars",0,register_dp_vars},
1.25 noro 249: {"dp_vars_prefix",0,register_dp_vars_prefix},
1.46 noro 250: {"dp_dvars_prefix",0,register_dp_dvars_prefix},
251: {"dp_vars_origin",0,register_dp_vars_origin},
252: {"dp_dvars_origin",0,register_dp_dvars_origin},
1.31 noro 253: {"dp_vars_hweyl",0,register_dp_vars_hweyl},
1.27 noro 254: {"show_lt",0,register_show_lt},
1.18 noro 255: {0,0,0},
256: };
257:
1.20 noro 258: #define PARTIAL "\\partial"
1.28 noro 259:
260: char *conv_rule(char *name)
261: {
262: char *body,*r;
1.41 noro 263: int len;
1.28 noro 264:
1.38 noro 265: if ( convfunc )
266: name = call_convfunc(name);
1.41 noro 267: if ( conv_flag & CONV_TABLE ) {
268: r = symbol_name(name);
269: if ( r ) return r;
270: }
271: if ( (conv_flag & CONV_DMODE) && *name == 'd' ) {
272: body = conv_rule(name+1);
273: r = MALLOC_ATOMIC((strlen(PARTIAL)+strlen(body)+5)*sizeof(char));
274: if ( !body || !(len=strlen(body)) )
275: strcpy(r,PARTIAL);
276: else if ( len == 1 )
277: sprintf(r,"%s_%s",PARTIAL,body);
278: else
279: sprintf(r,"%s_{%s}",PARTIAL,body);
280: return r;
281: } else
282: return conv_subs(name);
1.28 noro 283: }
284:
1.40 noro 285: int _is_delimiter(char c)
286: {
287: if ( (c == ' ' || c == '_' || c == ',') ) return 1;
288: else return 0;
289: }
290:
291: int _is_alpha(char c)
292: {
293: if ( isdigit(c) || c == '{' || _is_delimiter(c) ) return 0;
294: else return 1;
295: }
296:
1.38 noro 297: char *conv_subs(char *name)
1.19 noro 298: {
1.29 noro 299: int i,j,k,len,clen,slen,start,level;
1.41 noro 300: char *buf,*head,*r,*h,*brace,*buf_conv;
1.28 noro 301: char **subs;
302:
1.41 noro 303: if ( !name || !(len=strlen(name)) ) return "";
304: if ( !(conv_flag&CONV_SUBS) ) return name;
1.28 noro 305: subs = (char **)ALLOCA(len*sizeof(char* ));
1.32 noro 306: for ( i = 0, j = 0, start = i; ; j++ ) {
1.40 noro 307: while ( (i < len) && _is_delimiter(name[i]) ) i++;
1.32 noro 308: start = i;
1.28 noro 309: if ( i == len ) break;
1.29 noro 310: if ( name[i] == '{' ) {
311: for ( level = 1, i++; i < len && level; i++ ) {
312: if ( name[i] == '{' ) level++;
313: else if ( name[i] == '}' ) level--;
314: }
1.32 noro 315: slen = i-start;
1.37 noro 316: if ( slen >= 3 ) {
317: brace = (char *)ALLOCA((slen+1)*sizeof(char));
318: strncpy(brace,name+start+1,slen-2);
319: brace[slen-2] = 0;
1.38 noro 320: buf = conv_subs(brace);
1.37 noro 321: subs[j] = (char *)ALLOCA((strlen(buf)+3)*sizeof(char));
1.38 noro 322: if ( strlen(buf) == 1 )
323: strcpy(subs[j],buf);
324: else
325: sprintf(subs[j],"{%s}",buf);
1.37 noro 326: } else
327: subs[j] = "{}";
1.32 noro 328: } else {
329: if ( isdigit(name[i]) )
330: while ( i < len && isdigit(name[i]) ) i++;
331: else
1.40 noro 332: while ( i < len && _is_alpha(name[i]) ) i++;
1.32 noro 333: slen = i-start;
334: buf = (char *)ALLOCA((slen+1)*sizeof(char));
335: strncpy(buf,name+start,slen); buf[slen] = 0;
1.41 noro 336: buf_conv = symbol_name(buf);
337: subs[j] = buf_conv?buf_conv:buf;
1.32 noro 338: }
1.28 noro 339: }
1.32 noro 340: for ( k = 0, clen = 0; k < j; k++ ) clen += strlen(subs[k]);
341: /* {subs(0)}_{{subs(1)},...,{subs(j-1)}} => {}:j+1 _:1 ,:j-2 */
342: h = r = MALLOC_ATOMIC((clen+(j+1)*2+1+(j-2)+1)*sizeof(char));
343: if ( j == 1 )
344: sprintf(h,"{%s}",subs[0]);
1.28 noro 345: else {
1.38 noro 346: sprintf(h,"{%s}_{%s",subs[0],subs[1]);
1.28 noro 347: h += strlen(h);
1.32 noro 348: for ( k = 2; k < j; k++ ) {
1.38 noro 349: sprintf(h,",%s",subs[k]);
1.28 noro 350: h += strlen(h);
1.19 noro 351: }
1.28 noro 352: strcpy(h,"}");
1.20 noro 353: }
354: return r;
1.19 noro 355: }
356:
1.26 noro 357: char *call_convfunc(char *name)
358: {
359: STRING str,r;
360: NODE arg;
361:
362: MKSTR(str,name);
363: arg = mknode(1,str);
364: r = (STRING)bevalf(convfunc,arg);
365: if ( !r || OID(r) != O_STR )
366: error("call_convfunc : invalid result");
367: return BDY(r);
368: }
369:
1.18 noro 370: int register_symbol_table(Obj arg)
371: {
372: NODE n,t;
373: Obj b;
374: STRING a0,a1;
375: struct TeXSymbol *uts;
376: int i,len;
377:
378: /* check */
379: if ( !arg ) {
380: user_texsymbol = 0;
381: return 1;
382: }
383: if ( OID(arg) != O_LIST ) return 0;
384:
385: n = BDY((LIST)arg);
386: len = length(n);
387: uts = (struct TeXSymbol *)MALLOC((len+1)*sizeof(struct TeXSymbol));
388: for ( i = 0; n; n = NEXT(n), i++ ) {
389: b = (Obj)BDY(n);
390: if ( !b || OID(b) != O_LIST ) return 0;
391: t = BDY((LIST)b);
392: if ( !t || !NEXT(t) ) return 0;
393: a0 = (STRING)BDY(t);
394: a1 = (STRING)BDY(NEXT(t));
1.23 noro 395: if ( !a0 ) return 0;
396: if ( OID(a0) == O_STR )
397: uts[i].text = BDY(a0);
398: else if ( OID(a0) == O_P )
399: uts[i].text = NAME(VR((P)a0));
400: else
401: return 0;
402: if ( !a1 ) return 0;
403: if ( OID(a1) == O_STR )
404: uts[i].symbol = BDY(a1);
405: else if ( OID(a1) == O_P )
406: uts[i].symbol = NAME(VR((P)a1));
407: else
408: return 0;
1.18 noro 409: }
410: uts[i].text = 0;
411: uts[i].symbol = 0;
412: user_texsymbol = uts;
413: return 1;
414: }
415:
1.46 noro 416: int register_dp_vars_origin(Obj arg)
417: {
418: if ( INT(arg) ) {
419: dp_vars_origin = QTOS((Q)arg);
420: return 1;
421: } else return 0;
422: }
423:
424: int register_dp_dvars_origin(Obj arg)
425: {
426: if ( INT(arg) ) {
427: dp_dvars_origin = QTOS((Q)arg);
428: return 1;
429: } else return 0;
430: }
431:
1.31 noro 432: int register_dp_vars_hweyl(Obj arg)
433: {
434: if ( INT(arg) ) {
435: dp_vars_hweyl = QTOS((Q)arg);
436: return 1;
437: } else return 0;
438: }
439:
1.27 noro 440: int register_show_lt(Obj arg)
441: {
442: if ( INT(arg) ) {
443: show_lt = QTOS((Q)arg);
444: return 1;
445: } else return 0;
446: }
1.26 noro 447:
1.18 noro 448: int register_conv_rule(Obj arg)
449: {
1.19 noro 450: if ( INT(arg) ) {
1.28 noro 451: conv_flag = QTOS((Q)arg);
452: convfunc = 0;
453: return 1;
1.38 noro 454: } else return 0;
455: }
456:
457: int register_conv_func(Obj arg)
458: {
1.43 noro 459: if ( !arg ) {
460: convfunc = 0;
461: return 1;
462: } else if ( OID(arg) == O_P && (int)(VR((P)arg))->attr == V_SR ) {
1.26 noro 463: convfunc = (FUNC)(VR((P)arg)->priv);
464: /* f must be a function which takes single argument */
465: return 1;
1.19 noro 466: } else return 0;
1.18 noro 467: }
468:
1.23 noro 469: int register_dp_vars(Obj arg)
470: {
471: int l,i;
472: char **r;
473: NODE n;
474: STRING a;
475:
476: if ( !arg ) {
477: dp_vars = 0;
478: dp_vars_len = 0;
1.25 noro 479: return 1;
1.23 noro 480: } else if ( OID(arg) != O_LIST )
481: return 0;
482: else {
483: n = BDY((LIST)arg);
484: l = length(n);
485: r = (char **)MALLOC_ATOMIC(l*sizeof(char *));
486: for ( i = 0; i < l; i++, n = NEXT(n) ) {
487: a = (STRING)BDY(n);
488: if ( !a ) return 0;
489: if ( OID(a) == O_STR )
490: r[i] = BDY(a);
491: else if ( OID(a) == O_P )
492: r[i] = NAME(VR((P)a));
493: else
494: return 0;
495: }
496: dp_vars = r;
497: dp_vars_len = l;
498: return 1;
499: }
500: }
501:
1.25 noro 502: int register_dp_vars_prefix(Obj arg)
503: {
504: if ( !arg ) {
505: dp_vars_prefix = 0;
506: return 1;
507: } else if ( OID(arg) == O_STR ) {
508: dp_vars_prefix = BDY((STRING)arg);
509: return 1;
510: } else if ( OID(arg) == O_P ) {
511: dp_vars_prefix = NAME(VR((P)arg));
512: return 1;
513: } else return 0;
514: }
515:
1.46 noro 516: int register_dp_dvars_prefix(Obj arg)
517: {
518: if ( !arg ) {
519: dp_dvars_prefix = 0;
520: return 1;
521: } else if ( OID(arg) == O_STR ) {
522: dp_dvars_prefix = BDY((STRING)arg);
523: return 1;
524: } else if ( OID(arg) == O_P ) {
525: dp_dvars_prefix = NAME(VR((P)arg));
526: return 1;
527: } else return 0;
528: }
529:
1.24 noro 530: void Pquotetotex_env(NODE arg,Obj *rp)
1.18 noro 531: {
532: int ac,i;
533: char *name;
534: NODE n,n0;
535: STRING s;
536: LIST l;
537:
538: ac = argc(arg);
539: if ( !ac ) {
540: n0 = 0;
541: for ( i = 0; qtot_env[i].name; i++ ) {
542: NEXTNODE(n0,n); MKSTR(s,qtot_env[i].name); BDY(n) = (pointer)s;
543: NEXTNODE(n0,n); BDY(n) = (Q)qtot_env[i].value;
544: }
545: NEXT(n) = 0;
546: MKLIST(l,n0);
547: *rp = (Obj)l;
1.34 noro 548: } else if ( ac == 1 && !ARG0(arg) ) {
549: /* set to default */
1.43 noro 550: for ( i = 0; qtot_env[i].name; i++ ) {
551: (qtot_env[i].reg)(0);
1.34 noro 552: qtot_env[i].value = 0;
1.43 noro 553: }
1.34 noro 554: *rp = 0;
1.18 noro 555: } else if ( ac == 1 || ac == 2 ) {
1.24 noro 556: asir_assert(ARG0(arg),O_STR,"quotetotex_env");
1.18 noro 557: name = BDY((STRING)ARG0(arg));
558: for ( i = 0; qtot_env[i].name; i++ )
559: if ( !strcmp(qtot_env[i].name,name) ) {
560: if ( ac == 2 ) {
561: if ( (qtot_env[i].reg)((Obj)ARG1(arg)) )
562: qtot_env[i].value = (Obj)ARG1(arg);
563: else
1.24 noro 564: error("quotetotex_env : invalid argument");
1.18 noro 565: }
566: *rp = qtot_env[i].value;
567: return;
568: }
569: *rp = 0;
570: } else
571: *rp = 0;
572: }
573:
1.14 noro 574: void Pwrite_to_tb(NODE arg,Q *rp)
1.13 noro 575: {
576: int i;
1.16 noro 577: Obj obj;
578: TB tb;
1.13 noro 579:
1.14 noro 580: asir_assert(ARG1(arg),O_TB,"write_to_tb");
1.16 noro 581: obj = ARG0(arg);
582: if ( !obj )
583: write_tb("",ARG1(arg));
584: else if ( OID(obj) == O_STR )
585: write_tb(BDY((STRING)obj),ARG1(arg));
586: else if ( OID(obj) == O_TB ) {
587: tb = (TB)obj;
588: for ( i = 0; i < tb->next; i++ )
589: write_tb(tb->body[i],ARG1(arg));
590: }
1.14 noro 591: *rp = 0;
1.53 noro 592: }
593:
1.105 noro 594: void Pqt_to_nary(NODE arg,QUOTE *rp)
1.63 noro 595: {
596: FNODE f;
597:
1.70 noro 598: f = fnode_to_nary(BDY((QUOTE)ARG0(arg)));
1.63 noro 599: MKQUOTE(*rp,f);
600: }
601:
1.105 noro 602: void Pqt_to_bin(NODE arg,QUOTE *rp)
1.63 noro 603: {
604: FNODE f;
605: int direction;
606:
607: direction = QTOS((Q)ARG1(arg));
1.70 noro 608: f = fnode_to_bin(BDY((QUOTE)ARG0(arg)),direction);
1.63 noro 609:
610: MKQUOTE(*rp,f);
611: }
1.61 noro 612:
1.108 ! noro 613: void Pqt_is_var(NODE arg,Q *rp)
! 614: {
! 615: QUOTE q;
! 616: int ret;
! 617:
! 618: q = (QUOTE)ARG0(arg);
! 619: asir_assert(q,O_QUOTE,"qt_is_var");
! 620: ret = fnode_is_var(BDY(q));
! 621: STOQ(ret,*rp);
! 622: }
! 623:
! 624: void Pqt_is_coef(NODE arg,Q *rp)
! 625: {
! 626: QUOTE q;
! 627: int ret;
! 628:
! 629: q = (QUOTE)ARG0(arg);
! 630: asir_assert(q,O_QUOTE,"qt_is_coef");
! 631: ret = fnode_is_coef(BDY(q));
! 632: STOQ(ret,*rp);
! 633: }
! 634:
1.105 noro 635: void Pqt_is_number(NODE arg,Q *rp)
1.69 noro 636: {
637: QUOTE q;
638: int ret;
639:
640: q = (QUOTE)ARG0(arg);
1.105 noro 641: asir_assert(q,O_QUOTE,"qt_is_number");
1.69 noro 642: ret = fnode_is_number(BDY(q));
643: STOQ(ret,*rp);
644: }
645:
1.105 noro 646: void Pqt_is_rational(NODE arg,Q *rp)
1.69 noro 647: {
648: QUOTE q;
649: int ret;
650:
651: q = (QUOTE)ARG0(arg);
1.105 noro 652: asir_assert(q,O_QUOTE,"qt_is_rational");
1.69 noro 653: ret = fnode_is_rational(BDY(q));
654: STOQ(ret,*rp);
655: }
656:
1.105 noro 657: void Pqt_is_integer(NODE arg,Q *rp)
1.69 noro 658: {
659: QUOTE q;
660: int ret;
661:
662: q = (QUOTE)ARG0(arg);
1.105 noro 663: asir_assert(q,O_QUOTE,"qt_is_integer");
1.69 noro 664: ret = fnode_is_integer(BDY(q));
665: STOQ(ret,*rp);
666: }
667:
1.105 noro 668: void Pqt_is_function(NODE arg,Q *rp)
1.69 noro 669: {
670: QUOTE q;
671: int ret;
672:
673: q = (QUOTE)ARG0(arg);
1.105 noro 674: asir_assert(q,O_QUOTE,"qt_is_function");
1.69 noro 675: if ( q->id == I_FUNC || q->id == I_IFUNC )
676: ret = 1;
677: else
678: ret = 0;
679: STOQ(ret,*rp);
680: }
681:
1.105 noro 682: void Pqt_is_dependent(NODE arg,Q *rp)
1.69 noro 683: {
684: P x;
685: QUOTE q,v;
686: int ret;
687: V var;
688:
689: q = (QUOTE)ARG0(arg);
690: v = (QUOTE)ARG1(arg);
1.105 noro 691: asir_assert(q,O_QUOTE,"qt_is_dependent");
692: asir_assert(v,O_QUOTE,"qt_is_dependent");
1.69 noro 693: x = (P)eval(BDY(v));
694: if ( !x || OID(x) != O_P )
695: *rp = 0;
696: var = VR(x);
697: ret = fnode_is_dependent(BDY(q),var);
698: STOQ(ret,*rp);
699: }
700:
701:
1.105 noro 702: void Pqt_match(NODE arg,Q *rp)
1.53 noro 703: {
1.61 noro 704: FNODE f,g;
1.65 noro 705: Obj obj;
1.61 noro 706: QUOTE q;
1.53 noro 707: NODE r;
1.56 noro 708: int ret;
1.53 noro 709:
1.65 noro 710: obj = (Obj)ARG0(arg);
1.105 noro 711: ret = qt_match(obj,(Obj)ARG1(arg),&r);
1.57 noro 712: if ( ret ) {
713: do_assign(r);
714: *rp = ONE;
715: } else
1.56 noro 716: *rp = 0;
1.68 noro 717: }
718:
1.105 noro 719: void Pnqt_match(NODE arg,Q *rp)
1.88 noro 720: {
721: QUOTE fq,pq;
722: FNODE f,p;
723: int ret;
1.104 noro 724: Q mode;
1.88 noro 725: NODE r;
726:
1.104 noro 727: mode = argc(arg)==3 ? (Q)ARG2(arg) : 0;
1.105 noro 728: fq = (QUOTE)ARG0(arg); Pqt_normalize(mknode(2,fq,mode),&fq); f = (FNODE)BDY(fq);
729: pq = (QUOTE)ARG1(arg); Pqt_normalize(mknode(2,pq,mode),&pq); p = (FNODE)BDY(pq);
1.95 noro 730: ret = nfnode_match(f,p,&r);
1.88 noro 731: if ( ret ) {
732: fnode_do_assign(r);
733: *rp = ONE;
734: } else
735: *rp = 0;
736: }
737:
1.106 noro 738: void Pnqt_match_rewrite(NODE arg,Obj *rp)
739: {
740: FNODE f,p,c,a,r;
741: Obj obj,pat,cond,action;
742: NODE rule;
743: QUOTE q;
744: Q mode;
745: int m;
746:
747: obj = (Obj)ARG0(arg);
748: rule = BDY((LIST)ARG1(arg));
749: mode = (Q)ARG2(arg);
750: if ( length(rule) == 2 ) {
751: pat = ARG0(rule);
752: cond = (Obj)ONE;
753: action = (Obj)ARG1(rule);
754: } else {
755: pat = ARG0(rule);
756: cond = ARG1(rule);
757: action = (Obj)ARG2(rule);
758: }
759: Pqt_normalize(mknode(2,obj,mode),&q); f = (FNODE)BDY(q);
760: Pqt_normalize(mknode(2,pat,mode),&q); p = (FNODE)BDY(q);
761: Pqt_normalize(mknode(2,action,mode),&q);
762: a = (FNODE)BDY(q);
763: if ( OID(cond) == O_QUOTE ) c = BDY((QUOTE)cond);
764: else c = mkfnode(1,I_FORMULA,ONE);
765:
766: m = QTOS(mode);
767: r = nfnode_match_rewrite(f,p,c,a,m);
768: if ( r ) {
769: MKQUOTE(q,r);
770: *rp = (Obj)q;
771: } else
772: *rp = obj;
773: }
774:
775: /* f is NARYOP => do submatch */
776:
777: #define PV_ANY 99999999
778:
779: FNODE nfnode_match_rewrite(FNODE f,FNODE p,FNODE c,FNODE a,int mode)
780: {
781: ARF op;
782: NODE arg,h0,t,h,valuen;
783: NODE r,s0,s,pair;
1.107 noro 784: FNODE any,pany,head,tail,a1,a2;
1.106 noro 785: QUOTE q;
786: int ret;
787: FNODE value;
788: int ind;
789:
790: if ( f->id == I_NARYOP ) {
791: op = (ARF)FA0(f);
792: arg = (NODE)FA1(f);
793: pany = 0;
794: for ( h0 = 0, t = arg; t; t = NEXT(t) ) {
795: tail = fnode_node_to_nary(op,t);
796: ret = nfnode_match(tail,p,&r) && eval(rewrite_fnode(c,r,1));
797: if ( ret ) break;
798:
799: /* append a variable to the pattern */
800: if ( !pany ) {
801: any = mkfnode(1,I_PVAR,PV_ANY);
802: pany = mkfnode(3,I_BOP,op,p,any);
803: pany = fnode_normalize(pany,mode);
804: }
805: ret = nfnode_match(tail,pany,&r) && eval(rewrite_fnode(c,r,1));
806: if ( ret ) {
807: a = fnode_normalize(mkfnode(3,I_BOP,op,a,any),mode);
808: break;
809: }
810:
811: NEXTNODE(h0,h);
812: BDY(h) = BDY(t);
813: }
814: if ( t ) {
815: if ( h0 ) NEXT(h) = 0;
816: head = fnode_node_to_nary(op,h0);
817: a = fnode_normalize(mkfnode(3,I_BOP,op,head,a),mode);
818: ret = 1;
819: } else
820: ret = 0;
821: } else
822: ret = nfnode_match(f,p,&r) && eval(rewrite_fnode(c,r,1));
823:
824: if ( ret ) {
1.107 noro 825: a1 = rewrite_fnode(a,r,0);
826: a2 = partial_eval(a1);
827: return fnode_normalize(a2,mode);
1.106 noro 828: } else
829: return 0;
830: }
831:
1.56 noro 832: void do_assign(NODE arg)
833: {
834: NODE t,pair;
835: int pv;
836:
837: QUOTE value;
838:
839: for ( t = arg; t; t = NEXT(t) ) {
840: pair = BDY((LIST)BDY(t));
841: pv = (int)FA0((FNODE)BDY((QUOTE)BDY(pair)));
842: value = (QUOTE)(BDY(NEXT(pair)));
843: ASSPV(pv,value);
844: }
1.53 noro 845: }
846:
1.88 noro 847: /* [[index,fnode],...] */
848:
849: void fnode_do_assign(NODE arg)
850: {
851: NODE t,pair;
852: int pv;
853: FNODE f;
854: QUOTE value;
1.95 noro 855: QUOTEARG qa;
1.88 noro 856:
857: for ( t = arg; t; t = NEXT(t) ) {
858: pair = (NODE)BDY(t);
859: pv = (int)BDY(pair);
860: f = (FNODE)(BDY(NEXT(pair)));
1.96 noro 861: if ( f->id == I_FUNC_HEAD ) {
862: /* XXX : I_FUNC_HEAD is a dummy id to pass FUNC */
1.95 noro 863: MKQUOTEARG(qa,A_func,FA0(f));
864: value = (QUOTE)qa;
865: } else
866: MKQUOTE(value,f);
1.88 noro 867: ASSPV(pv,value);
868: }
869: }
870:
1.53 noro 871: /*
1.56 noro 872: /* consistency check and merge
873: */
1.53 noro 874:
1.56 noro 875: int merge_matching_node(NODE n,NODE a,NODE *rp)
1.53 noro 876: {
877: NODE ta,ba,tn,bn;
878: QUOTE pa,va,pn,vn;
879:
1.56 noro 880: if ( !n ) {
881: *rp = a;
882: return 1;
883: }
1.53 noro 884: for ( ta = a; ta; ta = NEXT(ta) ) {
885: ba = BDY((LIST)BDY(ta));
1.55 noro 886: if ( !ba ) continue;
1.53 noro 887: pa = (QUOTE)BDY(ba); va = (QUOTE)BDY(NEXT(ba));
888: for ( tn = n; tn; tn = NEXT(tn) ) {
889: bn = BDY((LIST)BDY(tn));
1.55 noro 890: if ( !bn ) continue;
1.53 noro 891: pn = (QUOTE)BDY(bn); vn = (QUOTE)BDY(NEXT(bn));
1.55 noro 892: if ( !compquote(CO,pa,pn) ) {
893: if ( !compquote(CO,va,vn) ) break;
894: else return 0;
895: }
1.53 noro 896: }
897: if ( !tn ) {
898: MKNODE(tn,(pointer)BDY(ta),n);
899: n = tn;
900: }
901: }
1.56 noro 902: *rp = n;
903: return 1;
1.53 noro 904: }
905:
1.105 noro 906: int qt_match_node(NODE f,NODE pat,NODE *rp) {
1.56 noro 907: NODE r,a,tf,tp,r1;
908: int ret;
1.53 noro 909:
910: if ( length(f) != length(pat) ) return 0;
911: r = 0;
912: for ( tf = f, tp = pat; tf; tf = NEXT(tf), tp = NEXT(tp) ) {
1.105 noro 913: ret = qt_match((Obj)BDY(tf),(Obj)BDY(tp),&a);
1.56 noro 914: if ( !ret ) return 0;
915: ret = merge_matching_node(r,a,&r1);
916: if ( !ret ) return 0;
917: else r = r1;
1.53 noro 918: }
1.56 noro 919: *rp = r;
920: return 1;
1.53 noro 921: }
922:
1.66 noro 923: /* f = [a,b,c,...] pat = [X,Y,...] rpat matches the rest of f */
924:
1.105 noro 925: int qt_match_cons(NODE f,NODE pat,Obj rpat,NODE *rp) {
1.66 noro 926: QUOTE q;
927: Q id;
928: FNODE fn;
929: NODE r,a,tf,tp,r1,arg;
930: int ret;
931: LIST list,alist;
932:
933: /* matching of the head part */
934: if ( length(f) < length(pat) ) return 0;
935: r = 0;
936: for ( tf = f, tp = pat; tp; tf = NEXT(tf), tp = NEXT(tp) ) {
1.105 noro 937: ret = qt_match((Obj)BDY(tf),(Obj)BDY(tp),&a);
1.66 noro 938: if ( !ret ) return 0;
939: ret = merge_matching_node(r,a,&r1);
940: if ( !ret ) return 0;
941: else r = r1;
942: }
943: /* matching of the rest */
944: MKLIST(list,tf);
945: STOQ(I_LIST,id); a = mknode(2,id,list);
946: MKLIST(alist,a);
947: arg = mknode(1,alist);
948: Pfunargs_to_quote(arg,&q);
1.105 noro 949: ret = qt_match((Obj)q,rpat,&a);
1.66 noro 950: if ( !ret ) return 0;
951: ret = merge_matching_node(r,a,&r1);
952: if ( !ret ) return 0;
953: *rp = r1;
954: return 1;
955: }
956:
1.53 noro 957: void get_quote_id_arg(QUOTE f,int *id,NODE *r)
958: {
959: LIST fa;
960: NODE arg,fab;
961:
962: arg = mknode(1,f); Pquote_to_funargs(arg,&fa); fab = BDY((LIST)fa);
963: *id = QTOS((Q)BDY(fab)); *r = NEXT(fab);
964: }
965:
1.56 noro 966: /* *rp : [[quote(A),quote(1)],...] */
1.53 noro 967:
1.105 noro 968: int qt_match(Obj f, Obj pat, NODE *rp)
1.53 noro 969: {
970: NODE tf,tp,head,body;
971: NODE parg,farg,r;
1.66 noro 972: Obj rpat;
1.53 noro 973: LIST fa,l;
974: int pid,id;
1.55 noro 975: FUNC ff,pf;
1.56 noro 976: int ret;
1.64 noro 977: QUOTE q;
978: FNODE g;
1.53 noro 979:
1.67 noro 980: if ( !f )
981: if ( !pat ) {
982: *rp = 0; return 1;
983: } else
984: return 0;
985: else if ( OID(pat) == O_LIST ) {
1.53 noro 986: if ( OID(f) == O_LIST )
1.105 noro 987: return qt_match_node(BDY((LIST)f),BDY((LIST)pat),rp);
1.53 noro 988: else
989: return 0;
990: } else if ( OID(pat) == O_QUOTE ) {
1.67 noro 991: pid = ((FNODE)BDY((QUOTE)pat))->id;
1.53 noro 992: switch ( pid ) {
1.55 noro 993: case I_FORMULA:
994: if ( compquote(CO,f,pat) )
995: return 0;
996: else {
1.67 noro 997: *rp = 0; return 1;
1.55 noro 998: }
999: break;
1.67 noro 1000:
1001: case I_LIST: case I_CONS:
1002: get_quote_id_arg((QUOTE)pat,&pid,&parg);
1003: if ( OID(f) == O_LIST )
1004: tf = BDY((LIST)f);
1005: else if ( OID(f) == O_QUOTE
1006: && ((FNODE)BDY((QUOTE)f))->id == pid ) {
1007: get_quote_id_arg((QUOTE)f,&id,&farg);
1008: tf = BDY((LIST)BDY(farg));
1009: } else
1010: return 0;
1011:
1.66 noro 1012: tp = BDY((LIST)BDY(parg));
1.67 noro 1013: if ( pid == I_LIST )
1.105 noro 1014: return qt_match_node(tf,tp,rp);
1.67 noro 1015: else {
1016: rpat = (Obj)BDY(NEXT(parg));
1.105 noro 1017: return qt_match_cons(tf,tp,rpat,rp);
1.67 noro 1018: }
1019:
1.53 noro 1020: case I_PVAR:
1021: /* [[pat,f]] */
1022: r = mknode(2,pat,f); MKLIST(l,r);
1.56 noro 1023: *rp = mknode(1,l);
1024: return 1;
1.67 noro 1025:
1.53 noro 1026: case I_IFUNC:
1027: /* F(X,Y,...) = ... */
1.67 noro 1028: get_quote_id_arg((QUOTE)f,&id,&farg);
1029: get_quote_id_arg((QUOTE)pat,&pid,&parg);
1.53 noro 1030: if ( id == I_FUNC ) {
1.54 noro 1031: r = mknode(2,BDY(parg),BDY(farg)); MKLIST(l,r);
1032: head = mknode(1,l);
1.105 noro 1033: ret = qt_match(BDY(NEXT(farg)),
1.56 noro 1034: BDY(NEXT(parg)),&body);
1035: if ( !ret ) return 0;
1036: else return merge_matching_node(head,body,rp);
1.53 noro 1037: } else
1038: return 0;
1.64 noro 1039:
1.67 noro 1040: case I_NARYOP: case I_BOP: case I_FUNC:
1.64 noro 1041: /* X+Y = ... */
1.67 noro 1042: /* f(...) = ... */
1043: if ( OID(f) != O_QUOTE ) return 0;
1044: id = ((FNODE)BDY((QUOTE)f))->id;
1045: if ( pid == I_FUNC )
1046: ;
1047: else {
1048: /* XXX converting to I_BOP */
1049: if ( pid == I_NARYOP ) {
1.70 noro 1050: g = fnode_to_bin(BDY((QUOTE)pat),1);
1.67 noro 1051: MKQUOTE(q,g); pat = (Obj)q;
1052: }
1053: if ( id == I_NARYOP ) {
1.70 noro 1054: g = fnode_to_bin(BDY((QUOTE)f),1);
1.67 noro 1055: MKQUOTE(q,g); f = (Obj)q;
1056: }
1057: }
1058: get_quote_id_arg((QUOTE)pat,&pid,&parg);
1059: get_quote_id_arg((QUOTE)f,&id,&farg);
1.64 noro 1060: if ( compqa(CO,BDY(farg),BDY(parg)) ) return 0;
1.105 noro 1061: return qt_match_node(NEXT(farg),NEXT(parg),rp);
1.64 noro 1062:
1.53 noro 1063: default:
1.67 noro 1064: if ( OID(f) != O_QUOTE ) return 0;
1065: id = ((FNODE)BDY((QUOTE)f))->id;
1066: if ( id != pid ) return 0;
1067: get_quote_id_arg((QUOTE)pat,&pid,&parg);
1068: get_quote_id_arg((QUOTE)f,&id,&farg);
1.105 noro 1069: return qt_match_node(farg,parg,rp);
1.53 noro 1070: }
1071: }
1.13 noro 1072: }
1073:
1.14 noro 1074: void Pquotetotex(NODE arg,STRING *rp)
1.13 noro 1075: {
1.14 noro 1076: TB tb;
1.13 noro 1077:
1.14 noro 1078: NEWTB(tb);
1.27 noro 1079: /* XXX for DP */
1080: is_lt = 1;
1.14 noro 1081: fnodetotex_tb(BDY((QUOTE)ARG0(arg)),tb);
1082: tb_to_string(tb,rp);
1.13 noro 1083: }
1084:
1.14 noro 1085: void Pquotetotex_tb(NODE arg,Q *rp)
1.13 noro 1086: {
1087: int i;
1.14 noro 1088: TB tb;
1.13 noro 1089:
1.14 noro 1090: asir_assert(ARG1(arg),O_TB,"quotetotex_tb");
1.27 noro 1091: /* XXX for DP */
1092: is_lt = 1;
1.14 noro 1093: fnodetotex_tb(BDY((QUOTE)ARG0(arg)),ARG1(arg));
1.13 noro 1094: *rp = 0;
1095: }
1096:
1.14 noro 1097: void Pstring_to_tb(NODE arg,TB *rp)
1098: {
1099: TB tb;
1100:
1101: asir_assert(ARG0(arg),O_STR,"string_to_tb");
1102: NEWTB(tb);
1103: tb->body[0] = BDY((STRING)ARG0(arg));
1104: tb->next++;
1105: *rp = tb;
1106: }
1107:
1108: void Ptb_to_string(NODE arg,STRING *rp)
1109: {
1110: TB tb;
1111:
1112: asir_assert(ARG0(arg),O_TB,"tb_to_string");
1113: tb = (TB)ARG0(arg);
1114: tb_to_string(tb,rp);
1115: }
1116:
1117: void tb_to_string(TB tb,STRING *rp)
1.13 noro 1118: {
1.14 noro 1119: int j,len;
1.13 noro 1120: char *all,*p,*q;
1121:
1.14 noro 1122: for ( j = 0, len = 0; j < tb->next; j++ )
1123: len += strlen(tb->body[j]);
1124: all = (char *)MALLOC_ATOMIC((len+1)*sizeof(char));
1125: for ( j = 0, p = all; j < tb->next; j++ )
1126: for ( q = tb->body[j]; *q; *p++ = *q++ );
1127: *p = 0;
1128: MKSTR(*rp,all);
1129: }
1130:
1131: void Pclear_tb(NODE arg,Q *rp)
1132: {
1133: TB tb;
1134: int j;
1135:
1136: asir_assert(ARG0(arg),O_TB,"clear_tb");
1137: tb = (TB)ARG0(arg);
1138: for ( j = 0; j < tb->next; j++ )
1139: tb->body[j] = 0;
1140: tb->next = 0;
1141: *rp = 0;
1.13 noro 1142: }
1.5 noro 1143:
1144: void Pstr_len(arg,rp)
1145: NODE arg;
1146: Q *rp;
1147: {
1.16 noro 1148: Obj obj;
1149: TB tb;
1150: int r,i;
1.5 noro 1151:
1.16 noro 1152: obj = (Obj)ARG0(arg);
1153: if ( !obj || (OID(obj) != O_STR && OID(obj) != O_TB) )
1154: error("str_len : invalid argument");
1155: if ( OID(obj) == O_STR)
1156: r = strlen(BDY((STRING)obj));
1157: else if ( OID(obj) == O_TB ) {
1158: tb = (TB)obj;
1159: for ( r = i = 0; i < tb->next; i++ )
1160: r += strlen(tb->body[i]);
1161: }
1.5 noro 1162: STOQ(r,*rp);
1163: }
1164:
1165: void Pstr_chr(arg,rp)
1166: NODE arg;
1167: Q *rp;
1168: {
1169: STRING str,terminator;
1170: Q start;
1171: char *p,*ind;
1172: int chr,spos,r;
1173:
1174: str = (STRING)ARG0(arg);
1175: start = (Q)ARG1(arg);
1176: terminator = (STRING)ARG2(arg);
1177: asir_assert(str,O_STR,"str_chr");
1178: asir_assert(start,O_N,"str_chr");
1179: asir_assert(terminator,O_STR,"str_chr");
1180: p = BDY(str);
1181: spos = QTOS(start);
1182: chr = BDY(terminator)[0];
1.8 noro 1183: if ( spos > (int)strlen(p) )
1.5 noro 1184: r = -1;
1185: else {
1186: ind = strchr(p+spos,chr);
1187: if ( ind )
1188: r = ind-p;
1189: else
1190: r = -1;
1191: }
1192: STOQ(r,*rp);
1193: }
1194:
1195: void Psub_str(arg,rp)
1196: NODE arg;
1197: STRING *rp;
1198: {
1199: STRING str;
1200: Q head,tail;
1201: char *p,*r;
1202: int spos,epos,len;
1203:
1204: str = (STRING)ARG0(arg);
1205: head = (Q)ARG1(arg);
1206: tail = (Q)ARG2(arg);
1207: asir_assert(str,O_STR,"sub_str");
1208: asir_assert(head,O_N,"sub_str");
1209: asir_assert(tail,O_N,"sub_str");
1210: p = BDY(str);
1211: spos = QTOS(head);
1212: epos = QTOS(tail);
1213: len = strlen(p);
1214: if ( (spos >= len) || (epos < spos) ) {
1215: *rp = 0; return;
1216: }
1217: if ( epos >= len )
1218: epos = len-1;
1219: len = epos-spos+1;
1220: r = (char *)MALLOC(len+1);
1221: strncpy(r,p+spos,len);
1222: r[len] = 0;
1223: MKSTR(*rp,r);
1224: }
1.3 noro 1225:
1226: void Pstrtoascii(arg,rp)
1227: NODE arg;
1228: LIST *rp;
1229: {
1230: STRING str;
1231: unsigned char *p;
1232: int len,i;
1233: NODE n,n1;
1234: Q q;
1235:
1236: str = (STRING)ARG0(arg);
1237: asir_assert(str,O_STR,"strtoascii");
1238: p = BDY(str);
1239: len = strlen(p);
1240: for ( i = len-1, n = 0; i >= 0; i-- ) {
1241: UTOQ((unsigned int)p[i],q);
1242: MKNODE(n1,q,n);
1243: n = n1;
1244: }
1245: MKLIST(*rp,n);
1246: }
1247:
1248: void Pasciitostr(arg,rp)
1249: NODE arg;
1250: STRING *rp;
1251: {
1252: LIST list;
1253: unsigned char *p;
1254: int len,i,j;
1255: NODE n;
1256: Q q;
1257:
1258: list = (LIST)ARG0(arg);
1259: asir_assert(list,O_LIST,"asciitostr");
1260: n = BDY(list);
1261: len = length(n);
1262: p = MALLOC_ATOMIC(len+1);
1263: for ( i = 0; i < len; i++, n = NEXT(n) ) {
1264: q = (Q)BDY(n);
1265: asir_assert(q,O_N,"asciitostr");
1266: j = QTOS(q);
1.4 noro 1267: if ( j >= 256 || j <= 0 )
1.3 noro 1268: error("asciitostr : argument out of range");
1269: p[i] = j;
1270: }
1271: p[i] = 0;
1272: MKSTR(*rp,(char *)p);
1273: }
1.1 noro 1274:
1275: void Peval_str(arg,rp)
1276: NODE arg;
1277: Obj *rp;
1278: {
1279: FNODE fnode;
1280: char *cmd;
1.10 ohara 1281: #if defined(PARI)
1.8 noro 1282: void recover(int);
1283:
1.1 noro 1284: recover(0);
1.11 saito 1285: # if !(PARI_VERSION_CODE > 131588)
1.1 noro 1286: if ( setjmp(environnement) ) {
1287: avma = top; recover(1);
1288: resetenv("");
1289: }
1.11 saito 1290: # endif
1.1 noro 1291: #endif
1292: cmd = BDY((STRING)ARG0(arg));
1.9 noro 1293: exprparse_create_var(0,cmd,&fnode);
1.1 noro 1294: *rp = eval(fnode);
1295: }
1296:
1297: void Prtostr(arg,rp)
1298: NODE arg;
1299: STRING *rp;
1300: {
1301: char *b;
1302: int len;
1303:
1.2 noro 1304: len = estimate_length(CO,ARG0(arg));
1.12 noro 1305: b = (char *)MALLOC_ATOMIC(len+1);
1.1 noro 1306: soutput_init(b);
1307: sprintexpr(CO,ARG0(arg));
1308: MKSTR(*rp,b);
1309: }
1310:
1311: void Pstrtov(arg,rp)
1312: NODE arg;
1313: P *rp;
1314: {
1.8 noro 1315: char *p;
1.1 noro 1316:
1317: p = BDY((STRING)ARG0(arg));
1318: #if 0
1319: if ( !islower(*p) )
1320: *rp = 0;
1321: else {
1322: for ( t = p+1; t && (isalnum(*t) || *t == '_'); t++ );
1323: if ( *t )
1324: *rp = 0;
1325: else
1326: makevar(p,rp);
1327: }
1328: #else
1329: makevar(p,rp);
1330: #endif
1.14 noro 1331: }
1332:
1.15 noro 1333: static struct TeXSymbol texsymbol[] = {
1334: {"sin","\\sin"},
1335: {"cos","\\cos"},
1336: {"tan","\\tan"},
1337: {"sinh","\\sinh"},
1338: {"cosh","\\cosh"},
1339: {"tanh","\\tanh"},
1340: {"exp","\\exp"},
1341: {"log","\\log"},
1342:
1343: /* Greek Letters (lower case) */
1344: {"alpha","\\alpha"},
1345: {"beta","\\beta"},
1346: {"gamma","\\gamma"},
1347: {"delta","\\delta"},
1348: {"epsilon","\\epsilon"},
1349: {"varepsilon","\\varepsilon"},
1350: {"zeta","\\zeta"},
1351: {"eta","\\eta"},
1352: {"theta","\\theta"},
1353: {"vartheta","\\vartheta"},
1354: {"iota","\\iota"},
1355: {"kappa","\\kappa"},
1356: {"lambda","\\lambda"},
1357: {"mu","\\mu"},
1358: {"nu","\\nu"},
1359: {"xi","\\xi"},
1360: {"pi","\\pi"},
1361: {"varpi","\\varpi"},
1362: {"rho","\\rho"},
1363: {"sigma","\\sigma"},
1364: {"varsigma","\\varsigma"},
1365: {"tau","\\tau"},
1366: {"upsilon","\\upsilon"},
1367: {"phi","\\phi"},
1368: {"varphi","\\varphi"},
1369: {"chi","\\chi"},
1370: {"omega","\\omega"},
1371:
1372: /* Greek Letters, (upper case) */
1373: {"ggamma","\\Gamma"},
1374: {"ddelta","\\Delta"},
1375: {"ttheta","\\Theta"},
1376: {"llambda","\\Lambda"},
1377: {"xxi","\\Xi"},
1378: {"ppi","\\Pi"},
1379: {"ssigma","\\Sigma"},
1380: {"uupsilon","\\Upsilon"},
1381: {"pphi","\\Phi"},
1382: {"ppsi","\\Psi"},
1383: {"oomega","\\Omega"},
1384:
1385: /* Our own mathematical functions */
1386: {"algebra_tensor","\\otimes"},
1387: {"base_where","{\\rm \\ where \\ }"},
1388: /* Mathematical constants */
1389: {"c_pi","\\pi"},
1390: {"c_i","\\sqrt{-1}"},
1391:
1392: /* Temporary */
1393: {0,0}
1394: };
1395:
1.14 noro 1396: char *symbol_name(char *name)
1397: {
1.15 noro 1398: int i;
1399:
1.41 noro 1400: if ( !name || strlen(name) == 0 )
1401: return "";
1.38 noro 1402: if ( !(conv_flag & CONV_TABLE) )
1403: return name;
1404:
1.18 noro 1405: if ( user_texsymbol )
1406: for ( i = 0; user_texsymbol[i].text; i++ )
1407: if ( !strcmp(user_texsymbol[i].text,name) )
1408: return user_texsymbol[i].symbol;
1.15 noro 1409: for ( i = 0; texsymbol[i].text; i++ )
1410: if ( !strcmp(texsymbol[i].text,name) )
1411: return texsymbol[i].symbol;
1.41 noro 1412: return 0;
1.52 noro 1413: }
1414:
1415: void Pget_function_name(NODE arg,STRING *rp)
1416: {
1417: QUOTEARG qa;
1418: ARF f;
1419: char *opname;
1420:
1421: qa = (QUOTEARG)BDY(arg);
1422: if ( !qa || OID(qa) != O_QUOTEARG || qa->type != A_arf )
1423: *rp = 0;
1424: else {
1425: f = (ARF)BDY(qa);
1426: opname = f->name;
1427: MKSTR(*rp,opname);
1428: }
1.14 noro 1429: }
1430:
1.51 noro 1431: FNODE strip_paren(FNODE);
1432:
1.14 noro 1433: void fnodetotex_tb(FNODE f,TB tb)
1434: {
1.91 noro 1435: NODE n,t,t0,args;
1.38 noro 1436: char vname[BUFSIZ],prefix[BUFSIZ];
1437: char *opname,*vname_conv,*prefix_conv;
1.14 noro 1438: Obj obj;
1.46 noro 1439: int i,len,allzero,elen,elen2,si;
1.40 noro 1440: C cplx;
1441: char *r;
1.91 noro 1442: FNODE fi,f2,f1;
1.14 noro 1443:
1444: write_tb(" ",tb);
1445: if ( !f ) {
1446: write_tb("0",tb);
1447: return;
1448: }
1449: switch ( f->id ) {
1450: /* unary operators */
1.23 noro 1451: case I_NOT:
1452: write_tb("\\neg (",tb);
1453: fnodetotex_tb((FNODE)FA0(f),tb);
1454: write_tb(")",tb);
1455: break;
1456: case I_PAREN:
1457: write_tb("(",tb);
1458: fnodetotex_tb((FNODE)FA0(f),tb);
1459: write_tb(")",tb);
1460: break;
1461: case I_MINUS:
1462: write_tb("-",tb);
1463: fnodetotex_tb((FNODE)FA0(f),tb);
1464: break;
1465:
1466: /* binary operators */
1467: /* arg list */
1468: /* I_AND, I_OR => FA0(f), FA1(f) */
1469: /* otherwise => FA1(f), FA2(f) */
1470: case I_BOP:
1471: opname = ((ARF)FA0(f))->name;
1.70 noro 1472: switch ( opname[0] ) {
1473: case '+':
1474: fnodetotex_tb((FNODE)FA1(f),tb);
1475: if ( !top_is_minus((FNODE)FA2(f)) ) write_tb(opname,tb);
1476: fnodetotex_tb((FNODE)FA2(f),tb);
1477: break;
1478: case '-':
1479: if ( FA1(f) ) fnodetotex_tb((FNODE)FA1(f),tb);
1480: write_tb(opname,tb);
1481: fnodetotex_tb((FNODE)FA2(f),tb);
1482: break;
1483: case '*':
1484: fnodetotex_tb((FNODE)FA1(f),tb);
1485: write_tb(" ",tb);
1486: /* XXX special care for DP */
1487: f2 = (FNODE)FA2(f);
1488: if ( f2->id == I_EV ) {
1489: n = (NODE)FA0(f2);
1490: for ( i = 0; n; n = NEXT(n), i++ ) {
1491: fi = (FNODE)BDY(n);
1492: if ( fi->id != I_FORMULA || FA0(fi) )
1493: break;
1494: }
1495: if ( n )
1496: fnodetotex_tb((FNODE)FA2(f),tb);
1497: } else
1.23 noro 1498: fnodetotex_tb((FNODE)FA2(f),tb);
1.70 noro 1499: break;
1500: case '/':
1501: write_tb("\\frac{",tb);
1502: fnodetotex_tb((FNODE)FA1(f),tb);
1503: write_tb("} {",tb);
1504: fnodetotex_tb((FNODE)FA2(f),tb);
1505: write_tb("}",tb);
1506: break;
1507: case '^':
1508: fnodetotex_tb((FNODE)FA1(f),tb);
1509: write_tb("^{",tb);
1510: fnodetotex_tb(strip_paren((FNODE)FA2(f)),tb);
1511: write_tb("} ",tb);
1512: break;
1513: case '%':
1514: fnodetotex_tb((FNODE)FA1(f),tb);
1515: write_tb(" {\\rm mod}\\, ",tb);
1.23 noro 1516: fnodetotex_tb((FNODE)FA2(f),tb);
1.70 noro 1517: break;
1518: default:
1519: error("invalid binary operator");
1520: break;
1521: }
1.23 noro 1522: break;
1.91 noro 1523: case I_NARYOP:
1524: args = (NODE)FA1(f);
1525: write_tb("(",tb);
1526: switch ( OPNAME(f) ) {
1527: case '+':
1528: fnodetotex_tb((FNODE)BDY(args),tb);
1529: for ( args = NEXT(args); args; args = NEXT(args) ) {
1530: write_tb("+",tb);
1531: fnodetotex_tb((FNODE)BDY(args),tb);
1532: }
1533: break;
1534: case '*':
1535: f1 = (FNODE)BDY(args);
1536: if ( f1->id == I_FORMULA && MUNIQ(FA0(f1)) )
1537: write_tb("-",tb);
1538: else
1539: fnodetotex_tb(f1,tb);
1540: write_tb(" ",tb);
1541: for ( args = NEXT(args); args; args = NEXT(args) ) {
1542: /* XXX special care for DP */
1543: f2 = (FNODE)BDY(args);
1544: if ( f2->id == I_EV ) {
1545: n = (NODE)FA0(f2);
1546: for ( i = 0; n; n = NEXT(n), i++ ) {
1547: fi = (FNODE)BDY(n);
1548: if ( fi->id != I_FORMULA || FA0(fi) )
1549: break;
1550: }
1551: if ( n )
1552: fnodetotex_tb(f2,tb);
1553: } else
1554: fnodetotex_tb(f2,tb);
1555: }
1556: break;
1557: default:
1558: error("invalid nary op");
1559: break;
1560: }
1561: write_tb(")",tb);
1562: break;
1.23 noro 1563:
1564: case I_COP:
1565: switch( (cid)FA0(f) ) {
1566: case C_EQ:
1567: fnodetotex_tb((FNODE)FA1(f),tb);
1568: write_tb(" = ",tb);
1569: fnodetotex_tb((FNODE)FA2(f),tb);
1570: break;
1571: case C_NE:
1572: fnodetotex_tb((FNODE)FA1(f),tb);
1573: write_tb(" \\neq ",tb);
1574: fnodetotex_tb((FNODE)FA2(f),tb);
1575: break;
1576: case C_GT:
1577: fnodetotex_tb((FNODE)FA1(f),tb);
1.45 noro 1578: write_tb(" > ",tb);
1.23 noro 1579: fnodetotex_tb((FNODE)FA2(f),tb);
1580: break;
1581: case C_LT:
1582: fnodetotex_tb((FNODE)FA1(f),tb);
1.45 noro 1583: write_tb(" < ",tb);
1.23 noro 1584: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1585: break;
1.23 noro 1586: case C_GE:
1587: fnodetotex_tb((FNODE)FA1(f),tb);
1588: write_tb(" \\geq ",tb);
1589: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1590: break;
1.23 noro 1591: case C_LE:
1592: fnodetotex_tb((FNODE)FA1(f),tb);
1593: write_tb(" \\leq ",tb);
1594: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1595: break;
1596: }
1597: break;
1598:
1.23 noro 1599: case I_LOP:
1600: switch( (lid)FA0(f) ) {
1601: case L_EQ:
1602: fnodetotex_tb((FNODE)FA1(f),tb);
1603: write_tb(" = ",tb);
1604: fnodetotex_tb((FNODE)FA2(f),tb);
1605: break;
1606: case L_NE:
1607: fnodetotex_tb((FNODE)FA1(f),tb);
1608: write_tb(" \\neq ",tb);
1609: fnodetotex_tb((FNODE)FA2(f),tb);
1610: break;
1611: case L_GT:
1612: fnodetotex_tb((FNODE)FA1(f),tb);
1.45 noro 1613: write_tb(" > ",tb);
1.23 noro 1614: fnodetotex_tb((FNODE)FA2(f),tb);
1615: break;
1616: case L_LT:
1617: fnodetotex_tb((FNODE)FA1(f),tb);
1.45 noro 1618: write_tb(" < ",tb);
1.23 noro 1619: fnodetotex_tb((FNODE)FA2(f),tb);
1620: break;
1621: case L_GE:
1622: fnodetotex_tb((FNODE)FA1(f),tb);
1623: write_tb(" \\geq ",tb);
1624: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1625: break;
1.23 noro 1626: case L_LE:
1627: fnodetotex_tb((FNODE)FA1(f),tb);
1628: write_tb(" \\leq ",tb);
1629: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1630: break;
1.23 noro 1631: case L_AND:
1632: fnodetotex_tb((FNODE)FA1(f),tb);
1.14 noro 1633: write_tb(" {\\rm \\ and\\ } ",tb);
1.23 noro 1634: fnodetotex_tb((FNODE)FA2(f),tb);
1635: break;
1636: case L_OR:
1.14 noro 1637: fnodetotex_tb((FNODE)FA1(f),tb);
1.23 noro 1638: write_tb(" {\\rm \\ or\\ } ",tb);
1639: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1640: break;
1.23 noro 1641: case L_NOT:
1642: /* XXX : L_NOT is a unary operator */
1643: write_tb("\\neg (",tb);
1.14 noro 1644: fnodetotex_tb((FNODE)FA1(f),tb);
1.23 noro 1645: write_tb(")",tb);
1646: return;
1.14 noro 1647: }
1648: break;
1649:
1.23 noro 1650: case I_AND:
1651: fnodetotex_tb((FNODE)FA0(f),tb);
1652: write_tb(" {\\rm \\ and\\ } ",tb);
1653: fnodetotex_tb((FNODE)FA1(f),tb);
1654: break;
1655:
1656: case I_OR:
1657: fnodetotex_tb((FNODE)FA0(f),tb);
1658: write_tb(" {\\rm \\ or\\ } ",tb);
1659: fnodetotex_tb((FNODE)FA1(f),tb);
1660: break;
1661:
1.14 noro 1662: /* ternary operators */
1663: case I_CE:
1664: error("fnodetotex_tb : not implemented yet");
1665: break;
1666:
1667: /* lists */
1668: case I_LIST:
1669: write_tb(" [ ",tb);
1670: n = (NODE)FA0(f);
1671: fnodenodetotex_tb(n,tb);
1672: write_tb("]",tb);
1673: break;
1674:
1675: /* function */
1.23 noro 1676: case I_FUNC:
1.40 noro 1677: if ( !strcmp(((FUNC)FA0(f))->name,"@pi") )
1678: write_tb("\\pi",tb);
1679: else if ( !strcmp(((FUNC)FA0(f))->name,"@e") )
1680: write_tb("e",tb);
1681: else {
1682: opname = conv_rule(((FUNC)FA0(f))->name);
1683: write_tb(opname,tb);
1684: write_tb("(",tb);
1685: fargstotex_tb(opname,FA1(f),tb);
1686: write_tb(")",tb);
1687: }
1.23 noro 1688: break;
1689:
1690: /* XXX */
1691: case I_CAR:
1.28 noro 1692: opname = conv_rule("car");
1.23 noro 1693: write_tb(opname,tb);
1694: write_tb("(",tb);
1695: fargstotex_tb(opname,FA0(f),tb);
1696: write_tb(")",tb);
1697: break;
1698:
1699: case I_CDR:
1.28 noro 1700: opname = conv_rule("cdr");
1.23 noro 1701: write_tb(opname,tb);
1702: write_tb("(",tb);
1703: fargstotex_tb(opname,FA0(f),tb);
1704: write_tb(")",tb);
1705: break;
1706:
1707: /* exponent vector */
1708: case I_EV:
1709: n = (NODE)FA0(f);
1.31 noro 1710: if ( dp_vars_hweyl ) {
1711: elen = length(n);
1712: elen2 = elen>>1;
1713: elen = elen2<<1;
1714: }
1.23 noro 1715: allzero = 1;
1.27 noro 1716: if ( show_lt && is_lt )
1717: write_tb("\\underline{",tb);
1.23 noro 1718: for ( t0 = 0, i = 0; n; n = NEXT(n), i++ ) {
1719: fi = (FNODE)BDY(n);
1720: if ( fi->id == I_FORMULA && !FA0(fi) ) continue;
1721: allzero = 0;
1.38 noro 1722: if ( dp_vars && i < dp_vars_len ) {
1723: strcpy(vname,dp_vars[i]);
1724: vname_conv = conv_rule(vname);
1725: } else {
1726: if ( dp_vars_hweyl ) {
1.44 noro 1727: if ( i < elen2 ) {
1.38 noro 1728: strcpy(prefix,dp_vars_prefix?dp_vars_prefix:"x");
1.44 noro 1729: prefix_conv = conv_rule(prefix);
1730: vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46 noro 1731: si = i+dp_vars_origin;
1732: sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
1733: prefix_conv,si);
1.44 noro 1734: } else if ( i < elen ) {
1.46 noro 1735: strcpy(prefix,
1736: dp_dvars_prefix?dp_dvars_prefix:"\\partial");
1.44 noro 1737: prefix_conv = conv_rule(prefix);
1738: vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46 noro 1739: si = i+dp_dvars_origin-elen2;
1740: sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
1741: prefix_conv,si);
1.44 noro 1742: } else {
1.38 noro 1743: strcpy(prefix,"h");
1.44 noro 1744: vname_conv = conv_rule(prefix);
1745: }
1746: } else {
1.38 noro 1747: strcpy(prefix,dp_vars_prefix?dp_vars_prefix:"x");
1.44 noro 1748: prefix_conv = conv_rule(prefix);
1749: vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46 noro 1750: si = i+dp_vars_origin;
1751: sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
1752: prefix_conv,si);
1.44 noro 1753: }
1.38 noro 1754: }
1.23 noro 1755: if ( fi->id == I_FORMULA && UNIQ(FA0(fi)) ) {
1756: len = strlen(vname_conv);
1757: opname = MALLOC_ATOMIC(len+2);
1758: sprintf(opname,"%s ",vname_conv);
1.14 noro 1759: write_tb(opname,tb);
1.23 noro 1760: } else {
1761: len = strlen(vname_conv);
1762: /* 2: ^{ */
1763: opname = MALLOC_ATOMIC(len+1+2);
1764: sprintf(opname,"%s^{",vname_conv);
1.14 noro 1765: write_tb(opname,tb);
1.23 noro 1766: fnodetotex_tb((FNODE)BDY(n),tb);
1767: write_tb("} ",tb);
1768: }
1.14 noro 1769: }
1.23 noro 1770: /* XXX */
1771: if ( allzero )
1772: write_tb(" 1 ",tb);
1.27 noro 1773: if ( show_lt && is_lt ) {
1774: write_tb("}",tb);
1775: is_lt = 0;
1776: }
1.14 noro 1777: break;
1778:
1.23 noro 1779: /* string */
1.14 noro 1780: case I_STR:
1781: write_tb((char *)FA0(f),tb);
1782: break;
1783:
1.23 noro 1784: /* internal object */
1.14 noro 1785: case I_FORMULA:
1786: obj = (Obj)FA0(f);
1.40 noro 1787: if ( !obj )
1.42 noro 1788: write_tb("0",tb);
1.40 noro 1789: else if ( OID(obj) == O_N && NID(obj) == N_C ) {
1790: cplx = (C)obj;
1791: write_tb("(",tb);
1792: if ( cplx->r ) {
1793: r = objtostr((Obj)cplx->r); write_tb(r,tb);
1794: }
1795: if ( cplx->i ) {
1796: if ( cplx->r && compnum(0,cplx->i,0) > 0 ) {
1797: write_tb("+",tb);
1798: if ( !UNIQ(cplx->i) ) {
1799: r = objtostr((Obj)cplx->i); write_tb(r,tb);
1800: }
1801: } else if ( MUNIQ(cplx->i) )
1802: write_tb("-",tb);
1803: else if ( !UNIQ(cplx->i) ) {
1804: r = objtostr((Obj)cplx->i); write_tb(r,tb);
1805: }
1806: write_tb("\\sqrt{-1}",tb);
1807: }
1808: write_tb(")",tb);
1809: } else if ( OID(obj) == O_P )
1810: write_tb(conv_rule(VR((P)obj)->name),tb);
1811: else
1812: write_tb(objtostr(obj),tb);
1.14 noro 1813: break;
1814:
1.23 noro 1815: /* program variable */
1.14 noro 1816: case I_PVAR:
1817: if ( FA1(f) )
1818: error("fnodetotex_tb : not implemented yet");
1819: GETPVNAME(FA0(f),opname);
1820: write_tb(opname,tb);
1821: break;
1822:
1823: default:
1824: error("fnodetotex_tb : not implemented yet");
1825: }
1.40 noro 1826: }
1827:
1828: char *objtostr(Obj obj)
1829: {
1830: int len;
1831: char *r;
1832:
1833: len = estimate_length(CO,obj);
1834: r = (char *)MALLOC_ATOMIC(len+1);
1835: soutput_init(r);
1836: sprintexpr(CO,obj);
1837: return r;
1.50 ohara 1838: }
1839:
1840: void Psprintf(NODE arg,STRING *rp)
1841: {
1842: STRING string;
1843: char *s,*t,*r;
1844: int argc,n,len;
1845: NODE node;
1846:
1847: string = (STRING)ARG0(arg);
1848: asir_assert(string,O_STR,"sprintf");
1849: s = BDY(string);
1850: for(n = 0, t = s; *t; t++) {
1851: if (*t=='%' && *(t+1)=='a') {
1852: n++;
1853: }
1854: }
1855: for(node = NEXT(arg), argc = 0, len = strlen(s); node; node = NEXT(node), argc++) {
1856: len += estimate_length(CO,BDY(node));
1857: }
1858: if (argc < n) {
1859: error("sprintf: invalid argument");
1860: }
1861: r = (char *)MALLOC_ATOMIC(len);
1862: for(node = NEXT(arg), t = r; *s; s++) {
1863: if (*s=='%' && *(s+1)=='a') {
1864: strcpy(t,objtostr(BDY(node)));
1865: node = NEXT(node);
1866: t = strchr(t,0);
1867: s++;
1868: }else {
1869: *t++ = *s;
1870: }
1871: }
1872: *t = 0;
1873: MKSTR(*rp,r);
1.14 noro 1874: }
1875:
1876: void fnodenodetotex_tb(NODE n,TB tb)
1877: {
1878: for ( ; n; n = NEXT(n) ) {
1.27 noro 1879: is_lt = 1;
1.14 noro 1880: fnodetotex_tb((FNODE)BDY(n),tb);
1881: if ( NEXT(n) ) write_tb(", ",tb);
1882: }
1883: }
1884:
1885: void fargstotex_tb(char *name,FNODE f,TB tb)
1886: {
1887: NODE n;
1888:
1889: if ( !strcmp(name,"matrix") ) {
1890: error("fargstotex_tb : not implemented yet");
1891: } else if ( !strcmp(name,"vector") ) {
1892: error("fargstotex_tb : not implemented yet");
1893: } else {
1894: if ( f->id == I_LIST ) {
1895: n = (NODE)FA0(f);
1896: fnodenodetotex_tb(n,tb);
1897: } else
1898: fnodetotex_tb(f,tb);
1.35 noro 1899: }
1900: }
1901:
1902: int top_is_minus(FNODE f)
1903: {
1904: char *opname;
1905: int len;
1906: Obj obj;
1907:
1908: if ( !f )
1909: return 0;
1910: switch ( f->id ) {
1911: case I_MINUS:
1912: return 1;
1913: case I_BOP:
1914: opname = ((ARF)FA0(f))->name;
1915: switch ( opname[0] ) {
1916: case '+': case '*': case '/': case '^': case '%':
1917: return top_is_minus((FNODE)FA1(f));
1918: case '-':
1919: if ( FA1(f) )
1920: return top_is_minus((FNODE)FA1(f));
1921: else
1922: return 1;
1923: default:
1924: return 0;
1925: }
1926: break;
1927: case I_COP:
1928: return top_is_minus((FNODE)FA1(f));
1929: case I_LOP:
1930: if ( (lid)FA0(f) == L_NOT ) return 0;
1931: else return top_is_minus((FNODE)FA1(f));
1932: case I_AND: case I_OR:
1933: return top_is_minus((FNODE)FA0(f));
1934: case I_FORMULA:
1935: obj = (Obj)FA0(f);
1.36 noro 1936: if ( !obj )
1937: return 0;
1938: else {
1939: switch ( OID(obj) ) {
1940: case O_N:
1941: return mmono((P)obj);
1942: case O_P:
1943: /* must be a variable */
1944: opname = conv_rule(VR((P)obj)->name);
1945: return opname[0]=='-';
1946: default:
1947: /* ??? */
1948: len = estimate_length(CO,obj);
1949: opname = (char *)MALLOC_ATOMIC(len+1);
1950: soutput_init(opname);
1951: sprintexpr(CO,obj);
1952: return opname[0]=='-';
1953: }
1.35 noro 1954: }
1.91 noro 1955: case I_NARYOP:
1956: return top_is_minus((FNODE)BDY((NODE)FA1(f)));
1957:
1.35 noro 1958: default:
1959: return 0;
1.14 noro 1960: }
1.47 noro 1961: }
1962:
1963: FNODE flatten_fnode(FNODE,char *);
1964:
1.48 noro 1965: void Pflatten_quote(NODE arg,Obj *rp)
1.47 noro 1966: {
1967: FNODE f;
1968: QUOTE q;
1969:
1.48 noro 1970: if ( !ARG0(arg) || OID((Obj)ARG0(arg)) != O_QUOTE )
1971: *rp = (Obj)ARG0(arg);
1.65 noro 1972: else if ( argc(arg) == 1 ) {
1973: f = flatten_fnode(BDY((QUOTE)ARG0(arg)),"+");
1974: f = flatten_fnode(f,"*");
1975: MKQUOTE(q,f);
1976: *rp = (Obj)q;
1977: } else {
1.48 noro 1978: f = flatten_fnode(BDY((QUOTE)ARG0(arg)),BDY((STRING)ARG1(arg)));
1979: MKQUOTE(q,f);
1980: *rp = (Obj)q;
1981: }
1.63 noro 1982: }
1983:
1984: void Pget_quote_id(NODE arg,Q *rp)
1985: {
1986: FNODE f;
1987: QUOTE q;
1988:
1989: q = (QUOTE)ARG0(arg);
1990: if ( !q || OID(q) != O_QUOTE )
1991: error("get_quote_id : invalid argument");
1992: f = BDY(q);
1993: STOQ((int)f->id,*rp);
1.48 noro 1994: }
1995:
1996: void Pquote_to_funargs(NODE arg,LIST *rp)
1997: {
1998: fid_spec_p spec;
1999: QUOTE q;
2000: QUOTEARG qa;
2001: FNODE f;
2002: STRING s;
2003: QUOTE r;
2004: int i;
2005: Q id,a;
1.49 noro 2006: LIST l;
2007: NODE t0,t,w,u,u0;
1.48 noro 2008:
2009: q = (QUOTE)ARG0(arg);
2010: if ( !q || OID(q) != O_QUOTE )
2011: error("quote_to_funargs : invalid argument");
2012: f = BDY(q);
2013: if ( !f ) {
2014: MKLIST(*rp,0);
2015: return;
2016: }
2017: get_fid_spec(f->id,&spec);
2018: if ( !spec )
2019: error("quote_to_funargs : not supported yet");
2020: t0 = 0;
2021: STOQ((int)f->id,id);
2022: NEXTNODE(t0,t);
2023: BDY(t) = (pointer)id;
2024: for ( i = 0; spec->type[i] != A_end; i++ ) {
2025: NEXTNODE(t0,t);
2026: switch ( spec->type[i] ) {
2027: case A_fnode:
2028: MKQUOTE(r,(FNODE)f->arg[i]);
2029: BDY(t) = (pointer)r;
2030: break;
2031: case A_int:
2032: STOQ((int)f->arg[i],a);
2033: BDY(t) = (pointer)a;
2034: break;
2035: case A_str:
2036: MKSTR(s,(char *)f->arg[i]);
2037: BDY(t) = (pointer)s;
2038: break;
2039: case A_internal:
2040: BDY(t) = (pointer)f->arg[i];
2041: break;
1.49 noro 2042: case A_node:
2043: w = (NODE)f->arg[i];
2044: for ( u0 = 0; w; w = NEXT(w) ){
2045: NEXTNODE(u0,u);
2046: MKQUOTE(r,(FNODE)BDY(w));
2047: BDY(u) = (pointer)r;
2048: }
2049: if ( u0 ) NEXT(u) = 0;
2050: MKLIST(l,u0);
2051: BDY(t) = (pointer)l;
2052: break;
1.48 noro 2053: default:
2054: MKQUOTEARG(qa,spec->type[i],f->arg[i]);
2055: BDY(t) = (pointer)qa;
2056: break;
2057: }
2058: }
2059: if ( t0 ) NEXT(t) = 0;
2060: MKLIST(*rp,t0);
2061: }
2062:
2063: void Pfunargs_to_quote(NODE arg,QUOTE *rp)
2064: {
2065: fid_spec_p spec;
2066: QUOTE q;
2067: QUOTEARG qa;
2068: FNODE f;
2069: STRING s;
1.49 noro 2070: QUOTE r,b;
1.48 noro 2071: int i;
2072: LIST l;
2073: fid id;
2074: Obj a;
1.49 noro 2075: NODE t0,t,u0,u,w;
1.48 noro 2076:
2077: l = (LIST)ARG0(arg);
2078: if ( !l || OID(l) != O_LIST || !(t=BDY(l)) )
2079: error("funargs_to_quote : invalid argument");
2080: t = BDY(l);
2081: id = (fid)QTOS((Q)BDY(t)); t = NEXT(t);
2082: get_fid_spec(id,&spec);
2083: if ( !spec )
2084: error("funargs_to_quote : not supported yet");
2085: for ( i = 0; spec->type[i] != A_end; i++ );
2086: NEWFNODE(f,i);
2087: f->id = id;
2088: for ( i = 0; spec->type[i] != A_end; i++, t = NEXT(t) ) {
2089: if ( !t )
2090: error("funargs_to_quote : argument mismatch");
2091: a = (Obj)BDY(t);
2092: switch ( spec->type[i] ) {
2093: case A_fnode:
2094: if ( !a || OID(a) != O_QUOTE )
2095: error("funargs_to_quote : invalid argument");
2096: f->arg[i] = BDY((QUOTE)a);
2097: break;
2098: case A_int:
2099: if ( !INT(a) )
2100: error("funargs_to_quote : invalid argument");
2101: f->arg[i] = (pointer)QTOS((Q)a);
2102: break;
2103: case A_str:
2104: if ( !a || OID(a) != O_STR )
2105: error("funargs_to_quote : invalid argument");
2106: f->arg[i] = (pointer)BDY((STRING)a);
2107: break;
2108: case A_internal:
2109: f->arg[i] = (pointer)a;
1.49 noro 2110: break;
2111: case A_node:
2112: if ( !a || OID(a) != O_LIST )
2113: error("funargs_to_quote : invalid argument");
2114: u0 = 0;
2115: for ( w = BDY((LIST)a); w; w = NEXT(w) ) {
2116: NEXTNODE(u0,u);
2117: b = (QUOTE)BDY(w);
2118: if ( !b || OID(b) != O_QUOTE )
2119: error("funargs_to_quote : invalid argument");
2120: BDY(u) = BDY(b);
2121: }
2122: if ( u0 ) NEXT(u) = 0;
2123: f->arg[i] = (pointer)u0;
1.48 noro 2124: break;
2125: default:
2126: if ( !a || OID(a) != O_QUOTEARG ||
2127: ((QUOTEARG)a)->type != spec->type[i] )
2128: error("funargs_to_quote : invalid argument");
2129: f->arg[i] = BDY((QUOTEARG)a);
2130: break;
2131: }
2132: }
2133: MKQUOTE(*rp,f);
1.69 noro 2134: }
2135:
1.105 noro 2136: VL reordvars(VL vl0,NODE head)
2137: {
2138: VL vl,svl,tvl;
2139: int i,j;
2140: NODE n;
2141: P t;
2142: V *va;
2143: V v;
2144:
2145: for ( vl = 0, i = 0, n = head; n; n = NEXT(n), i++ ) {
2146: NEXTVL(vl,tvl);
2147: if ( !(t = (P)BDY(n)) || (OID(t) != O_P) )
2148: error("reordvars : invalid argument");
2149: VR(tvl) = VR(t);
2150: }
2151: va = (V *)ALLOCA(i*sizeof(V));
2152: for ( j = 0, svl = vl; j < i; j++, svl = NEXT(svl) )
2153: va[j] = VR(svl);
2154: for ( svl = vl0; svl; svl = NEXT(svl) ) {
2155: v = VR(svl);
2156: for ( j = 0; j < i; j++ )
2157: if ( v == va[j] )
2158: break;
2159: if ( j == i ) {
2160: NEXTVL(vl,tvl);
2161: VR(tvl) = v;
2162: }
2163: }
2164: if ( vl )
2165: NEXT(tvl) = 0;
2166: return vl;
2167: }
2168:
1.108 ! noro 2169: VL qt_current_ord, qt_current_coef;
! 2170: LIST qt_current_ord_obj,qt_current_coef_obj;
1.105 noro 2171:
2172: void Pqt_set_ord(NODE arg,LIST *rp)
2173: {
2174: NODE r0,r;
2175: VL vl;
2176: P v;
2177:
2178: if ( !argc(arg) )
2179: *rp = qt_current_ord_obj;
2180: else {
2181: qt_current_ord = reordvars(CO,BDY((LIST)ARG0(arg)));
2182: for ( r0 = 0, vl = qt_current_ord; vl; vl = NEXT(vl) ) {
2183: NEXTNODE(r0,r); MKV(vl->v,v); BDY(r) = v;
2184: }
2185: if ( r0 ) NEXT(r) = 0;
2186: MKLIST(*rp,r0);
2187: qt_current_ord_obj = *rp;
2188: }
2189: }
2190:
1.108 ! noro 2191: void Pqt_set_coef(NODE arg,LIST *rp)
! 2192: {
! 2193: NODE r0,r,n;
! 2194: VL vl0,vl;
! 2195: P v;
! 2196:
! 2197: if ( !argc(arg) )
! 2198: *rp = qt_current_coef_obj;
! 2199: else {
! 2200: n = BDY((LIST)ARG0(arg));
! 2201: for ( vl0 = 0, r0 = 0; n; n = NEXT(n) ) {
! 2202: NEXTNODE(r0,r);
! 2203: NEXTVL(vl0,vl);
! 2204: vl->v = VR((P)BDY(n));
! 2205: MKV(vl->v,v); BDY(r) = v;
! 2206: }
! 2207: if ( r0 ) NEXT(r) = 0;
! 2208: if ( vl0 ) NEXT(vl) = 0;
! 2209: qt_current_coef = vl0;
! 2210: MKLIST(*rp,r0);
! 2211: qt_current_coef_obj = *rp;
! 2212: }
! 2213: }
! 2214:
1.105 noro 2215: void Pqt_normalize(NODE arg,QUOTE *rp)
1.70 noro 2216: {
2217: QUOTE q,r;
2218: FNODE f;
1.76 noro 2219: int expand,ac;
1.70 noro 2220:
1.76 noro 2221: ac = argc(arg);
1.105 noro 2222: if ( !ac ) error("qt_normalize : invalid argument");
1.70 noro 2223: q = (QUOTE)ARG0(arg);
1.103 noro 2224: if ( ac == 2 )
2225: expand = QTOS((Q)ARG1(arg));
1.97 noro 2226: if ( !q || OID(q) != O_QUOTE )
1.87 noro 2227: *rp = q;
2228: else {
1.76 noro 2229: f = fnode_normalize(BDY(q),expand);
1.70 noro 2230: MKQUOTE(r,f);
2231: *rp = r;
1.98 noro 2232: }
2233: }
2234:
2235: NBP fnode_to_nbp(FNODE f);
2236:
1.105 noro 2237: void Pqt_to_nbp(NODE arg,NBP *rp)
1.98 noro 2238: {
2239: QUOTE q;
2240: FNODE f;
2241:
2242: q = (QUOTE)ARG0(arg); f = (FNODE)BDY(q);
2243: f = fnode_normalize(f,0);
2244: *rp = fnode_to_nbp(f);
2245: }
2246:
1.101 noro 2247: void Pshuffle_mul(NODE arg,NBP *rp)
1.98 noro 2248: {
2249: NBP p1,p2;
2250:
2251: p1 = (NBP)ARG0(arg);
2252: p2 = (NBP)ARG1(arg);
2253: shuffle_mulnbp(CO,p1,p2,rp);
2254: }
1.99 noro 2255:
1.101 noro 2256: void Pharmonic_mul(NODE arg,NBP *rp)
1.99 noro 2257: {
2258: NBP p1,p2;
2259:
2260: p1 = (NBP)ARG0(arg);
2261: p2 = (NBP)ARG1(arg);
2262: harmonic_mulnbp(CO,p1,p2,rp);
2263: }
2264:
1.100 noro 2265: void Pnbp_hm(NODE arg, NBP *rp)
2266: {
2267: NBP p;
2268: NODE n;
2269: NBM m;
2270:
2271: p = (NBP)ARG0(arg);
2272: if ( !p ) *rp = 0;
2273: else {
2274: m = (NBM)BDY(BDY(p));
2275: MKNODE(n,m,0);
2276: MKNBP(*rp,n);
2277: }
2278: }
2279:
2280: void Pnbp_ht(NODE arg, NBP *rp)
2281: {
2282: NBP p;
2283: NODE n;
2284: NBM m,m1;
2285:
2286: p = (NBP)ARG0(arg);
2287: if ( !p ) *rp = 0;
2288: else {
2289: m = (NBM)BDY(BDY(p));
2290: NEWNBM(m1);
2291: m1->d = m->d; m1->c = ONE; m1->b = m->b;
2292: MKNODE(n,m1,0);
2293: MKNBP(*rp,n);
2294: }
2295: }
2296:
2297: void Pnbp_hc(NODE arg, Q *rp)
2298: {
2299: NBP p;
2300: NBM m;
2301:
2302: p = (NBP)ARG0(arg);
2303: if ( !p ) *rp = 0;
2304: else {
2305: m = (NBM)BDY(BDY(p));
2306: *rp = m->c;
2307: }
2308: }
2309:
2310: void Pnbp_rest(NODE arg, NBP *rp)
2311: {
2312: NBP p;
2313: NODE n;
2314:
2315: p = (NBP)ARG0(arg);
2316: if ( !p ) *rp = 0;
2317: else {
2318: n = BDY(p);
2319: if ( !NEXT(n) ) *rp = 0;
2320: else
2321: MKNBP(*rp,NEXT(n));
2322: }
2323: }
2324:
1.102 noro 2325: void Pnbm_deg(NODE arg, Q *rp)
1.100 noro 2326: {
2327: NBP p;
2328: NBM m;
1.102 noro 2329:
2330: p = (NBP)ARG0(arg);
2331: if ( !p )
2332: STOQ(-1,*rp);
2333: else {
2334: m = (NBM)BDY(BDY(p));
2335: STOQ(m->d,*rp);
2336: }
2337: }
2338:
2339: void Pnbm_hp_rest(NODE arg, LIST *rp)
2340: {
2341: NBP p,h,r;
2342: NBM m,m1;
1.100 noro 2343: NODE n;
1.102 noro 2344: int *b,*b1;
2345: int d,d1,v,i,j,k;
1.100 noro 2346:
2347: p = (NBP)ARG0(arg);
1.102 noro 2348: if ( !p )
1.100 noro 2349: MKLIST(*rp,0);
1.102 noro 2350: else {
2351: m = (NBM)BDY(BDY(p));
2352: b = m->b; d = m->d;
1.100 noro 2353: if ( !d )
2354: MKLIST(*rp,0);
2355: else {
1.102 noro 2356: v = NBM_GET(b,0);
1.100 noro 2357: for ( i = 1; i < d; i++ )
1.102 noro 2358: if ( NBM_GET(b,i) != v ) break;
2359: NEWNBM(m1); NEWNBMBDY(m1,i);
2360: b1 = m1->b; m1->d = i; m1->c = ONE;
2361: if ( v ) for ( j = 0; j < i; j++ ) NBM_SET(b1,j);
2362: else for ( j = 0; j < i; j++ ) NBM_CLR(b1,j);
2363: MKNODE(n,m1,0); MKNBP(h,n);
2364:
2365: d1 = d-i;
2366: NEWNBM(m1); NEWNBMBDY(m1,d1);
2367: b1 = m1->b; m1->d = d1; m1->c = ONE;
2368: for ( j = 0, k = i; j < d1; j++, k++ )
2369: if ( NBM_GET(b,k) ) NBM_SET(b1,j);
2370: else NBM_CLR(b1,j);
2371: MKNODE(n,m1,0); MKNBP(r,n);
2372: n = mknode(2,h,r);
1.100 noro 2373: MKLIST(*rp,n);
2374: }
2375: }
2376: }
2377:
1.102 noro 2378: void Pnbm_hxky(NODE arg, LIST *rp)
2379: {
2380: NBP p;
2381:
2382: p = (NBP)ARG0(arg);
2383: if ( !p )
2384: *rp = 0;
2385: else
2386: separate_xky_nbm((NBM)BDY(BDY(p)),0,rp,0);
2387: }
2388:
2389: void Pnbm_xky_rest(NODE arg,NBP *rp)
1.100 noro 2390: {
2391: NBP p;
2392:
2393: p = (NBP)ARG0(arg);
2394: if ( !p )
2395: *rp = 0;
1.102 noro 2396: else
2397: separate_xky_nbm((NBM)BDY(BDY(p)),0,0,rp);
2398: }
2399:
2400: void Pnbm_hv(NODE arg, NBP *rp)
2401: {
2402: NBP p;
2403:
2404: p = (NBP)ARG0(arg);
2405: if ( !p )
2406: *rp = 0;
2407: else
2408: separate_nbm((NBM)BDY(BDY(p)),0,rp,0);
2409: }
2410:
2411: void Pnbm_rest(NODE arg, NBP *rp)
2412: {
2413: NBP p;
2414:
2415: p = (NBP)ARG0(arg);
2416: if ( !p )
2417: *rp = 0;
2418: else
2419: separate_nbm((NBM)BDY(BDY(p)),0,0,rp);
1.100 noro 2420: }
1.98 noro 2421:
2422: NBP fnode_to_nbp(FNODE f)
2423: {
2424: Q r;
2425: int n,i;
2426: NBM m;
2427: V v;
2428: NBP u,u1,u2;
2429: NODE t,b;
2430:
2431: if ( f->id == I_FORMULA ) {
2432: r = eval(f);
2433: NEWNBM(m);
2434: if ( OID(r) == O_N ) {
2435: m->d = 0; m->c = (Q)r; m->b = 0;
2436: } else {
2437: v = VR((P)r);
2438: m->d = 1; m->c = ONE; NEWNBMBDY(m,1);
2439: if ( !strcmp(NAME(v),"x") ) NBM_SET(m->b,0);
2440: else NBM_CLR(m->b,0);
2441: }
2442: MKNODE(b,m,0); MKNBP(u,b);
2443: return u;
2444: } else if ( IS_NARYADD(f) ) {
2445: t = (NODE)FA1(f); u = fnode_to_nbp((FNODE)BDY(t));
2446: for ( t = NEXT(t); t; t = NEXT(t) ) {
2447: u1 = fnode_to_nbp((FNODE)BDY(t));
2448: addnbp(CO,u,u1,&u2); u = u2;
2449: }
2450: return u;
2451: } else if ( IS_NARYMUL(f) ) {
2452: t = (NODE)FA1(f); u = fnode_to_nbp((FNODE)BDY(t));
2453: for ( t = NEXT(t); t; t = NEXT(t) ) {
2454: u1 = fnode_to_nbp((FNODE)BDY(t));
2455: mulnbp(CO,u,u1,&u2); u = u2;
2456: }
2457: return u;
2458: } else if ( IS_BINARYPWR(f) ) {
2459: u = fnode_to_nbp((FNODE)FA1(f));
2460: r = eval((FNODE)FA2(f));
2461: pwrnbp(CO,u,r,&u1);
2462: return u1;
1.70 noro 2463: }
2464: }
2465:
1.105 noro 2466: void Pnqt_comp(NODE arg,Q *rp)
1.80 noro 2467: {
1.87 noro 2468: QUOTE q1,q2;
1.80 noro 2469: FNODE f1,f2;
2470: int r;
2471:
1.87 noro 2472: q1 = (QUOTE)ARG0(arg); f1 = (FNODE)BDY(q1);
2473: q2 = (QUOTE)ARG1(arg); f2 = (FNODE)BDY(q2);
1.97 noro 2474: f1 = fnode_normalize(f1,0);
2475: f2 = fnode_normalize(f2,0);
1.95 noro 2476: r = nfnode_comp(f1,f2);
1.80 noro 2477: STOQ(r,*rp);
2478: }
2479:
1.108 ! noro 2480: int fnode_is_var(FNODE f)
! 2481: {
! 2482: Obj obj;
! 2483: VL vl,t,s;
! 2484: DCP dc;
! 2485:
! 2486: if ( fnode_is_coef(f) ) return 0;
! 2487: switch ( f->id ) {
! 2488: case I_PAREN:
! 2489: return fnode_is_var(FA0(f));
! 2490:
! 2491: case I_FORMULA:
! 2492: obj = FA0(f);
! 2493: if ( obj && OID(obj) == O_P ) {
! 2494: dc = DC((P)obj);
! 2495: if ( !cmpq(DEG(dc),ONE) && !NEXT(dc)
! 2496: && !arf_comp(CO,(Obj)COEF(dc),(Obj)ONE) ) return 1;
! 2497: else return 0;
! 2498: } else return 0;
! 2499:
! 2500: default:
! 2501: return 0;
! 2502: }
! 2503: }
! 2504:
! 2505: int fnode_is_coef(FNODE f)
! 2506: {
! 2507: Obj obj;
! 2508: VL vl,t,s;
! 2509:
! 2510: switch ( f->id ) {
! 2511: case I_MINUS: case I_PAREN:
! 2512: return fnode_is_coef(FA0(f));
! 2513:
! 2514: case I_FORMULA:
! 2515: obj = FA0(f);
! 2516: if ( !obj ) return 1;
! 2517: else if ( OID(obj) == O_QUOTE )
! 2518: return fnode_is_coef(BDY((QUOTE)obj));
! 2519: else if ( NUM(obj) ) return 1;
! 2520: else if ( OID(obj) == O_P || OID(obj) == O_R) {
! 2521: get_vars_recursive(obj,&vl);
! 2522: for ( t = vl; t; t = NEXT(t) ) {
! 2523: for ( s = qt_current_coef; s; s = NEXT(s) )
! 2524: if ( t->v == s->v ) break;
! 2525: if ( !s ) return 0;
! 2526: }
! 2527: return 1;
! 2528: } else return 0;
! 2529:
! 2530: case I_BOP:
! 2531: return fnode_is_coef(FA1(f)) && fnode_is_coef(FA2(f));
! 2532:
! 2533: default:
! 2534: return 0;
! 2535: }
! 2536: }
! 2537:
! 2538: int fnode_is_number(FNODE f)
1.69 noro 2539: {
2540: Obj obj;
2541:
2542: switch ( f->id ) {
2543: case I_MINUS: case I_PAREN:
2544: return fnode_is_number(FA0(f));
2545:
2546: case I_FORMULA:
2547: obj = FA0(f);
2548: if ( !obj ) return 1;
2549: else if ( OID(obj) == O_QUOTE )
2550: return fnode_is_number(BDY((QUOTE)obj));
2551: else if ( NUM(obj) ) return 1;
2552: else return 0;
2553:
2554: case I_BOP:
2555: return fnode_is_number(FA1(f)) && fnode_is_number(FA2(f));
2556:
2557: default:
2558: return 0;
2559: }
2560: }
2561:
2562: int fnode_is_rational(FNODE f)
2563: {
2564: Obj obj;
2565:
2566: switch ( f->id ) {
2567: case I_MINUS: case I_PAREN:
2568: return fnode_is_number(FA0(f));
2569:
2570: case I_FORMULA:
2571: obj = FA0(f);
2572: if ( !obj ) return 1;
2573: else if ( OID(obj) == O_QUOTE )
2574: return fnode_is_rational(BDY((QUOTE)obj));
2575: else if ( NUM(obj) && RATN(obj) ) return 1;
2576: else return 0;
2577:
2578: case I_BOP:
2579: if ( !strcmp(((ARF)FA0(f))->name,"^") )
2580: return fnode_is_rational(FA1(f)) && fnode_is_integer(FA2(f));
2581: else
2582: return fnode_is_rational(FA1(f)) && fnode_is_rational(FA2(f));
2583:
2584: default:
2585: return 0;
2586: }
2587: }
2588:
2589: int fnode_is_integer(FNODE f)
2590: {
2591: Obj obj;
2592:
2593: switch ( f->id ) {
2594: case I_MINUS: case I_PAREN:
2595: return fnode_is_integer(FA0(f));
2596:
2597: case I_FORMULA:
2598: obj = FA0(f);
2599: if ( !obj ) return 1;
2600: else if ( OID(obj) == O_QUOTE )
2601: return fnode_is_integer(BDY((QUOTE)obj));
2602: else if ( INT(obj)) return 1;
2603: else return 0;
2604:
2605: case I_BOP:
1.70 noro 2606: switch ( ((ARF)FA0(f))->name[0] ) {
2607: case '^':
2608: return fnode_is_integer(FA1(f))
2609: && fnode_is_nonnegative_integer(FA2(f));
2610: case '/':
2611: return fnode_is_integer(FA1(f)) &&
2612: ( fnode_is_one(FA2(f)) || fnode_is_minusone(FA2(f)) );
2613: default:
2614: return fnode_is_integer(FA1(f)) && fnode_is_integer(FA2(f));
2615: }
2616: break;
2617:
1.69 noro 2618: default:
2619: return 0;
2620: }
2621: }
2622:
2623: int fnode_is_nonnegative_integer(FNODE f)
2624: {
2625: Q n;
2626:
2627: n = eval(f);
2628: if ( !n || (INT(n) && SGN(n) > 0) ) return 1;
2629: else return 0;
2630: }
2631:
2632: int fnode_is_one(FNODE f)
2633: {
2634: Q n;
2635:
2636: n = eval(f);
2637: if ( UNIQ(n) ) return 1;
2638: else return 0;
2639: }
2640:
2641: int fnode_is_minusone(FNODE f)
2642: {
2643: Q n;
2644:
2645: n = eval(f);
2646: if ( MUNIQ(n) ) return 1;
2647: else return 0;
2648: }
2649:
2650: int fnode_is_dependent(FNODE f,V v)
2651: {
2652: Obj obj;
2653: FNODE arg;
2654: NODE t;
2655:
2656: switch ( f->id ) {
2657: case I_MINUS: case I_PAREN:
2658: return fnode_is_dependent(FA0(f),v);
2659:
2660: case I_FORMULA:
2661: obj = FA0(f);
2662: if ( !obj ) return 0;
2663: else if ( OID(obj) == O_QUOTE )
2664: return fnode_is_dependent(BDY((QUOTE)obj),v);
2665: else if ( obj_is_dependent(obj,v) ) return 1;
2666: else return 0;
2667:
2668: case I_BOP:
2669: return fnode_is_dependent(FA1(f),v) || fnode_is_dependent(FA2(f),v);
2670:
2671: case I_FUNC:
2672: arg = (FNODE)FA1(f);
2673: for ( t = FA0(arg); t; t = NEXT(t) )
2674: if ( fnode_is_dependent(BDY(t),v) ) return 1;
2675: return 0;
2676:
2677: default:
2678: return 0;
2679: }
1.1 noro 2680: }
1.70 noro 2681:
1.72 noro 2682:
1.76 noro 2683: FNODE fnode_normalize(FNODE f,int expand)
1.70 noro 2684: {
1.73 noro 2685: FNODE a1,a2,mone,r,b2;
1.72 noro 2686: NODE n;
1.70 noro 2687: Q q;
2688:
1.103 noro 2689: if ( f->normalized && (f->expanded == expand) ) return f;
1.72 noro 2690: STOQ(-1,q);
2691: mone = mkfnode(1,I_FORMULA,q);
1.70 noro 2692: switch ( f->id ) {
2693: case I_PAREN:
1.89 noro 2694: r = fnode_normalize(FA0(f),expand);
2695: break;
1.71 noro 2696:
2697: case I_MINUS:
1.108 ! noro 2698: r = nfnode_mul_coef((Obj)q,
1.76 noro 2699: fnode_normalize(FA0(f),expand),expand);
1.89 noro 2700: break;
1.71 noro 2701:
1.70 noro 2702: case I_BOP:
2703: /* arf fnode fnode */
1.76 noro 2704: a1 = fnode_normalize(FA1(f),expand);
2705: a2 = fnode_normalize(FA2(f),expand);
1.72 noro 2706: switch ( OPNAME(f) ) {
2707: case '+':
1.95 noro 2708: r = nfnode_add(a1,a2,expand);
1.89 noro 2709: break;
1.70 noro 2710: case '-':
1.108 ! noro 2711: a2 = nfnode_mul_coef((Obj)q,a2,expand);
1.95 noro 2712: r = nfnode_add(a1,a2,expand);
1.89 noro 2713: break;
1.72 noro 2714: case '*':
1.95 noro 2715: r = nfnode_mul(a1,a2,expand);
1.89 noro 2716: break;
1.70 noro 2717: case '/':
1.95 noro 2718: a2 = nfnode_pwr(a2,mone,expand);
2719: r = nfnode_mul(a1,a2,expand);
1.89 noro 2720: break;
1.73 noro 2721: case '^':
1.95 noro 2722: r = nfnode_pwr(a1,a2,expand);
1.89 noro 2723: break;
1.70 noro 2724: default:
1.89 noro 2725: r = mkfnode(3,I_BOP,FA0(f),a1,a2);
2726: break;
1.70 noro 2727: }
2728: break;
1.71 noro 2729:
1.70 noro 2730: case I_NARYOP:
1.72 noro 2731: switch ( OPNAME(f) ) {
1.71 noro 2732: case '+':
1.73 noro 2733: n = (NODE)FA1(f);
1.76 noro 2734: r = fnode_normalize(BDY(n),expand); n = NEXT(n);
1.72 noro 2735: for ( ; n; n = NEXT(n) ) {
1.76 noro 2736: a1 = fnode_normalize(BDY(n),expand);
1.95 noro 2737: r = nfnode_add(r,a1,expand);
1.72 noro 2738: }
1.89 noro 2739: break;
1.70 noro 2740: case '*':
1.73 noro 2741: n = (NODE)FA1(f);
1.76 noro 2742: r = fnode_normalize(BDY(n),expand); n = NEXT(n);
1.72 noro 2743: for ( ; n; n = NEXT(n) ) {
1.76 noro 2744: a1 = fnode_normalize(BDY(n),expand);
1.95 noro 2745: r = nfnode_mul(r,a1,expand);
1.72 noro 2746: }
1.89 noro 2747: break;
1.70 noro 2748: default:
1.72 noro 2749: error("fnode_normallize : cannot happen");
1.70 noro 2750: }
1.89 noro 2751: break;
1.72 noro 2752:
1.70 noro 2753: default:
1.76 noro 2754: return fnode_apply(f,fnode_normalize,expand);
1.70 noro 2755: }
1.89 noro 2756: r->normalized = 1;
2757: r->expanded = expand;
2758: return r;
1.70 noro 2759: }
2760:
1.76 noro 2761: FNODE fnode_apply(FNODE f,FNODE (*func)(),int expand)
1.70 noro 2762: {
2763: fid_spec_p spec;
2764: FNODE r;
2765: int i,n;
2766: NODE t,t0,s;
2767:
2768: get_fid_spec(f->id,&spec);
2769: for ( n = 0; spec->type[n] != A_end; n++ );
2770: NEWFNODE(r,n); r->id = f->id;
2771: for ( i = 0; i < n; i++ ) {
2772: switch ( spec->type[i] ) {
2773: case A_fnode:
1.78 noro 2774: r->arg[i] = func(f->arg[i],expand);
1.70 noro 2775: break;
2776: case A_node:
2777: s = (NODE)f->arg[i];
2778: for ( t0 = 0; s; s = NEXT(s) ) {
2779: NEXTNODE(t0,t);
1.76 noro 2780: BDY(t) = (pointer)func((FNODE)BDY(s),expand);
1.70 noro 2781: }
2782: if ( t0 ) NEXT(t) = 0;
2783: r->arg[i] = t0;
2784: break;
2785: default:
2786: r->arg[i] = f->arg[i];
2787: break;
2788: }
2789: }
2790: return r;
2791: }
2792:
1.95 noro 2793: FNODE nfnode_add(FNODE f1,FNODE f2,int expand)
1.71 noro 2794: {
1.72 noro 2795: NODE n1,n2,r0,r;
2796: FNODE b1,b2;
2797: int s;
1.108 ! noro 2798: Obj c1,c2,c;
1.72 noro 2799:
1.77 noro 2800: if ( IS_ZERO(f1) ) return f2;
2801: else if ( IS_ZERO(f2) ) return f1;
1.75 noro 2802: f1 = to_naryadd(f1); f2 = to_naryadd(f2);
2803: n1 = (NODE)FA1(f1); n2 = (NODE)FA1(f2);
1.72 noro 2804: r0 = 0;
2805: while ( n1 && n2 ) {
1.75 noro 2806: fnode_coef_body(BDY(n1),&c1,&b1); fnode_coef_body(BDY(n2),&c2,&b2);
1.95 noro 2807: if ( (s = nfnode_comp(b1,b2)) > 0 ) {
1.73 noro 2808: NEXTNODE(r0,r); BDY(r) = BDY(n1); n1 = NEXT(n1);
1.72 noro 2809: } else if ( s < 0 ) {
1.73 noro 2810: NEXTNODE(r0,r); BDY(r) = BDY(n2); n2 = NEXT(n2);
1.72 noro 2811: } else {
1.108 ! noro 2812: arf_add(CO,c1,c2,&c);
1.72 noro 2813: if ( c ) {
1.95 noro 2814: NEXTNODE(r0,r); BDY(r) = nfnode_mul_coef(c,b1,expand);
1.71 noro 2815: }
1.72 noro 2816: n1 = NEXT(n1); n2 = NEXT(n2);
1.71 noro 2817: }
2818: }
1.72 noro 2819: if ( n1 )
2820: if ( r0 ) NEXT(r) = n1;
2821: else r0 = n1;
2822: else if ( n2 )
2823: if ( r0 ) NEXT(r) = n2;
2824: else r0 = n2;
2825: else if ( r0 )
2826: NEXT(r) = 0;
2827:
1.106 noro 2828: return fnode_node_to_nary(addfs,r0);
1.75 noro 2829: }
2830:
1.106 noro 2831: FNODE fnode_node_to_nary(ARF op,NODE n)
1.75 noro 2832: {
1.106 noro 2833: if ( !n ) {
2834: if ( op->name[0] == '+' )
2835: return mkfnode(1,I_FORMULA,0);
2836: else
2837: return mkfnode(1,I_FORMULA,ONE);
2838: } else if ( !NEXT(n) ) return BDY(n);
2839: else return mkfnode(2,I_NARYOP,op,n);
1.71 noro 2840: }
2841:
1.95 noro 2842: FNODE nfnode_mul(FNODE f1,FNODE f2,int expand)
1.71 noro 2843: {
1.72 noro 2844: NODE n1,n2,r0,r,r1;
1.76 noro 2845: FNODE b1,b2,e1,e2,cc,t,t1;
1.72 noro 2846: FNODE *m;
2847: int s;
1.108 ! noro 2848: Obj c1,c2,c;
! 2849: Num e;
1.75 noro 2850: int l1,l,i,j;
1.72 noro 2851:
1.77 noro 2852: if ( IS_ZERO(f1) || IS_ZERO(f2) ) return mkfnode(1,I_FORMULA,0);
1.108 ! noro 2853: else if ( fnode_is_coef(f1) )
! 2854: return nfnode_mul_coef((Obj)eval(f1),f2,expand);
! 2855: else if ( fnode_is_coef(f2) )
! 2856: return nfnode_mul_coef((Obj)eval(f2),f1,expand);
1.76 noro 2857:
2858: if ( expand && IS_NARYADD(f1) ) {
2859: t = mkfnode(1,I_FORMULA,0);
2860: for ( n1 = (NODE)FA1(f1); n1; n1 = NEXT(n1) ) {
1.95 noro 2861: t1 = nfnode_mul(BDY(n1),f2,expand);
2862: t = nfnode_add(t,t1,expand);
1.76 noro 2863: }
2864: return t;
2865: }
2866: if ( expand && IS_NARYADD(f2) ) {
2867: t = mkfnode(1,I_FORMULA,0);
2868: for ( n2 = (NODE)FA1(f2); n2; n2 = NEXT(n2) ) {
1.95 noro 2869: t1 = nfnode_mul(f1,BDY(n2),expand);
2870: t = nfnode_add(t,t1,expand);
1.76 noro 2871: }
2872: return t;
2873: }
1.72 noro 2874:
1.75 noro 2875: fnode_coef_body(f1,&c1,&b1); fnode_coef_body(f2,&c2,&b2);
1.108 ! noro 2876: arf_mul(CO,c1,c2,&c);
1.72 noro 2877: if ( !c ) return mkfnode(1,I_FORMULA,0);
1.71 noro 2878:
1.76 noro 2879:
1.75 noro 2880: n1 = (NODE)FA1(to_narymul(b1)); n2 = (NODE)FA1(to_narymul(b2));
2881: l1 = length(n1); l = l1+length(n2);
1.72 noro 2882: m = (FNODE *)ALLOCA(l*sizeof(FNODE));
2883: for ( r = n1, i = 0; i < l1; r = NEXT(r), i++ ) m[i] = BDY(r);
2884: for ( r = n2; r; r = NEXT(r) ) {
1.103 noro 2885: if ( i == 0 || (expand == 2) )
1.72 noro 2886: m[i++] = BDY(r);
2887: else {
1.75 noro 2888: fnode_base_exp(m[i-1],&b1,&e1); fnode_base_exp(BDY(r),&b2,&e2);
2889: if ( compfnode(b1,b2) ) break;
2890: addnum(0,eval(e1),eval(e2),&e);
2891: if ( !e ) i--;
2892: else if ( UNIQ(e) )
2893: m[i-1] = b1;
2894: else
2895: m[i-1] = mkfnode(3,I_BOP,pwrfs,b1,mkfnode(1,I_FORMULA,e));
1.71 noro 2896: }
2897: }
1.75 noro 2898: for ( j = i-1; j >= 0; j-- ) {
2899: MKNODE(r1,m[j],r); r = r1;
2900: }
2901: if ( !UNIQ(c) ) {
2902: cc = mkfnode(1,I_FORMULA,c); MKNODE(r1,cc,r); r = r1;
1.72 noro 2903: }
1.106 noro 2904: return fnode_node_to_nary(mulfs,r);
1.73 noro 2905: }
2906:
1.95 noro 2907: FNODE nfnode_pwr(FNODE f1,FNODE f2,int expand)
1.73 noro 2908: {
1.89 noro 2909: FNODE b,b1,e1,e,cc,r,mf2,mone,inv;
1.108 ! noro 2910: Obj c,c1;
! 2911: Num nf2;
1.89 noro 2912: int ee;
2913: NODE arg,n,t0,t1;
1.76 noro 2914: Q q;
1.73 noro 2915:
1.77 noro 2916: if ( IS_ZERO(f2) ) return mkfnode(1,I_FORMULA,ONE);
2917: else if ( IS_ZERO(f1) ) return mkfnode(1,I_FORMULA,0);
1.108 ! noro 2918: else if ( fnode_is_coef(f1) ) {
1.73 noro 2919: if ( fnode_is_integer(f2) ) {
1.92 noro 2920: if ( fnode_is_one(f2) ) return f1;
2921: else {
1.108 ! noro 2922: arf_pwr(CO,eval(f1),(Obj)eval(f2),&c);
1.92 noro 2923: return mkfnode(1,I_FORMULA,c);
2924: }
1.108 ! noro 2925: } else {
! 2926: f1 = mkfnode(1,I_FORMULA,eval(f1));
1.73 noro 2927: return mkfnode(3,I_BOP,pwrfs,f1,f2);
1.108 ! noro 2928: }
1.92 noro 2929: } else if ( IS_BINARYPWR(f1) ) {
1.73 noro 2930: b1 = FA1(f1); e1 = FA2(f1);
1.95 noro 2931: e = nfnode_mul(e1,f2,expand);
1.73 noro 2932: if ( fnode_is_one(e) )
2933: return b1;
2934: else
2935: return mkfnode(3,I_BOP,FA0(f1),b1,e);
1.92 noro 2936: } else if ( expand && IS_NARYMUL(f1) && fnode_is_number(f2)
2937: && fnode_is_integer(f2) ) {
1.73 noro 2938: fnode_coef_body(f1,&c1,&b1);
1.89 noro 2939: nf2 = (Num)eval(f2);
1.108 ! noro 2940: arf_pwr(CO,c1,(Obj)nf2,&c);
1.89 noro 2941: ee = QTOS((Q)nf2);
1.75 noro 2942: cc = mkfnode(1,I_FORMULA,c);
1.89 noro 2943: if ( fnode_is_nonnegative_integer(f2) )
1.103 noro 2944: b = fnode_expand_pwr(b1,ee,expand);
1.89 noro 2945: else {
2946: STOQ(-1,q);
2947: mone = mkfnode(1,I_FORMULA,q);
1.92 noro 2948: b1 = to_narymul(b1);
1.89 noro 2949: for ( t0 = 0, n = (NODE)FA1(b1); n; n = NEXT(n) ) {
2950: inv = mkfnode(3,I_BOP,pwrfs,BDY(n),mone);
2951: MKNODE(t1,inv,t0); t0 = t1;
2952: }
1.106 noro 2953: b1 = fnode_node_to_nary(mulfs,t0);
1.103 noro 2954: b = fnode_expand_pwr(b1,-ee,expand);
1.89 noro 2955: }
1.75 noro 2956: if ( fnode_is_one(cc) )
2957: return b;
2958: else
1.106 noro 2959: return fnode_node_to_nary(mulfs,mknode(2,cc,b));
1.82 noro 2960: } else if ( expand && fnode_is_integer(f2)
2961: && fnode_is_nonnegative_integer(f2) ) {
1.76 noro 2962: q = (Q)eval(f2);
1.95 noro 2963: if ( PL(NM(q)) > 1 ) error("nfnode_pwr : exponent too large");
1.103 noro 2964: return fnode_expand_pwr(f1,QTOS(q),expand);
1.73 noro 2965: } else
2966: return mkfnode(3,I_BOP,pwrfs,f1,f2);
1.72 noro 2967: }
2968:
1.103 noro 2969: FNODE fnode_expand_pwr(FNODE f,int n,int expand)
1.76 noro 2970: {
1.103 noro 2971: int n1,i;
2972: FNODE f1,f2,fn;
2973: Q q;
1.76 noro 2974:
2975: if ( !n ) return mkfnode(1,I_FORMULA,ONE);
1.77 noro 2976: else if ( IS_ZERO(f) ) return mkfnode(1,I_FORMULA,0);
1.76 noro 2977: else if ( n == 1 ) return f;
2978: else {
1.103 noro 2979: switch ( expand ) {
2980: case 1:
2981: n1 = n/2;
2982: f1 = fnode_expand_pwr(f,n1,expand);
2983: f2 = nfnode_mul(f1,f1,expand);
2984: if ( n%2 ) f2 = nfnode_mul(f2,f,1);
2985: return f2;
2986: case 2:
2987: for ( i = 1, f1 = f; i < n; i++ )
2988: f1 = nfnode_mul(f1,f,expand);
2989: return f1;
2990: case 0: default:
2991: STOQ(n,q);
2992: fn = mkfnode(1,I_FORMULA,q);
2993: return mkfnode(3,I_BOP,pwrfs,f,fn);
2994: }
1.76 noro 2995: }
2996: }
2997:
1.72 noro 2998: /* f = b^e */
2999: void fnode_base_exp(FNODE f,FNODE *bp,FNODE *ep)
3000: {
1.75 noro 3001: if ( IS_BINARYPWR(f) ) {
1.72 noro 3002: *bp = FA1(f); *ep = FA2(f);
3003: } else {
3004: *bp = f; *ep = mkfnode(1,I_FORMULA,ONE);
3005: }
3006: }
3007:
3008: FNODE to_naryadd(FNODE f)
3009: {
3010: FNODE r;
3011: NODE n;
3012:
1.75 noro 3013: if ( IS_NARYADD(f) ) return f;
3014:
3015: NEWFNODE(r,2); r->id = I_NARYOP;
3016: FA0(r) = addfs; MKNODE(n,f,0); FA1(r) = n;
1.72 noro 3017: return r;
3018: }
3019:
3020: FNODE to_narymul(FNODE f)
3021: {
3022: FNODE r;
3023: NODE n;
3024:
1.75 noro 3025: if ( IS_NARYMUL(f) ) return f;
3026:
3027: NEWFNODE(r,2); r->id = I_NARYOP;
3028: FA0(r) = mulfs; MKNODE(n,f,0); FA1(r) = n;
1.72 noro 3029: return r;
3030: }
3031:
1.108 ! noro 3032: FNODE nfnode_mul_coef(Obj c,FNODE f,int expand)
1.72 noro 3033: {
1.76 noro 3034: FNODE b1,cc;
1.108 ! noro 3035: Obj c1,c2;
1.76 noro 3036: NODE n,r,r0;
1.72 noro 3037:
3038: if ( !c )
3039: return mkfnode(I_FORMULA,0);
1.75 noro 3040: else {
3041: fnode_coef_body(f,&c1,&b1);
1.108 ! noro 3042: arf_mul(CO,c,c1,&c2);
1.75 noro 3043: if ( UNIQ(c2) ) return b1;
3044: else {
3045: cc = mkfnode(1,I_FORMULA,c2);
3046: if ( fnode_is_number(b1) ) {
3047: if ( !fnode_is_one(b1) )
1.95 noro 3048: error("nfnode_mul_coef : cannot happen");
1.75 noro 3049: else
3050: return cc;
1.76 noro 3051: } else if ( IS_NARYMUL(b1) ) {
1.75 noro 3052: MKNODE(n,cc,FA1(b1));
1.106 noro 3053: return fnode_node_to_nary(mulfs,n);
1.76 noro 3054: } else if ( expand && IS_NARYADD(b1) ) {
3055: for ( r0 = 0, n = (NODE)FA1(b1); n; n = NEXT(n) ) {
3056: NEXTNODE(r0,r);
1.95 noro 3057: BDY(r) = nfnode_mul_coef(c2,BDY(n),expand);
1.76 noro 3058: }
3059: if ( r0 ) NEXT(r) = 0;
1.106 noro 3060: return fnode_node_to_nary(addfs,r0);
1.76 noro 3061: } else
1.106 noro 3062: return fnode_node_to_nary(mulfs,mknode(2,cc,b1));
1.72 noro 3063: }
1.71 noro 3064: }
3065: }
3066:
1.108 ! noro 3067: void fnode_coef_body(FNODE f,Obj *cp,FNODE *bp)
1.70 noro 3068: {
1.72 noro 3069: FNODE c;
1.70 noro 3070:
1.108 ! noro 3071: if ( fnode_is_coef(f) ) {
! 3072: *cp = (Obj)eval(f); *bp = mkfnode(1,I_FORMULA,ONE);
1.75 noro 3073: } else if ( IS_NARYMUL(f) ) {
3074: c=(FNODE)BDY((NODE)FA1(f));
1.108 ! noro 3075: if ( fnode_is_coef(c) ) {
! 3076: *cp = (Obj)eval(c);
1.106 noro 3077: *bp = fnode_node_to_nary(mulfs,NEXT((NODE)FA1(f)));
1.70 noro 3078: } else {
1.108 ! noro 3079: *cp = (Obj)ONE; *bp = f;
1.70 noro 3080: }
3081: } else {
1.108 ! noro 3082: *cp = (Obj)ONE; *bp = f;
1.70 noro 3083: }
1.80 noro 3084: }
3085:
1.95 noro 3086: int nfnode_comp_pwr(FNODE f1,FNODE f2);
1.80 noro 3087:
1.95 noro 3088: int nfnode_comp(FNODE f1,FNODE f2)
1.80 noro 3089: {
3090: NODE n1,n2;
1.95 noro 3091: int r,i1,i2,ret;
1.82 noro 3092: char *nm1,*nm2;
1.95 noro 3093: FNODE b1,b2,e1,e2,g,a1,a2,fn1,fn2;
1.108 ! noro 3094: Num ee,ee1;
! 3095: Obj c1,c2;
1.80 noro 3096:
3097: if ( IS_NARYADD(f1) || IS_NARYADD(f2) ) {
3098: f1 = to_naryadd(f1); f2 = to_naryadd(f2);
3099: n1 = (NODE)FA1(f1); n2 = (NODE)FA1(f2);
3100: while ( n1 && n2 )
1.95 noro 3101: if ( r = nfnode_comp(BDY(n1),BDY(n2)) ) return r;
1.80 noro 3102: else {
3103: n1 = NEXT(n1); n2 = NEXT(n2);
3104: }
1.85 noro 3105: return n1?1:(n2?-1:0);
1.80 noro 3106: }
3107: if ( IS_NARYMUL(f1) || IS_NARYMUL(f2) ) {
1.83 noro 3108: fnode_coef_body(f1,&c1,&b1);
3109: fnode_coef_body(f2,&c2,&b2);
1.108 ! noro 3110: if ( !compfnode(b1,b2) ) return arf_comp(CO,c1,c2);
1.83 noro 3111: b1 = to_narymul(b1); b2 = to_narymul(b2);
3112: n1 = (NODE)FA1(b1); n2 = (NODE)FA1(b2);
1.80 noro 3113: while ( 1 ) {
3114: while ( n1 && n2 && !compfnode(BDY(n1),BDY(n2)) ) {
3115: n1 = NEXT(n1); n2 = NEXT(n2);
3116: }
3117: if ( !n1 || !n2 ) {
1.85 noro 3118: return n1?1:(n2?-1:0);
1.80 noro 3119: }
3120: fnode_base_exp(BDY(n1),&b1,&e1);
3121: fnode_base_exp(BDY(n2),&b2,&e2);
3122:
1.95 noro 3123: if ( r = nfnode_comp(b1,b2) ) {
1.83 noro 3124: if ( r > 0 )
1.95 noro 3125: return nfnode_comp(e1,mkfnode(1,I_FORMULA,0));
1.83 noro 3126: else if ( r < 0 )
1.95 noro 3127: return nfnode_comp(mkfnode(1,I_FORMULA,0),e2);
1.83 noro 3128: } else {
3129: n1 = NEXT(n1); n2 = NEXT(n2);
3130: if ( fnode_is_number(e1) && fnode_is_number(e2) ) {
3131: /* f1 = t b^e1 ... , f2 = t b^e2 ... */
3132: subnum(0,eval(e1),eval(e2),&ee);
1.86 noro 3133: r = compnum(0,ee,0);
3134: if ( r > 0 ) {
1.83 noro 3135: g = mkfnode(3,I_BOP,pwrfs,b1,mkfnode(1,I_FORMULA,ee));
3136: MKNODE(n1,g,n1);
1.86 noro 3137: } else if ( r < 0 ) {
3138: chsgnnum(ee,&ee1);
3139: g = mkfnode(3,I_BOP,pwrfs,b1,mkfnode(1,I_FORMULA,ee1));
3140: MKNODE(n2,g,n2);
1.83 noro 3141: }
3142: } else {
1.95 noro 3143: r = nfnode_comp(e1,e2);
1.83 noro 3144: if ( r > 0 ) return 1;
3145: else if ( r < 0 ) return -1;
1.80 noro 3146: }
3147: }
3148: }
3149: }
3150: if ( IS_BINARYPWR(f1) || IS_BINARYPWR(f2) )
1.95 noro 3151: return nfnode_comp_pwr(f1,f2);
1.80 noro 3152:
1.95 noro 3153: /* now, IDs of f1 and f2 must be I_FORMULA, I_FUNC, I_IFUNC or I_PVAR */
1.106 noro 3154: /* I_IFUNC > I_PVAR > I_FUNC=I_FUNC_QARG > I_FORMULA */
1.80 noro 3155: switch ( f1->id ) {
3156: case I_FORMULA:
3157: switch ( f2->id ) {
3158: case I_FORMULA:
1.105 noro 3159: return arf_comp(qt_current_ord?qt_current_ord:CO,FA0(f1),FA0(f2));
1.95 noro 3160: case I_FUNC: case I_IFUNC: case I_PVAR:
1.80 noro 3161: return -1;
3162: default:
1.95 noro 3163: error("nfnode_comp : undefined");
1.80 noro 3164: }
3165: break;
1.106 noro 3166: case I_FUNC: case I_FUNC_QARG:
1.80 noro 3167: switch ( f2->id ) {
3168: case I_FORMULA:
3169: return 1;
1.95 noro 3170: case I_PVAR: case I_IFUNC:
3171: return -1;
1.106 noro 3172: case I_FUNC: case I_FUNC_QARG:
1.82 noro 3173: nm1 = ((FUNC)FA0(f1))->name; nm2 = ((FUNC)FA0(f2))->name;
3174: r = strcmp(nm1,nm2);
3175: if ( r > 0 ) return 1;
3176: else if ( r < 0 ) return -1;
1.80 noro 3177: else {
3178: /* compare args */
3179: n1 = FA0((FNODE)FA1(f1)); n2 = FA0((FNODE)FA1(f2));
3180: while ( n1 && n2 )
1.95 noro 3181: if ( r = nfnode_comp(BDY(n1),BDY(n2)) ) return r;
1.82 noro 3182: else {
3183: n1 = NEXT(n1); n2 = NEXT(n2);
3184: }
1.85 noro 3185: return n1?1:(n2?-1:0);
1.80 noro 3186: }
3187: break;
3188: default:
1.95 noro 3189: error("nfnode_comp : undefined");
1.80 noro 3190: }
3191: case I_PVAR:
3192: switch ( f2->id ) {
1.106 noro 3193: case I_FORMULA: case I_FUNC: case I_FUNC_QARG:
1.80 noro 3194: return 1;
1.95 noro 3195: case I_IFUNC:
3196: return -1;
1.80 noro 3197: case I_PVAR:
3198: i1 = (int)FA0(f1); i2 = (int)FA0(f2);
3199: if ( i1 > i2 ) return 1;
3200: else if ( i1 < i2 ) return -1;
3201: else return 0;
3202: default:
1.95 noro 3203: error("nfnode_comp : undefined");
3204: }
3205: break;
3206: case I_IFUNC:
3207: switch ( f2->id ) {
1.106 noro 3208: case I_FORMULA: case I_FUNC: case I_FUNC_QARG: case I_PVAR:
1.95 noro 3209: return 1;
3210: case I_IFUNC:
3211: i1 = (int)FA0((FNODE)FA0(f1));
3212: i2 = (int)FA0((FNODE)FA0(f2));
3213: if ( i1 > i2 ) return 1;
3214: else if ( i1 < i2 ) return -1;
3215: else {
3216: /* compare args */
3217: n1 = FA0((FNODE)FA1(f1)); n2 = FA0((FNODE)FA1(f2));
3218: while ( n1 && n2 )
3219: if ( r = nfnode_comp(BDY(n1),BDY(n2)) ) return r;
3220: else {
3221: n1 = NEXT(n1); n2 = NEXT(n2);
3222: }
3223: return n1?1:(n2?-1:0);
3224: }
3225: break;
3226:
3227: default:
3228: error("nfnode_comp : undefined");
1.80 noro 3229: }
3230: break;
3231: default:
1.95 noro 3232: error("nfnode_comp : undefined");
1.80 noro 3233: }
3234: }
3235:
1.95 noro 3236: int nfnode_comp_pwr(FNODE f1,FNODE f2)
1.80 noro 3237: {
3238: FNODE b1,b2,e1,e2;
3239: int r;
3240:
3241: fnode_base_exp(f1,&b1,&e1);
3242: fnode_base_exp(f2,&b2,&e2);
1.95 noro 3243: if ( r = nfnode_comp(b1,b2) ) {
1.83 noro 3244: if ( r > 0 )
1.95 noro 3245: return nfnode_comp(e1,mkfnode(1,I_FORMULA,0));
1.83 noro 3246: else if ( r < 0 )
1.95 noro 3247: return nfnode_comp(mkfnode(1,I_FORMULA,0),e2);
3248: } else return nfnode_comp(e1,e2);
1.70 noro 3249: }
1.87 noro 3250:
1.88 noro 3251: NODE append_node(NODE a1,NODE a2)
3252: {
3253: NODE t,t0;
3254:
3255: if ( !a1 )
3256: return a2;
3257: else {
3258: for ( t0 = 0; a1; a1 = NEXT(a1) ) {
3259: NEXTNODE(t0,t); BDY(t) = BDY(a1);
3260: }
3261: NEXT(t) = a2;
3262: return t0;
3263: }
3264: }
3265:
1.95 noro 3266: int nfnode_match(FNODE f,FNODE pat,NODE *rp)
1.87 noro 3267: {
3268: NODE m,m1,m2,base,exp,fa,pa,n;
3269: LIST l;
3270: QUOTE qp,qf;
1.96 noro 3271: FNODE fbase,fexp,a,fh;
1.87 noro 3272: FUNC ff,pf;
3273: int r;
3274:
1.97 noro 3275: if ( !pat )
3276: if ( !f ) {
3277: *rp = 0;
3278: return 1;
3279: } else
3280: return 0;
3281: else if ( !f )
3282: return 0;
1.87 noro 3283: switch ( pat->id ) {
3284: case I_PVAR:
3285: /* [[pat,f]] */
1.103 noro 3286: *rp = mknode(1,mknode(2,(int)FA0(pat),f));
1.87 noro 3287: return 1;
3288:
3289: case I_FORMULA:
1.93 noro 3290: if ( f->id == I_FORMULA && !arf_comp(CO,(Obj)FA0(f),(Obj)FA0(pat)) ) {
1.87 noro 3291: *rp = 0; return 1;
3292: } else
3293: return 0;
3294:
3295: case I_BOP:
3296: /* OPNAME should be "^" */
3297: if ( !IS_BINARYPWR(pat) )
1.95 noro 3298: error("nfnode_match : invalid BOP");
1.87 noro 3299: if ( IS_BINARYPWR(f) ) {
3300: fbase = FA1(f); fexp = FA2(f);
3301: } else {
3302: fbase = f; fexp = mkfnode(1,I_FORMULA,ONE);
3303: }
1.95 noro 3304: if ( !nfnode_match(fbase,FA1(pat),&base) ) return 0;
1.106 noro 3305: a = rewrite_fnode(FA2(pat),base,0);
1.95 noro 3306: if ( !nfnode_match(fexp,a,&exp) ) return 0;
1.88 noro 3307: else {
3308: *rp = append_node(base,exp);
3309: return 1;
3310: }
1.87 noro 3311: break;
3312:
1.95 noro 3313: case I_FUNC: case I_IFUNC:
1.87 noro 3314: if ( f->id != I_FUNC ) return 0;
1.95 noro 3315: ff = (FUNC)FA0(f);
3316: if ( pat->id == I_FUNC ) {
3317: pf = (FUNC)FA0(pat);
3318: if ( strcmp(ff->fullname,pf->fullname) ) return 0;
3319: m = 0;
3320: } else {
1.96 noro 3321: /* XXX : I_FUNC_HEAD is a dummy id to pass FUNC */
3322: fh = mkfnode(1,I_FUNC_HEAD,FA0(f));
3323: m = mknode(1,mknode(2,FA0((FNODE)FA0(pat)),fh),0);
1.95 noro 3324: }
1.87 noro 3325: /* FA1(f) and FA1(pat) are I_LIST */
3326: fa = (NODE)FA0((FNODE)FA1(f));
3327: pa = (NODE)FA0((FNODE)FA1(pat));
3328: while ( fa && pa ) {
1.106 noro 3329: a = rewrite_fnode(BDY(pa),m,0);
1.95 noro 3330: if ( !nfnode_match(BDY(fa),a,&m1) ) return 0;
1.88 noro 3331: m = append_node(m1,m);
3332: fa = NEXT(fa); pa = NEXT(pa);
1.87 noro 3333: }
3334: if ( fa || pa ) return 0;
3335: else {
3336: *rp = m;
3337: return 1;
3338: }
3339:
3340: case I_NARYOP:
3341: if ( IS_NARYADD(pat) )
1.95 noro 3342: return nfnode_match_naryadd(f,pat,rp);
1.87 noro 3343: else if ( IS_NARYMUL(pat) )
1.95 noro 3344: return nfnode_match_narymul(f,pat,rp);
1.87 noro 3345: else
1.95 noro 3346: error("nfnode_match : invalid NARYOP");
1.87 noro 3347: break;
3348:
3349: default:
1.95 noro 3350: error("nfnode_match : invalid pattern");
1.87 noro 3351: }
3352: }
3353:
1.88 noro 3354: /* remove i-th element */
1.87 noro 3355:
1.88 noro 3356: FNODE fnode_removeith_naryadd(FNODE p,int i)
3357: {
3358: int k,l;
3359: NODE t,r0,r,a;
3360:
3361: a = (NODE)FA1(p);
3362: l = length(a);
3363: if ( i < 0 || i >= l ) error("fnode_removeith_naryadd: invalid index");
3364: else if ( i == 0 )
1.106 noro 3365: return fnode_node_to_nary(addfs,NEXT(a));
1.88 noro 3366: else {
3367: for ( r0 = 0, k = 0, t = a; k < i; k++, t = NEXT(t) ) {
3368: NEXTNODE(r0,r);
3369: BDY(r) = BDY(t);
3370: }
1.94 noro 3371: NEXT(r) = NEXT(t);
1.106 noro 3372: return fnode_node_to_nary(addfs,r0);
1.88 noro 3373: }
3374:
3375: }
1.87 noro 3376:
1.88 noro 3377: /* a0,...,a(i-1) */
3378: FNODE fnode_left_narymul(FNODE p,int i)
1.87 noro 3379: {
1.88 noro 3380: int k,l;
3381: NODE t,r0,r,a;
3382:
3383: a = (NODE)FA1(p);
3384: l = length(a);
3385: if ( i < 0 || i >= l ) error("fnode_left_narymul : invalid index");
1.97 noro 3386: if ( i == 0 ) return 0;
1.88 noro 3387: else if ( i == 1 ) return (FNODE)BDY(a);
3388: else {
3389: for ( r0 = 0, k = 0, t = a; k < i; k++, t = NEXT(t) ) {
3390: NEXTNODE(r0,r);
3391: BDY(r) = BDY(t);
3392: }
3393: NEXT(r) = 0;
1.106 noro 3394: return fnode_node_to_nary(mulfs,r0);
1.88 noro 3395: }
3396: }
3397:
3398: /* a(i+1),...,a(l-1) */
3399: FNODE fnode_right_narymul(FNODE p,int i)
3400: {
3401: NODE a,t;
3402: int l,k;
3403:
3404: a = (NODE)FA1(p);
3405: l = length(a);
3406: if ( i < 0 || i >= l ) error("fnode_right_narymul : invalid index");
1.97 noro 3407: if ( i == l-1 ) return 0;
1.88 noro 3408: else {
3409: for ( k = 0, t = a; k <= i; k++, t = NEXT(t) );
1.106 noro 3410: return fnode_node_to_nary(mulfs,t);
1.88 noro 3411: }
3412: }
3413:
1.95 noro 3414: int nfnode_match_naryadd(FNODE f,FNODE p,NODE *rp)
1.88 noro 3415: {
3416: int fl,pl,fi,pi;
3417: NODE fa,pa,t,s,m,m1;
3418: FNODE fr,pr,prr,pivot;
1.87 noro 3419:
3420: f = to_naryadd(f);
1.88 noro 3421: fa = (NODE)FA1(f); fl = length(fa);
3422: pa = (NODE)FA1(p); pl = length(pa);
3423: if ( fl < pl ) return 0;
3424: else if ( pl == 1 ) {
3425: if ( fl == 1 )
1.95 noro 3426: return nfnode_match(BDY(fa),BDY(pa),rp);
1.87 noro 3427: else
3428: return 0;
3429: } else {
1.88 noro 3430: for ( t = pa, pi = 0; t; t = NEXT(t), pi++ )
3431: if ( ((FNODE)BDY(t))->id != I_PVAR ) break;
3432: if ( !t ) {
3433: /* all are I_PVAR */
3434: m = 0;
3435: for ( t = pa, s = fa; NEXT(t); t = NEXT(t), s = NEXT(s) ) {
1.95 noro 3436: nfnode_match(BDY(s),BDY(t),&m1);
1.88 noro 3437: m = append_node(m1,m);
3438: }
3439: if ( !NEXT(s) )
3440: fr = (FNODE)BDY(s);
3441: else
3442: fr = mkfnode(2,I_NARYOP,FA0(f),s);
1.95 noro 3443: nfnode_match(fr,BDY(t),&m1);
1.88 noro 3444: *rp = append_node(m1,m);
3445: return 1;
3446: } else {
3447: pivot = (FNODE)BDY(t);
3448: pr = fnode_removeith_naryadd(p,pi);
3449: for ( s = fa, fi = 0; s; s = NEXT(s), fi++ ) {
1.95 noro 3450: if ( nfnode_match(BDY(s),pivot,&m) ) {
1.88 noro 3451: fr = fnode_removeith_naryadd(f,fi);
1.106 noro 3452: prr = rewrite_fnode(pr,m,0);
1.95 noro 3453: if ( nfnode_match(fr,prr,&m1) ) {
1.88 noro 3454: *rp = append_node(m,m1);
3455: return 1;
3456: }
3457: }
3458: }
3459: return 0;
3460: }
1.87 noro 3461: }
3462: }
3463:
1.95 noro 3464: int nfnode_match_narymul(FNODE f,FNODE p,NODE *rp)
1.88 noro 3465: {
3466: int fl,pl,fi,pi;
3467: NODE fa,pa,t,s,m,m1;
3468: FNODE fr,pr,pleft,pleft1,pright,pright1,fleft,fright,pivot;
3469:
3470: f = to_narymul(f);
3471: fa = (NODE)FA1(f); fl = length(fa);
3472: pa = (NODE)FA1(p); pl = length(pa);
3473: if ( fl < pl ) return 0;
3474: else if ( pl == 1 ) {
3475: if ( fl == 1 )
1.95 noro 3476: return nfnode_match(BDY(fa),BDY(pa),rp);
1.88 noro 3477: else
3478: return 0;
3479: } else {
3480: for ( t = pa, pi = 0; t; t = NEXT(t), pi++ )
3481: if ( ((FNODE)BDY(t))->id != I_PVAR ) break;
3482: if ( !t ) {
3483: /* all are I_PVAR */
3484: m = 0;
3485: for ( t = pa, s = fa; NEXT(t); t = NEXT(t), s = NEXT(s) ) {
1.106 noro 3486: pr = rewrite_fnode(BDY(t),m,0);
1.95 noro 3487: if ( !nfnode_match(BDY(s),pr,&m1) ) return 0;
1.88 noro 3488: m = append_node(m1,m);
3489: }
3490: if ( !NEXT(s) )
3491: fr = (FNODE)BDY(s);
3492: else
3493: fr = mkfnode(2,I_NARYOP,FA0(f),s);
1.106 noro 3494: pr = rewrite_fnode(BDY(t),m,0);
1.95 noro 3495: if ( !nfnode_match(fr,pr,&m1) ) return 0;
1.88 noro 3496: *rp = append_node(m1,m);
3497: return 1;
3498: } else {
3499: pivot = (FNODE)BDY(t);
3500: pleft = fnode_left_narymul(p,pi);
3501: pright = fnode_right_narymul(p,pi);
3502: /* XXX : incomplete */
3503: for ( s = fa, fi = 0; s; s = NEXT(s), fi++ ) {
1.97 noro 3504: if ( fi < pi ) continue;
1.95 noro 3505: if ( nfnode_match(BDY(s),pivot,&m) ) {
1.88 noro 3506: fleft = fnode_left_narymul(f,fi);
1.106 noro 3507: pleft1 = rewrite_fnode(pleft,m,0);
1.95 noro 3508: if ( nfnode_match(fleft,pleft1,&m1) ) {
1.88 noro 3509: m = append_node(m1,m);
3510: fright = fnode_right_narymul(f,fi);
1.106 noro 3511: pright1 = rewrite_fnode(pright,m,0);
1.95 noro 3512: if ( nfnode_match(fright,pright1,&m1) ) {
1.88 noro 3513: *rp = append_node(m1,m);
3514: return 1;
3515: }
3516: }
3517: }
3518: }
3519: return 0;
3520: }
1.95 noro 3521: }
3522: }
3523:
3524: NODE nfnode_pvars(FNODE pat,NODE found)
3525: {
3526: int ind;
3527: NODE prev,t;
3528: int *pair;
3529:
3530: switch ( pat->id ) {
3531: case I_PVAR:
3532: ind = (int)FA0(pat);
3533: for ( prev = 0, t = found; t; prev = t, t = NEXT(t) ) {
3534: pair = (int *)BDY(t);
3535: if ( pair[0] == ind ) {
3536: pair[1]++;
3537: return found;
3538: }
3539: }
3540: pair = (int *)MALLOC_ATOMIC(sizeof(int)*2);
3541: pair[0] = ind; pair[1] = 1;
3542: if ( !prev )
3543: MKNODE(found,pair,0);
3544: else
3545: MKNODE(NEXT(prev),pair,0);
3546: return found;
3547:
3548: case I_FORMULA:
3549: return found;
3550:
3551: case I_BOP:
3552: /* OPNAME should be "^" */
3553: if ( !IS_BINARYPWR(pat) )
3554: error("nfnode_pvar : invalid BOP");
3555: found = nfnode_pvars(FA1(pat),found);
3556: found = nfnode_pvars(FA2(pat),found);
3557: return found;
3558:
3559: case I_FUNC:
3560: t = (NODE)FA0((FNODE)FA1(pat));
3561: for ( ; t; t = NEXT(t) )
3562: found = nfnode_pvars(BDY(t),found);
3563: return found;
3564:
3565: case I_NARYOP:
3566: t = (NODE)FA1(pat);
3567: for ( ; t; t = NEXT(t) )
3568: found = nfnode_pvars(BDY(t),found);
3569: return found;
3570:
3571: default:
3572: error("nfnode_match : invalid pattern");
1.88 noro 3573: }
3574: }