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