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