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