![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to strobj.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / builtin|
Return to strobj.c CVS log | Up to [local] / OpenXM_contrib2 / asir2000 / builtin |
1.6 noro 1: /*
2: * Copyright (c) 1994-2000 FUJITSU LABORATORIES LIMITED
3: * All rights reserved.
4: *
5: * FUJITSU LABORATORIES LIMITED ("FLL") hereby grants you a limited,
6: * non-exclusive and royalty-free license to use, copy, modify and
7: * redistribute, solely for non-commercial and non-profit purposes, the
8: * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and
9: * conditions of this Agreement. For the avoidance of doubt, you acquire
10: * only a limited right to use the SOFTWARE hereunder, and FLL or any
11: * third party developer retains all rights, including but not limited to
12: * copyrights, in and to the SOFTWARE.
13: *
14: * (1) FLL does not grant you a license in any way for commercial
15: * purposes. You may use the SOFTWARE only for non-commercial and
16: * non-profit purposes only, such as academic, research and internal
17: * business use.
18: * (2) The SOFTWARE is protected by the Copyright Law of Japan and
19: * international copyright treaties. If you make copies of the SOFTWARE,
20: * with or without modification, as permitted hereunder, you shall affix
21: * to all such copies of the SOFTWARE the above copyright notice.
22: * (3) An explicit reference to this SOFTWARE and its copyright owner
23: * shall be made on your publication or presentation in any form of the
24: * results obtained by use of the SOFTWARE.
25: * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.7 noro 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.6 noro 27: * for such modification or the source code of the modified part of the
28: * SOFTWARE.
29: *
30: * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
31: * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
32: * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
33: * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
34: * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
35: * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
36: * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
37: * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
38: * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
39: * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
40: * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
41: * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
42: * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
43: * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
44: * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
45: * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
46: * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
47: *
1.92 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.91 2005/11/02 06:32:44 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: {
1.91 noro 1317: NODE n,t,t0,args;
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.91 noro 1324: FNODE fi,f2,f1;
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;
1.91 noro 1405: case I_NARYOP:
1406: args = (NODE)FA1(f);
1407: write_tb("(",tb);
1408: switch ( OPNAME(f) ) {
1409: case '+':
1410: fnodetotex_tb((FNODE)BDY(args),tb);
1411: for ( args = NEXT(args); args; args = NEXT(args) ) {
1412: write_tb("+",tb);
1413: fnodetotex_tb((FNODE)BDY(args),tb);
1414: }
1415: break;
1416: case '*':
1417: f1 = (FNODE)BDY(args);
1418: if ( f1->id == I_FORMULA && MUNIQ(FA0(f1)) )
1419: write_tb("-",tb);
1420: else
1421: fnodetotex_tb(f1,tb);
1422: write_tb(" ",tb);
1423: for ( args = NEXT(args); args; args = NEXT(args) ) {
1424: /* XXX special care for DP */
1425: f2 = (FNODE)BDY(args);
1426: if ( f2->id == I_EV ) {
1427: n = (NODE)FA0(f2);
1428: for ( i = 0; n; n = NEXT(n), i++ ) {
1429: fi = (FNODE)BDY(n);
1430: if ( fi->id != I_FORMULA || FA0(fi) )
1431: break;
1432: }
1433: if ( n )
1434: fnodetotex_tb(f2,tb);
1435: } else
1436: fnodetotex_tb(f2,tb);
1437: }
1438: break;
1439: default:
1440: error("invalid nary op");
1441: break;
1442: }
1443: write_tb(")",tb);
1444: break;
1.23 noro 1445:
1446: case I_COP:
1447: switch( (cid)FA0(f) ) {
1448: case C_EQ:
1449: fnodetotex_tb((FNODE)FA1(f),tb);
1450: write_tb(" = ",tb);
1451: fnodetotex_tb((FNODE)FA2(f),tb);
1452: break;
1453: case C_NE:
1454: fnodetotex_tb((FNODE)FA1(f),tb);
1455: write_tb(" \\neq ",tb);
1456: fnodetotex_tb((FNODE)FA2(f),tb);
1457: break;
1458: case C_GT:
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 C_LT:
1464: fnodetotex_tb((FNODE)FA1(f),tb);
1.45 noro 1465: write_tb(" < ",tb);
1.23 noro 1466: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1467: break;
1.23 noro 1468: case C_GE:
1469: fnodetotex_tb((FNODE)FA1(f),tb);
1470: write_tb(" \\geq ",tb);
1471: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1472: break;
1.23 noro 1473: case C_LE:
1474: fnodetotex_tb((FNODE)FA1(f),tb);
1475: write_tb(" \\leq ",tb);
1476: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1477: break;
1478: }
1479: break;
1480:
1.23 noro 1481: case I_LOP:
1482: switch( (lid)FA0(f) ) {
1483: case L_EQ:
1484: fnodetotex_tb((FNODE)FA1(f),tb);
1485: write_tb(" = ",tb);
1486: fnodetotex_tb((FNODE)FA2(f),tb);
1487: break;
1488: case L_NE:
1489: fnodetotex_tb((FNODE)FA1(f),tb);
1490: write_tb(" \\neq ",tb);
1491: fnodetotex_tb((FNODE)FA2(f),tb);
1492: break;
1493: case L_GT:
1494: fnodetotex_tb((FNODE)FA1(f),tb);
1.45 noro 1495: write_tb(" > ",tb);
1.23 noro 1496: fnodetotex_tb((FNODE)FA2(f),tb);
1497: break;
1498: case L_LT:
1499: fnodetotex_tb((FNODE)FA1(f),tb);
1.45 noro 1500: write_tb(" < ",tb);
1.23 noro 1501: fnodetotex_tb((FNODE)FA2(f),tb);
1502: break;
1503: case L_GE:
1504: fnodetotex_tb((FNODE)FA1(f),tb);
1505: write_tb(" \\geq ",tb);
1506: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1507: break;
1.23 noro 1508: case L_LE:
1509: fnodetotex_tb((FNODE)FA1(f),tb);
1510: write_tb(" \\leq ",tb);
1511: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1512: break;
1.23 noro 1513: case L_AND:
1514: fnodetotex_tb((FNODE)FA1(f),tb);
1.14 noro 1515: write_tb(" {\\rm \\ and\\ } ",tb);
1.23 noro 1516: fnodetotex_tb((FNODE)FA2(f),tb);
1517: break;
1518: case L_OR:
1.14 noro 1519: fnodetotex_tb((FNODE)FA1(f),tb);
1.23 noro 1520: write_tb(" {\\rm \\ or\\ } ",tb);
1521: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1522: break;
1.23 noro 1523: case L_NOT:
1524: /* XXX : L_NOT is a unary operator */
1525: write_tb("\\neg (",tb);
1.14 noro 1526: fnodetotex_tb((FNODE)FA1(f),tb);
1.23 noro 1527: write_tb(")",tb);
1528: return;
1.14 noro 1529: }
1530: break;
1531:
1.23 noro 1532: case I_AND:
1533: fnodetotex_tb((FNODE)FA0(f),tb);
1534: write_tb(" {\\rm \\ and\\ } ",tb);
1535: fnodetotex_tb((FNODE)FA1(f),tb);
1536: break;
1537:
1538: case I_OR:
1539: fnodetotex_tb((FNODE)FA0(f),tb);
1540: write_tb(" {\\rm \\ or\\ } ",tb);
1541: fnodetotex_tb((FNODE)FA1(f),tb);
1542: break;
1543:
1.14 noro 1544: /* ternary operators */
1545: case I_CE:
1546: error("fnodetotex_tb : not implemented yet");
1547: break;
1548:
1549: /* lists */
1550: case I_LIST:
1551: write_tb(" [ ",tb);
1552: n = (NODE)FA0(f);
1553: fnodenodetotex_tb(n,tb);
1554: write_tb("]",tb);
1555: break;
1556:
1557: /* function */
1.23 noro 1558: case I_FUNC:
1.40 noro 1559: if ( !strcmp(((FUNC)FA0(f))->name,"@pi") )
1560: write_tb("\\pi",tb);
1561: else if ( !strcmp(((FUNC)FA0(f))->name,"@e") )
1562: write_tb("e",tb);
1563: else {
1564: opname = conv_rule(((FUNC)FA0(f))->name);
1565: write_tb(opname,tb);
1566: write_tb("(",tb);
1567: fargstotex_tb(opname,FA1(f),tb);
1568: write_tb(")",tb);
1569: }
1.23 noro 1570: break;
1571:
1572: /* XXX */
1573: case I_CAR:
1.28 noro 1574: opname = conv_rule("car");
1.23 noro 1575: write_tb(opname,tb);
1576: write_tb("(",tb);
1577: fargstotex_tb(opname,FA0(f),tb);
1578: write_tb(")",tb);
1579: break;
1580:
1581: case I_CDR:
1.28 noro 1582: opname = conv_rule("cdr");
1.23 noro 1583: write_tb(opname,tb);
1584: write_tb("(",tb);
1585: fargstotex_tb(opname,FA0(f),tb);
1586: write_tb(")",tb);
1587: break;
1588:
1589: /* exponent vector */
1590: case I_EV:
1591: n = (NODE)FA0(f);
1.31 noro 1592: if ( dp_vars_hweyl ) {
1593: elen = length(n);
1594: elen2 = elen>>1;
1595: elen = elen2<<1;
1596: }
1.23 noro 1597: allzero = 1;
1.27 noro 1598: if ( show_lt && is_lt )
1599: write_tb("\\underline{",tb);
1.23 noro 1600: for ( t0 = 0, i = 0; n; n = NEXT(n), i++ ) {
1601: fi = (FNODE)BDY(n);
1602: if ( fi->id == I_FORMULA && !FA0(fi) ) continue;
1603: allzero = 0;
1.38 noro 1604: if ( dp_vars && i < dp_vars_len ) {
1605: strcpy(vname,dp_vars[i]);
1606: vname_conv = conv_rule(vname);
1607: } else {
1608: if ( dp_vars_hweyl ) {
1.44 noro 1609: if ( i < elen2 ) {
1.38 noro 1610: strcpy(prefix,dp_vars_prefix?dp_vars_prefix:"x");
1.44 noro 1611: prefix_conv = conv_rule(prefix);
1612: vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46 noro 1613: si = i+dp_vars_origin;
1614: sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
1615: prefix_conv,si);
1.44 noro 1616: } else if ( i < elen ) {
1.46 noro 1617: strcpy(prefix,
1618: dp_dvars_prefix?dp_dvars_prefix:"\\partial");
1.44 noro 1619: prefix_conv = conv_rule(prefix);
1620: vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46 noro 1621: si = i+dp_dvars_origin-elen2;
1622: sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
1623: prefix_conv,si);
1.44 noro 1624: } else {
1.38 noro 1625: strcpy(prefix,"h");
1.44 noro 1626: vname_conv = conv_rule(prefix);
1627: }
1628: } else {
1.38 noro 1629: strcpy(prefix,dp_vars_prefix?dp_vars_prefix:"x");
1.44 noro 1630: prefix_conv = conv_rule(prefix);
1631: vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46 noro 1632: si = i+dp_vars_origin;
1633: sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
1634: prefix_conv,si);
1.44 noro 1635: }
1.38 noro 1636: }
1.23 noro 1637: if ( fi->id == I_FORMULA && UNIQ(FA0(fi)) ) {
1638: len = strlen(vname_conv);
1639: opname = MALLOC_ATOMIC(len+2);
1640: sprintf(opname,"%s ",vname_conv);
1.14 noro 1641: write_tb(opname,tb);
1.23 noro 1642: } else {
1643: len = strlen(vname_conv);
1644: /* 2: ^{ */
1645: opname = MALLOC_ATOMIC(len+1+2);
1646: sprintf(opname,"%s^{",vname_conv);
1.14 noro 1647: write_tb(opname,tb);
1.23 noro 1648: fnodetotex_tb((FNODE)BDY(n),tb);
1649: write_tb("} ",tb);
1650: }
1.14 noro 1651: }
1.23 noro 1652: /* XXX */
1653: if ( allzero )
1654: write_tb(" 1 ",tb);
1.27 noro 1655: if ( show_lt && is_lt ) {
1656: write_tb("}",tb);
1657: is_lt = 0;
1658: }
1.14 noro 1659: break;
1660:
1.23 noro 1661: /* string */
1.14 noro 1662: case I_STR:
1663: write_tb((char *)FA0(f),tb);
1664: break;
1665:
1.23 noro 1666: /* internal object */
1.14 noro 1667: case I_FORMULA:
1668: obj = (Obj)FA0(f);
1.40 noro 1669: if ( !obj )
1.42 noro 1670: write_tb("0",tb);
1.40 noro 1671: else if ( OID(obj) == O_N && NID(obj) == N_C ) {
1672: cplx = (C)obj;
1673: write_tb("(",tb);
1674: if ( cplx->r ) {
1675: r = objtostr((Obj)cplx->r); write_tb(r,tb);
1676: }
1677: if ( cplx->i ) {
1678: if ( cplx->r && compnum(0,cplx->i,0) > 0 ) {
1679: write_tb("+",tb);
1680: if ( !UNIQ(cplx->i) ) {
1681: r = objtostr((Obj)cplx->i); write_tb(r,tb);
1682: }
1683: } else if ( MUNIQ(cplx->i) )
1684: write_tb("-",tb);
1685: else if ( !UNIQ(cplx->i) ) {
1686: r = objtostr((Obj)cplx->i); write_tb(r,tb);
1687: }
1688: write_tb("\\sqrt{-1}",tb);
1689: }
1690: write_tb(")",tb);
1691: } else if ( OID(obj) == O_P )
1692: write_tb(conv_rule(VR((P)obj)->name),tb);
1693: else
1694: write_tb(objtostr(obj),tb);
1.14 noro 1695: break;
1696:
1.23 noro 1697: /* program variable */
1.14 noro 1698: case I_PVAR:
1699: if ( FA1(f) )
1700: error("fnodetotex_tb : not implemented yet");
1701: GETPVNAME(FA0(f),opname);
1702: write_tb(opname,tb);
1703: break;
1704:
1705: default:
1706: error("fnodetotex_tb : not implemented yet");
1707: }
1.40 noro 1708: }
1709:
1710: char *objtostr(Obj obj)
1711: {
1712: int len;
1713: char *r;
1714:
1715: len = estimate_length(CO,obj);
1716: r = (char *)MALLOC_ATOMIC(len+1);
1717: soutput_init(r);
1718: sprintexpr(CO,obj);
1719: return r;
1.50 ohara 1720: }
1721:
1722: void Psprintf(NODE arg,STRING *rp)
1723: {
1724: STRING string;
1725: char *s,*t,*r;
1726: int argc,n,len;
1727: NODE node;
1728:
1729: string = (STRING)ARG0(arg);
1730: asir_assert(string,O_STR,"sprintf");
1731: s = BDY(string);
1732: for(n = 0, t = s; *t; t++) {
1733: if (*t=='%' && *(t+1)=='a') {
1734: n++;
1735: }
1736: }
1737: for(node = NEXT(arg), argc = 0, len = strlen(s); node; node = NEXT(node), argc++) {
1738: len += estimate_length(CO,BDY(node));
1739: }
1740: if (argc < n) {
1741: error("sprintf: invalid argument");
1742: }
1743: r = (char *)MALLOC_ATOMIC(len);
1744: for(node = NEXT(arg), t = r; *s; s++) {
1745: if (*s=='%' && *(s+1)=='a') {
1746: strcpy(t,objtostr(BDY(node)));
1747: node = NEXT(node);
1748: t = strchr(t,0);
1749: s++;
1750: }else {
1751: *t++ = *s;
1752: }
1753: }
1754: *t = 0;
1755: MKSTR(*rp,r);
1.14 noro 1756: }
1757:
1758: void fnodenodetotex_tb(NODE n,TB tb)
1759: {
1760: for ( ; n; n = NEXT(n) ) {
1.27 noro 1761: is_lt = 1;
1.14 noro 1762: fnodetotex_tb((FNODE)BDY(n),tb);
1763: if ( NEXT(n) ) write_tb(", ",tb);
1764: }
1765: }
1766:
1767: void fargstotex_tb(char *name,FNODE f,TB tb)
1768: {
1769: NODE n;
1770:
1771: if ( !strcmp(name,"matrix") ) {
1772: error("fargstotex_tb : not implemented yet");
1773: } else if ( !strcmp(name,"vector") ) {
1774: error("fargstotex_tb : not implemented yet");
1775: } else {
1776: if ( f->id == I_LIST ) {
1777: n = (NODE)FA0(f);
1778: fnodenodetotex_tb(n,tb);
1779: } else
1780: fnodetotex_tb(f,tb);
1.35 noro 1781: }
1782: }
1783:
1784: int top_is_minus(FNODE f)
1785: {
1786: char *opname;
1787: int len;
1788: Obj obj;
1789:
1790: if ( !f )
1791: return 0;
1792: switch ( f->id ) {
1793: case I_MINUS:
1794: return 1;
1795: case I_BOP:
1796: opname = ((ARF)FA0(f))->name;
1797: switch ( opname[0] ) {
1798: case '+': case '*': case '/': case '^': case '%':
1799: return top_is_minus((FNODE)FA1(f));
1800: case '-':
1801: if ( FA1(f) )
1802: return top_is_minus((FNODE)FA1(f));
1803: else
1804: return 1;
1805: default:
1806: return 0;
1807: }
1808: break;
1809: case I_COP:
1810: return top_is_minus((FNODE)FA1(f));
1811: case I_LOP:
1812: if ( (lid)FA0(f) == L_NOT ) return 0;
1813: else return top_is_minus((FNODE)FA1(f));
1814: case I_AND: case I_OR:
1815: return top_is_minus((FNODE)FA0(f));
1816: case I_FORMULA:
1817: obj = (Obj)FA0(f);
1.36 noro 1818: if ( !obj )
1819: return 0;
1820: else {
1821: switch ( OID(obj) ) {
1822: case O_N:
1823: return mmono((P)obj);
1824: case O_P:
1825: /* must be a variable */
1826: opname = conv_rule(VR((P)obj)->name);
1827: return opname[0]=='-';
1828: default:
1829: /* ??? */
1830: len = estimate_length(CO,obj);
1831: opname = (char *)MALLOC_ATOMIC(len+1);
1832: soutput_init(opname);
1833: sprintexpr(CO,obj);
1834: return opname[0]=='-';
1835: }
1.35 noro 1836: }
1.91 noro 1837: case I_NARYOP:
1838: return top_is_minus((FNODE)BDY((NODE)FA1(f)));
1839:
1.35 noro 1840: default:
1841: return 0;
1.14 noro 1842: }
1.47 noro 1843: }
1844:
1845: FNODE flatten_fnode(FNODE,char *);
1846:
1.48 noro 1847: void Pflatten_quote(NODE arg,Obj *rp)
1.47 noro 1848: {
1849: FNODE f;
1850: QUOTE q;
1851:
1.48 noro 1852: if ( !ARG0(arg) || OID((Obj)ARG0(arg)) != O_QUOTE )
1853: *rp = (Obj)ARG0(arg);
1.65 noro 1854: else if ( argc(arg) == 1 ) {
1855: f = flatten_fnode(BDY((QUOTE)ARG0(arg)),"+");
1856: f = flatten_fnode(f,"*");
1857: MKQUOTE(q,f);
1858: *rp = (Obj)q;
1859: } else {
1.48 noro 1860: f = flatten_fnode(BDY((QUOTE)ARG0(arg)),BDY((STRING)ARG1(arg)));
1861: MKQUOTE(q,f);
1862: *rp = (Obj)q;
1863: }
1.63 noro 1864: }
1865:
1866: void Pget_quote_id(NODE arg,Q *rp)
1867: {
1868: FNODE f;
1869: QUOTE q;
1870:
1871: q = (QUOTE)ARG0(arg);
1872: if ( !q || OID(q) != O_QUOTE )
1873: error("get_quote_id : invalid argument");
1874: f = BDY(q);
1875: STOQ((int)f->id,*rp);
1.48 noro 1876: }
1877:
1878: void Pquote_to_funargs(NODE arg,LIST *rp)
1879: {
1880: fid_spec_p spec;
1881: QUOTE q;
1882: QUOTEARG qa;
1883: FNODE f;
1884: STRING s;
1885: QUOTE r;
1886: int i;
1887: Q id,a;
1.49 noro 1888: LIST l;
1889: NODE t0,t,w,u,u0;
1.48 noro 1890:
1891: q = (QUOTE)ARG0(arg);
1892: if ( !q || OID(q) != O_QUOTE )
1893: error("quote_to_funargs : invalid argument");
1894: f = BDY(q);
1895: if ( !f ) {
1896: MKLIST(*rp,0);
1897: return;
1898: }
1899: get_fid_spec(f->id,&spec);
1900: if ( !spec )
1901: error("quote_to_funargs : not supported yet");
1902: t0 = 0;
1903: STOQ((int)f->id,id);
1904: NEXTNODE(t0,t);
1905: BDY(t) = (pointer)id;
1906: for ( i = 0; spec->type[i] != A_end; i++ ) {
1907: NEXTNODE(t0,t);
1908: switch ( spec->type[i] ) {
1909: case A_fnode:
1910: MKQUOTE(r,(FNODE)f->arg[i]);
1911: BDY(t) = (pointer)r;
1912: break;
1913: case A_int:
1914: STOQ((int)f->arg[i],a);
1915: BDY(t) = (pointer)a;
1916: break;
1917: case A_str:
1918: MKSTR(s,(char *)f->arg[i]);
1919: BDY(t) = (pointer)s;
1920: break;
1921: case A_internal:
1922: BDY(t) = (pointer)f->arg[i];
1923: break;
1.49 noro 1924: case A_node:
1925: w = (NODE)f->arg[i];
1926: for ( u0 = 0; w; w = NEXT(w) ){
1927: NEXTNODE(u0,u);
1928: MKQUOTE(r,(FNODE)BDY(w));
1929: BDY(u) = (pointer)r;
1930: }
1931: if ( u0 ) NEXT(u) = 0;
1932: MKLIST(l,u0);
1933: BDY(t) = (pointer)l;
1934: break;
1.48 noro 1935: default:
1936: MKQUOTEARG(qa,spec->type[i],f->arg[i]);
1937: BDY(t) = (pointer)qa;
1938: break;
1939: }
1940: }
1941: if ( t0 ) NEXT(t) = 0;
1942: MKLIST(*rp,t0);
1943: }
1944:
1945: void Pfunargs_to_quote(NODE arg,QUOTE *rp)
1946: {
1947: fid_spec_p spec;
1948: QUOTE q;
1949: QUOTEARG qa;
1950: FNODE f;
1951: STRING s;
1.49 noro 1952: QUOTE r,b;
1.48 noro 1953: int i;
1954: LIST l;
1955: fid id;
1956: Obj a;
1.49 noro 1957: NODE t0,t,u0,u,w;
1.48 noro 1958:
1959: l = (LIST)ARG0(arg);
1960: if ( !l || OID(l) != O_LIST || !(t=BDY(l)) )
1961: error("funargs_to_quote : invalid argument");
1962: t = BDY(l);
1963: id = (fid)QTOS((Q)BDY(t)); t = NEXT(t);
1964: get_fid_spec(id,&spec);
1965: if ( !spec )
1966: error("funargs_to_quote : not supported yet");
1967: for ( i = 0; spec->type[i] != A_end; i++ );
1968: NEWFNODE(f,i);
1969: f->id = id;
1970: for ( i = 0; spec->type[i] != A_end; i++, t = NEXT(t) ) {
1971: if ( !t )
1972: error("funargs_to_quote : argument mismatch");
1973: a = (Obj)BDY(t);
1974: switch ( spec->type[i] ) {
1975: case A_fnode:
1976: if ( !a || OID(a) != O_QUOTE )
1977: error("funargs_to_quote : invalid argument");
1978: f->arg[i] = BDY((QUOTE)a);
1979: break;
1980: case A_int:
1981: if ( !INT(a) )
1982: error("funargs_to_quote : invalid argument");
1983: f->arg[i] = (pointer)QTOS((Q)a);
1984: break;
1985: case A_str:
1986: if ( !a || OID(a) != O_STR )
1987: error("funargs_to_quote : invalid argument");
1988: f->arg[i] = (pointer)BDY((STRING)a);
1989: break;
1990: case A_internal:
1991: f->arg[i] = (pointer)a;
1.49 noro 1992: break;
1993: case A_node:
1994: if ( !a || OID(a) != O_LIST )
1995: error("funargs_to_quote : invalid argument");
1996: u0 = 0;
1997: for ( w = BDY((LIST)a); w; w = NEXT(w) ) {
1998: NEXTNODE(u0,u);
1999: b = (QUOTE)BDY(w);
2000: if ( !b || OID(b) != O_QUOTE )
2001: error("funargs_to_quote : invalid argument");
2002: BDY(u) = BDY(b);
2003: }
2004: if ( u0 ) NEXT(u) = 0;
2005: f->arg[i] = (pointer)u0;
1.48 noro 2006: break;
2007: default:
2008: if ( !a || OID(a) != O_QUOTEARG ||
2009: ((QUOTEARG)a)->type != spec->type[i] )
2010: error("funargs_to_quote : invalid argument");
2011: f->arg[i] = BDY((QUOTEARG)a);
2012: break;
2013: }
2014: }
2015: MKQUOTE(*rp,f);
1.69 noro 2016: }
2017:
1.76 noro 2018: FNODE fnode_apply(FNODE f,FNODE (*func)(),int expand);
2019: FNODE fnode_normalize(FNODE f,int expand);
1.70 noro 2020:
2021: void Pquote_normalize(NODE arg,QUOTE *rp)
2022: {
2023: QUOTE q,r;
2024: FNODE f;
1.76 noro 2025: int expand,ac;
1.70 noro 2026:
1.76 noro 2027: ac = argc(arg);
2028: if ( !ac ) error("quote_normalize : invalid argument");
1.70 noro 2029: q = (QUOTE)ARG0(arg);
1.76 noro 2030: expand = ac==2 && ARG1(arg);
1.70 noro 2031: if ( !q || OID(q) != O_QUOTE ) {
2032: *rp = q;
2033: return;
1.87 noro 2034: } else if ( q->normalized && (q->expanded || !expand) )
2035: *rp = q;
2036: else {
1.76 noro 2037: f = fnode_normalize(BDY(q),expand);
1.70 noro 2038: MKQUOTE(r,f);
1.87 noro 2039: r->normalized = 1;
2040: if ( expand ) r->expanded = 1;
1.70 noro 2041: *rp = r;
2042: }
2043: }
2044:
1.80 noro 2045: void Pquote_normalize_comp(NODE arg,Q *rp)
2046: {
1.87 noro 2047: QUOTE q1,q2;
1.80 noro 2048: FNODE f1,f2;
2049: int r;
2050:
1.87 noro 2051: q1 = (QUOTE)ARG0(arg); f1 = (FNODE)BDY(q1);
2052: q2 = (QUOTE)ARG1(arg); f2 = (FNODE)BDY(q2);
2053: if ( !q1->normalized ) f1 = fnode_normalize(f1,0);
2054: if ( !q2->normalized ) f2 = fnode_normalize(f2,0);
1.80 noro 2055: r = fnode_normalize_comp(f1,f2);
2056: STOQ(r,*rp);
2057: }
2058:
1.89 noro 2059: INLINE int fnode_is_number(FNODE f)
1.69 noro 2060: {
2061: Obj obj;
2062:
2063: switch ( f->id ) {
2064: case I_MINUS: case I_PAREN:
2065: return fnode_is_number(FA0(f));
2066:
2067: case I_FORMULA:
2068: obj = FA0(f);
2069: if ( !obj ) return 1;
2070: else if ( OID(obj) == O_QUOTE )
2071: return fnode_is_number(BDY((QUOTE)obj));
2072: else if ( NUM(obj) ) return 1;
2073: else return 0;
2074:
2075: case I_BOP:
2076: return fnode_is_number(FA1(f)) && fnode_is_number(FA2(f));
2077:
2078: default:
2079: return 0;
2080: }
2081: }
2082:
2083: int fnode_is_rational(FNODE f)
2084: {
2085: Obj obj;
2086:
2087: switch ( f->id ) {
2088: case I_MINUS: case I_PAREN:
2089: return fnode_is_number(FA0(f));
2090:
2091: case I_FORMULA:
2092: obj = FA0(f);
2093: if ( !obj ) return 1;
2094: else if ( OID(obj) == O_QUOTE )
2095: return fnode_is_rational(BDY((QUOTE)obj));
2096: else if ( NUM(obj) && RATN(obj) ) return 1;
2097: else return 0;
2098:
2099: case I_BOP:
2100: if ( !strcmp(((ARF)FA0(f))->name,"^") )
2101: return fnode_is_rational(FA1(f)) && fnode_is_integer(FA2(f));
2102: else
2103: return fnode_is_rational(FA1(f)) && fnode_is_rational(FA2(f));
2104:
2105: default:
2106: return 0;
2107: }
2108: }
2109:
2110: int fnode_is_integer(FNODE f)
2111: {
2112: Obj obj;
2113:
2114: switch ( f->id ) {
2115: case I_MINUS: case I_PAREN:
2116: return fnode_is_integer(FA0(f));
2117:
2118: case I_FORMULA:
2119: obj = FA0(f);
2120: if ( !obj ) return 1;
2121: else if ( OID(obj) == O_QUOTE )
2122: return fnode_is_integer(BDY((QUOTE)obj));
2123: else if ( INT(obj)) return 1;
2124: else return 0;
2125:
2126: case I_BOP:
1.70 noro 2127: switch ( ((ARF)FA0(f))->name[0] ) {
2128: case '^':
2129: return fnode_is_integer(FA1(f))
2130: && fnode_is_nonnegative_integer(FA2(f));
2131: case '/':
2132: return fnode_is_integer(FA1(f)) &&
2133: ( fnode_is_one(FA2(f)) || fnode_is_minusone(FA2(f)) );
2134: default:
2135: return fnode_is_integer(FA1(f)) && fnode_is_integer(FA2(f));
2136: }
2137: break;
2138:
1.69 noro 2139: default:
2140: return 0;
2141: }
2142: }
2143:
2144: int fnode_is_nonnegative_integer(FNODE f)
2145: {
2146: Q n;
2147:
2148: n = eval(f);
2149: if ( !n || (INT(n) && SGN(n) > 0) ) return 1;
2150: else return 0;
2151: }
2152:
2153: int fnode_is_one(FNODE f)
2154: {
2155: Q n;
2156:
2157: n = eval(f);
2158: if ( UNIQ(n) ) return 1;
2159: else return 0;
2160: }
2161:
2162: int fnode_is_minusone(FNODE f)
2163: {
2164: Q n;
2165:
2166: n = eval(f);
2167: if ( MUNIQ(n) ) return 1;
2168: else return 0;
2169: }
2170:
2171: int fnode_is_dependent(FNODE f,V v)
2172: {
2173: Obj obj;
2174: FNODE arg;
2175: NODE t;
2176:
2177: switch ( f->id ) {
2178: case I_MINUS: case I_PAREN:
2179: return fnode_is_dependent(FA0(f),v);
2180:
2181: case I_FORMULA:
2182: obj = FA0(f);
2183: if ( !obj ) return 0;
2184: else if ( OID(obj) == O_QUOTE )
2185: return fnode_is_dependent(BDY((QUOTE)obj),v);
2186: else if ( obj_is_dependent(obj,v) ) return 1;
2187: else return 0;
2188:
2189: case I_BOP:
2190: return fnode_is_dependent(FA1(f),v) || fnode_is_dependent(FA2(f),v);
2191:
2192: case I_FUNC:
2193: arg = (FNODE)FA1(f);
2194: for ( t = FA0(arg); t; t = NEXT(t) )
2195: if ( fnode_is_dependent(BDY(t),v) ) return 1;
2196: return 0;
2197:
2198: default:
2199: return 0;
2200: }
1.1 noro 2201: }
1.70 noro 2202:
1.76 noro 2203: FNODE fnode_normalize_add(FNODE a1,FNODE a2,int expand);
2204: FNODE fnode_normalize_mul(FNODE a1,FNODE a2,int expand);
2205: FNODE fnode_normalize_pwr(FNODE a1,FNODE a2,int expand);
2206: FNODE fnode_normalize_mul_coef(Num c,FNODE f,int expand);
2207: FNODE fnode_expand_pwr(FNODE f,int n);
1.72 noro 2208: FNODE to_narymul(FNODE f);
2209: FNODE to_naryadd(FNODE f);
1.75 noro 2210: FNODE fnode_node_to_naryadd(NODE n);
2211: FNODE fnode_node_to_narymul(NODE n);
1.72 noro 2212: void fnode_base_exp(FNODE f,FNODE *bp,FNODE *ep);
2213: void fnode_coef_body(FNODE f,Num *cp,FNODE *bp);
2214:
2215:
1.76 noro 2216: FNODE fnode_normalize(FNODE f,int expand)
1.70 noro 2217: {
1.73 noro 2218: FNODE a1,a2,mone,r,b2;
1.72 noro 2219: NODE n;
1.70 noro 2220: Q q;
2221:
1.89 noro 2222: if ( f->normalized && (f->expanded || !expand) ) return f;
1.72 noro 2223: STOQ(-1,q);
2224: mone = mkfnode(1,I_FORMULA,q);
1.70 noro 2225: switch ( f->id ) {
2226: case I_PAREN:
1.89 noro 2227: r = fnode_normalize(FA0(f),expand);
2228: break;
1.71 noro 2229:
2230: case I_MINUS:
1.89 noro 2231: r = fnode_normalize_mul_coef((Num)q,
1.76 noro 2232: fnode_normalize(FA0(f),expand),expand);
1.89 noro 2233: break;
1.71 noro 2234:
1.70 noro 2235: case I_BOP:
2236: /* arf fnode fnode */
1.76 noro 2237: a1 = fnode_normalize(FA1(f),expand);
2238: a2 = fnode_normalize(FA2(f),expand);
1.72 noro 2239: switch ( OPNAME(f) ) {
2240: case '+':
1.89 noro 2241: r = fnode_normalize_add(a1,a2,expand);
2242: break;
1.70 noro 2243: case '-':
1.76 noro 2244: a2 = fnode_normalize_mul_coef((Num)q,a2,expand);
1.89 noro 2245: r = fnode_normalize_add(a1,a2,expand);
2246: break;
1.72 noro 2247: case '*':
1.89 noro 2248: r = fnode_normalize_mul(a1,a2,expand);
2249: break;
1.70 noro 2250: case '/':
1.76 noro 2251: a2 = fnode_normalize_pwr(a2,mone,expand);
1.89 noro 2252: r = fnode_normalize_mul(a1,a2,expand);
2253: break;
1.73 noro 2254: case '^':
1.89 noro 2255: r = fnode_normalize_pwr(a1,a2,expand);
2256: break;
1.70 noro 2257: default:
1.89 noro 2258: r = mkfnode(3,I_BOP,FA0(f),a1,a2);
2259: break;
1.70 noro 2260: }
2261: break;
1.71 noro 2262:
1.70 noro 2263: case I_NARYOP:
1.72 noro 2264: switch ( OPNAME(f) ) {
1.71 noro 2265: case '+':
1.73 noro 2266: n = (NODE)FA1(f);
1.76 noro 2267: r = fnode_normalize(BDY(n),expand); n = NEXT(n);
1.72 noro 2268: for ( ; n; n = NEXT(n) ) {
1.76 noro 2269: a1 = fnode_normalize(BDY(n),expand);
2270: r = fnode_normalize_add(r,a1,expand);
1.72 noro 2271: }
1.89 noro 2272: break;
1.70 noro 2273: case '*':
1.73 noro 2274: n = (NODE)FA1(f);
1.76 noro 2275: r = fnode_normalize(BDY(n),expand); n = NEXT(n);
1.72 noro 2276: for ( ; n; n = NEXT(n) ) {
1.76 noro 2277: a1 = fnode_normalize(BDY(n),expand);
2278: r = fnode_normalize_mul(r,a1,expand);
1.72 noro 2279: }
1.89 noro 2280: break;
1.70 noro 2281: default:
1.72 noro 2282: error("fnode_normallize : cannot happen");
1.70 noro 2283: }
1.89 noro 2284: break;
1.72 noro 2285:
1.70 noro 2286: default:
1.76 noro 2287: return fnode_apply(f,fnode_normalize,expand);
1.70 noro 2288: }
1.89 noro 2289: r->normalized = 1;
2290: r->expanded = expand;
2291: return r;
1.70 noro 2292: }
2293:
1.76 noro 2294: FNODE fnode_apply(FNODE f,FNODE (*func)(),int expand)
1.70 noro 2295: {
2296: fid_spec_p spec;
2297: FNODE r;
2298: int i,n;
2299: NODE t,t0,s;
2300:
2301: get_fid_spec(f->id,&spec);
2302: for ( n = 0; spec->type[n] != A_end; n++ );
2303: NEWFNODE(r,n); r->id = f->id;
2304: for ( i = 0; i < n; i++ ) {
2305: switch ( spec->type[i] ) {
2306: case A_fnode:
1.78 noro 2307: r->arg[i] = func(f->arg[i],expand);
1.70 noro 2308: break;
2309: case A_node:
2310: s = (NODE)f->arg[i];
2311: for ( t0 = 0; s; s = NEXT(s) ) {
2312: NEXTNODE(t0,t);
1.76 noro 2313: BDY(t) = (pointer)func((FNODE)BDY(s),expand);
1.70 noro 2314: }
2315: if ( t0 ) NEXT(t) = 0;
2316: r->arg[i] = t0;
2317: break;
2318: default:
2319: r->arg[i] = f->arg[i];
2320: break;
2321: }
2322: }
2323: return r;
2324: }
2325:
1.76 noro 2326: FNODE fnode_normalize_add(FNODE f1,FNODE f2,int expand)
1.71 noro 2327: {
1.72 noro 2328: NODE n1,n2,r0,r;
2329: FNODE b1,b2;
2330: int s;
2331: Num c1,c2,c;
2332:
1.77 noro 2333: if ( IS_ZERO(f1) ) return f2;
2334: else if ( IS_ZERO(f2) ) return f1;
1.75 noro 2335: f1 = to_naryadd(f1); f2 = to_naryadd(f2);
2336: n1 = (NODE)FA1(f1); n2 = (NODE)FA1(f2);
1.72 noro 2337: r0 = 0;
2338: while ( n1 && n2 ) {
1.75 noro 2339: fnode_coef_body(BDY(n1),&c1,&b1); fnode_coef_body(BDY(n2),&c2,&b2);
1.80 noro 2340: if ( (s = fnode_normalize_comp(b1,b2)) > 0 ) {
1.73 noro 2341: NEXTNODE(r0,r); BDY(r) = BDY(n1); n1 = NEXT(n1);
1.72 noro 2342: } else if ( s < 0 ) {
1.73 noro 2343: NEXTNODE(r0,r); BDY(r) = BDY(n2); n2 = NEXT(n2);
1.72 noro 2344: } else {
2345: addnum(0,c1,c2,&c);
2346: if ( c ) {
1.76 noro 2347: NEXTNODE(r0,r); BDY(r) = fnode_normalize_mul_coef(c,b1,expand);
1.71 noro 2348: }
1.72 noro 2349: n1 = NEXT(n1); n2 = NEXT(n2);
1.71 noro 2350: }
2351: }
1.72 noro 2352: if ( n1 )
2353: if ( r0 ) NEXT(r) = n1;
2354: else r0 = n1;
2355: else if ( n2 )
2356: if ( r0 ) NEXT(r) = n2;
2357: else r0 = n2;
2358: else if ( r0 )
2359: NEXT(r) = 0;
2360:
1.75 noro 2361: return fnode_node_to_naryadd(r0);
2362: }
2363:
2364: FNODE fnode_node_to_naryadd(NODE n)
2365: {
2366: if ( !n ) return mkfnode(1,I_FORMULA,0);
2367: else if ( !NEXT(n) ) return BDY(n);
2368: else return mkfnode(2,I_NARYOP,addfs,n);
2369: }
2370:
2371: FNODE fnode_node_to_narymul(NODE n)
2372: {
2373: if ( !n ) return mkfnode(1,I_FORMULA,ONE);
2374: else if ( !NEXT(n) ) return BDY(n);
2375: else return mkfnode(2,I_NARYOP,mulfs,n);
1.71 noro 2376: }
2377:
1.76 noro 2378: FNODE fnode_normalize_mul(FNODE f1,FNODE f2,int expand)
1.71 noro 2379: {
1.72 noro 2380: NODE n1,n2,r0,r,r1;
1.76 noro 2381: FNODE b1,b2,e1,e2,cc,t,t1;
1.72 noro 2382: FNODE *m;
2383: int s;
2384: Num c1,c2,c,e;
1.75 noro 2385: int l1,l,i,j;
1.72 noro 2386:
1.77 noro 2387: if ( IS_ZERO(f1) || IS_ZERO(f2) ) return mkfnode(1,I_FORMULA,0);
1.75 noro 2388: else if ( fnode_is_number(f1) )
1.76 noro 2389: return fnode_normalize_mul_coef((Num)eval(f1),f2,expand);
1.75 noro 2390: else if ( fnode_is_number(f2) )
1.76 noro 2391: return fnode_normalize_mul_coef((Num)eval(f2),f1,expand);
2392:
2393: if ( expand && IS_NARYADD(f1) ) {
2394: t = mkfnode(1,I_FORMULA,0);
2395: for ( n1 = (NODE)FA1(f1); n1; n1 = NEXT(n1) ) {
2396: t1 = fnode_normalize_mul(BDY(n1),f2,expand);
2397: t = fnode_normalize_add(t,t1,expand);
2398: }
2399: return t;
2400: }
2401: if ( expand && IS_NARYADD(f2) ) {
2402: t = mkfnode(1,I_FORMULA,0);
2403: for ( n2 = (NODE)FA1(f2); n2; n2 = NEXT(n2) ) {
2404: t1 = fnode_normalize_mul(f1,BDY(n2),expand);
2405: t = fnode_normalize_add(t,t1,expand);
2406: }
2407: return t;
2408: }
1.72 noro 2409:
1.75 noro 2410: fnode_coef_body(f1,&c1,&b1); fnode_coef_body(f2,&c2,&b2);
2411: mulnum(0,c1,c2,&c);
1.72 noro 2412: if ( !c ) return mkfnode(1,I_FORMULA,0);
1.71 noro 2413:
1.76 noro 2414:
1.75 noro 2415: n1 = (NODE)FA1(to_narymul(b1)); n2 = (NODE)FA1(to_narymul(b2));
2416: l1 = length(n1); l = l1+length(n2);
1.72 noro 2417: m = (FNODE *)ALLOCA(l*sizeof(FNODE));
2418: for ( r = n1, i = 0; i < l1; r = NEXT(r), i++ ) m[i] = BDY(r);
2419: for ( r = n2; r; r = NEXT(r) ) {
2420: if ( i == 0 )
2421: m[i++] = BDY(r);
2422: else {
1.75 noro 2423: fnode_base_exp(m[i-1],&b1,&e1); fnode_base_exp(BDY(r),&b2,&e2);
2424: if ( compfnode(b1,b2) ) break;
2425: addnum(0,eval(e1),eval(e2),&e);
2426: if ( !e ) i--;
2427: else if ( UNIQ(e) )
2428: m[i-1] = b1;
2429: else
2430: m[i-1] = mkfnode(3,I_BOP,pwrfs,b1,mkfnode(1,I_FORMULA,e));
1.71 noro 2431: }
2432: }
1.75 noro 2433: for ( j = i-1; j >= 0; j-- ) {
2434: MKNODE(r1,m[j],r); r = r1;
2435: }
2436: if ( !UNIQ(c) ) {
2437: cc = mkfnode(1,I_FORMULA,c); MKNODE(r1,cc,r); r = r1;
1.72 noro 2438: }
1.75 noro 2439: return fnode_node_to_narymul(r);
1.73 noro 2440: }
2441:
1.76 noro 2442: FNODE fnode_normalize_pwr(FNODE f1,FNODE f2,int expand)
1.73 noro 2443: {
1.89 noro 2444: FNODE b,b1,e1,e,cc,r,mf2,mone,inv;
2445: Num c,c1,nf2;
2446: int ee;
2447: NODE arg,n,t0,t1;
1.76 noro 2448: Q q;
1.73 noro 2449:
1.77 noro 2450: if ( IS_ZERO(f2) ) return mkfnode(1,I_FORMULA,ONE);
2451: else if ( IS_ZERO(f1) ) return mkfnode(1,I_FORMULA,0);
1.92 ! noro 2452: else if ( fnode_is_number(f1) ) {
1.73 noro 2453: if ( fnode_is_integer(f2) ) {
1.92 ! noro 2454: if ( fnode_is_one(f2) ) return f1;
! 2455: else {
! 2456: pwrnum(0,(Num)eval(f1),(Num)eval(f2),&c);
! 2457: return mkfnode(1,I_FORMULA,c);
! 2458: }
1.73 noro 2459: } else
2460: return mkfnode(3,I_BOP,pwrfs,f1,f2);
1.92 ! noro 2461: } else if ( IS_BINARYPWR(f1) ) {
1.73 noro 2462: b1 = FA1(f1); e1 = FA2(f1);
1.76 noro 2463: e = fnode_normalize_mul(e1,f2,expand);
1.73 noro 2464: if ( fnode_is_one(e) )
2465: return b1;
2466: else
2467: return mkfnode(3,I_BOP,FA0(f1),b1,e);
1.92 ! noro 2468: } else if ( expand && IS_NARYMUL(f1) && fnode_is_number(f2)
! 2469: && fnode_is_integer(f2) ) {
1.73 noro 2470: fnode_coef_body(f1,&c1,&b1);
1.89 noro 2471: nf2 = (Num)eval(f2);
2472: pwrnum(0,(Num)c1,nf2,&c);
2473: ee = QTOS((Q)nf2);
1.75 noro 2474: cc = mkfnode(1,I_FORMULA,c);
1.89 noro 2475: if ( fnode_is_nonnegative_integer(f2) )
2476: b = fnode_expand_pwr(b1,ee);
2477: else {
2478: STOQ(-1,q);
2479: mone = mkfnode(1,I_FORMULA,q);
1.92 ! noro 2480: b1 = to_narymul(b1);
1.89 noro 2481: for ( t0 = 0, n = (NODE)FA1(b1); n; n = NEXT(n) ) {
2482: inv = mkfnode(3,I_BOP,pwrfs,BDY(n),mone);
2483: MKNODE(t1,inv,t0); t0 = t1;
2484: }
1.92 ! noro 2485: b1 = fnode_node_to_narymul(t0);
1.89 noro 2486: b = fnode_expand_pwr(b1,-ee);
2487: }
1.75 noro 2488: if ( fnode_is_one(cc) )
2489: return b;
2490: else
2491: return fnode_node_to_narymul(mknode(2,cc,b));
1.82 noro 2492: } else if ( expand && fnode_is_integer(f2)
2493: && fnode_is_nonnegative_integer(f2) ) {
1.76 noro 2494: q = (Q)eval(f2);
2495: if ( PL(NM(q)) > 1 ) error("fnode_normalize_pwr : exponent too large");
2496: return fnode_expand_pwr(f1,QTOS(q));
1.73 noro 2497: } else
2498: return mkfnode(3,I_BOP,pwrfs,f1,f2);
1.72 noro 2499: }
2500:
1.76 noro 2501: FNODE fnode_expand_pwr(FNODE f,int n)
2502: {
2503: int n1;
2504: FNODE f1,f2;
2505:
2506: if ( !n ) return mkfnode(1,I_FORMULA,ONE);
1.77 noro 2507: else if ( IS_ZERO(f) ) return mkfnode(1,I_FORMULA,0);
1.76 noro 2508: else if ( n == 1 ) return f;
2509: else {
2510: n1 = n/2;
2511: f1 = fnode_expand_pwr(f,n1);
2512: f2 = fnode_normalize_mul(f1,f1,1);
2513: if ( n%2 ) f2 = fnode_normalize_mul(f2,f,1);
2514: return f2;
2515: }
2516: }
2517:
1.72 noro 2518: /* f = b^e */
2519: void fnode_base_exp(FNODE f,FNODE *bp,FNODE *ep)
2520: {
1.75 noro 2521: if ( IS_BINARYPWR(f) ) {
1.72 noro 2522: *bp = FA1(f); *ep = FA2(f);
2523: } else {
2524: *bp = f; *ep = mkfnode(1,I_FORMULA,ONE);
2525: }
2526: }
2527:
2528: FNODE to_naryadd(FNODE f)
2529: {
2530: FNODE r;
2531: NODE n;
2532:
1.75 noro 2533: if ( IS_NARYADD(f) ) return f;
2534:
2535: NEWFNODE(r,2); r->id = I_NARYOP;
2536: FA0(r) = addfs; MKNODE(n,f,0); FA1(r) = n;
1.72 noro 2537: return r;
2538: }
2539:
2540: FNODE to_narymul(FNODE f)
2541: {
2542: FNODE r;
2543: NODE n;
2544:
1.75 noro 2545: if ( IS_NARYMUL(f) ) return f;
2546:
2547: NEWFNODE(r,2); r->id = I_NARYOP;
2548: FA0(r) = mulfs; MKNODE(n,f,0); FA1(r) = n;
1.72 noro 2549: return r;
2550: }
2551:
1.76 noro 2552: FNODE fnode_normalize_mul_coef(Num c,FNODE f,int expand)
1.72 noro 2553: {
1.76 noro 2554: FNODE b1,cc;
1.72 noro 2555: Num c1,c2;
1.76 noro 2556: NODE n,r,r0;
1.72 noro 2557:
2558: if ( !c )
2559: return mkfnode(I_FORMULA,0);
1.75 noro 2560: else {
2561: fnode_coef_body(f,&c1,&b1);
2562: mulnum(0,c,c1,&c2);
2563: if ( UNIQ(c2) ) return b1;
2564: else {
2565: cc = mkfnode(1,I_FORMULA,c2);
2566: if ( fnode_is_number(b1) ) {
2567: if ( !fnode_is_one(b1) )
2568: error("fnode_normalize_mul_coef : cannot happen");
2569: else
2570: return cc;
1.76 noro 2571: } else if ( IS_NARYMUL(b1) ) {
1.75 noro 2572: MKNODE(n,cc,FA1(b1));
1.76 noro 2573: return fnode_node_to_narymul(n);
2574: } else if ( expand && IS_NARYADD(b1) ) {
2575: for ( r0 = 0, n = (NODE)FA1(b1); n; n = NEXT(n) ) {
2576: NEXTNODE(r0,r);
2577: BDY(r) = fnode_normalize_mul_coef(c2,BDY(n),expand);
2578: }
2579: if ( r0 ) NEXT(r) = 0;
2580: return fnode_node_to_naryadd(r0);
2581: } else
2582: return fnode_node_to_narymul(mknode(2,cc,b1));
1.72 noro 2583: }
1.71 noro 2584: }
2585: }
2586:
1.72 noro 2587: void fnode_coef_body(FNODE f,Num *cp,FNODE *bp)
1.70 noro 2588: {
1.72 noro 2589: FNODE c;
1.70 noro 2590:
1.72 noro 2591: if ( fnode_is_number(f) ) {
2592: *cp = eval(f); *bp = mkfnode(1,I_FORMULA,ONE);
1.75 noro 2593: } else if ( IS_NARYMUL(f) ) {
2594: c=(FNODE)BDY((NODE)FA1(f));
1.72 noro 2595: if ( fnode_is_number(c) ) {
2596: *cp = eval(c);
1.75 noro 2597: *bp = fnode_node_to_narymul(NEXT((NODE)FA1(f)));
1.70 noro 2598: } else {
1.72 noro 2599: *cp = (Num)ONE; *bp = f;
1.70 noro 2600: }
2601: } else {
1.72 noro 2602: *cp = (Num)ONE; *bp = f;
1.70 noro 2603: }
1.80 noro 2604: }
2605:
2606: int fnode_normalize_comp_pwr(FNODE f1,FNODE f2);
2607:
2608: int fnode_normalize_comp(FNODE f1,FNODE f2)
2609: {
2610: NODE n1,n2;
2611: int r,i1,i2;
1.82 noro 2612: char *nm1,*nm2;
1.80 noro 2613: FNODE b1,b2,e1,e2,g;
1.83 noro 2614: Num ee,ee1,c1,c2;
1.80 noro 2615:
2616: if ( IS_NARYADD(f1) || IS_NARYADD(f2) ) {
2617: f1 = to_naryadd(f1); f2 = to_naryadd(f2);
2618: n1 = (NODE)FA1(f1); n2 = (NODE)FA1(f2);
2619: while ( n1 && n2 )
2620: if ( r = fnode_normalize_comp(BDY(n1),BDY(n2)) ) return r;
2621: else {
2622: n1 = NEXT(n1); n2 = NEXT(n2);
2623: }
1.85 noro 2624: return n1?1:(n2?-1:0);
1.80 noro 2625: }
2626: if ( IS_NARYMUL(f1) || IS_NARYMUL(f2) ) {
1.83 noro 2627: fnode_coef_body(f1,&c1,&b1);
2628: fnode_coef_body(f2,&c2,&b2);
2629: if ( !compfnode(b1,b2) ) return compnum(0,c1,c2);
2630: b1 = to_narymul(b1); b2 = to_narymul(b2);
2631: n1 = (NODE)FA1(b1); n2 = (NODE)FA1(b2);
1.80 noro 2632: while ( 1 ) {
2633: while ( n1 && n2 && !compfnode(BDY(n1),BDY(n2)) ) {
2634: n1 = NEXT(n1); n2 = NEXT(n2);
2635: }
2636: if ( !n1 || !n2 ) {
1.85 noro 2637: return n1?1:(n2?-1:0);
1.80 noro 2638: }
2639: fnode_base_exp(BDY(n1),&b1,&e1);
2640: fnode_base_exp(BDY(n2),&b2,&e2);
2641:
1.83 noro 2642: if ( r = fnode_normalize_comp(b1,b2) ) {
2643: if ( r > 0 )
2644: return fnode_normalize_comp(e1,mkfnode(1,I_FORMULA,0));
2645: else if ( r < 0 )
2646: return fnode_normalize_comp(mkfnode(1,I_FORMULA,0),e2);
2647: } else {
2648: n1 = NEXT(n1); n2 = NEXT(n2);
2649: if ( fnode_is_number(e1) && fnode_is_number(e2) ) {
2650: /* f1 = t b^e1 ... , f2 = t b^e2 ... */
2651: subnum(0,eval(e1),eval(e2),&ee);
1.86 noro 2652: r = compnum(0,ee,0);
2653: if ( r > 0 ) {
1.83 noro 2654: g = mkfnode(3,I_BOP,pwrfs,b1,mkfnode(1,I_FORMULA,ee));
2655: MKNODE(n1,g,n1);
1.86 noro 2656: } else if ( r < 0 ) {
2657: chsgnnum(ee,&ee1);
2658: g = mkfnode(3,I_BOP,pwrfs,b1,mkfnode(1,I_FORMULA,ee1));
2659: MKNODE(n2,g,n2);
1.83 noro 2660: }
2661: } else {
2662: r = fnode_normalize_comp(e1,e2);
2663: if ( r > 0 ) return 1;
2664: else if ( r < 0 ) return -1;
1.80 noro 2665: }
2666: }
2667: }
2668: }
2669: if ( IS_BINARYPWR(f1) || IS_BINARYPWR(f2) )
2670: return fnode_normalize_comp_pwr(f1,f2);
2671:
2672: /* now, IDs of f1 and f2 must be I_FORMULA, I_FUNC, or I_PVAR */
2673: switch ( f1->id ) {
2674: case I_FORMULA:
2675: switch ( f2->id ) {
2676: case I_FORMULA:
2677: return arf_comp(CO,FA0(f1),FA0(f2));
2678: case I_FUNC: case I_PVAR:
2679: return -1;
2680: default:
2681: error("fnode_normalize_comp : undefined");
2682: }
2683: break;
2684: case I_FUNC:
2685: switch ( f2->id ) {
2686: case I_FORMULA:
2687: return 1;
2688: case I_FUNC:
1.82 noro 2689: nm1 = ((FUNC)FA0(f1))->name; nm2 = ((FUNC)FA0(f2))->name;
2690: r = strcmp(nm1,nm2);
2691: if ( r > 0 ) return 1;
2692: else if ( r < 0 ) return -1;
1.80 noro 2693: else {
2694: /* compare args */
2695: n1 = FA0((FNODE)FA1(f1)); n2 = FA0((FNODE)FA1(f2));
2696: while ( n1 && n2 )
1.82 noro 2697: if ( r = fnode_normalize_comp(BDY(n1),BDY(n2)) ) return r;
2698: else {
2699: n1 = NEXT(n1); n2 = NEXT(n2);
2700: }
1.85 noro 2701: return n1?1:(n2?-1:0);
1.80 noro 2702: }
2703: break;
2704: case I_PVAR:
2705: return -1;
2706: default:
2707: error("fnode_normalize_comp : undefined");
2708: }
2709: case I_PVAR:
2710: switch ( f2->id ) {
2711: case I_FORMULA: case I_FUNC:
2712: return 1;
2713: case I_PVAR:
2714: i1 = (int)FA0(f1); i2 = (int)FA0(f2);
2715: if ( i1 > i2 ) return 1;
2716: else if ( i1 < i2 ) return -1;
2717: else return 0;
2718: default:
2719: error("fnode_normalize_comp : undefined");
2720: }
2721: break;
2722: default:
2723: error("fnode_normalize_comp : undefined");
2724: }
2725: }
2726:
2727: int fnode_normalize_comp_pwr(FNODE f1,FNODE f2)
2728: {
2729: FNODE b1,b2,e1,e2;
2730: int r;
2731:
2732: fnode_base_exp(f1,&b1,&e1);
2733: fnode_base_exp(f2,&b2,&e2);
1.83 noro 2734: if ( r = fnode_normalize_comp(b1,b2) ) {
2735: if ( r > 0 )
2736: return fnode_normalize_comp(e1,mkfnode(1,I_FORMULA,0));
2737: else if ( r < 0 )
2738: return fnode_normalize_comp(mkfnode(1,I_FORMULA,0),e2);
2739: } else return fnode_normalize_comp(e1,e2);
1.70 noro 2740: }
1.87 noro 2741:
1.88 noro 2742: NODE append_node(NODE a1,NODE a2)
2743: {
2744: NODE t,t0;
2745:
2746: if ( !a1 )
2747: return a2;
2748: else {
2749: for ( t0 = 0; a1; a1 = NEXT(a1) ) {
2750: NEXTNODE(t0,t); BDY(t) = BDY(a1);
2751: }
2752: NEXT(t) = a2;
2753: return t0;
2754: }
2755: }
2756:
1.90 noro 2757: int fnode_normalize_match(FNODE f,FNODE pat,NODE *rp)
1.87 noro 2758: {
2759: NODE m,m1,m2,base,exp,fa,pa,n;
2760: LIST l;
2761: QUOTE qp,qf;
1.88 noro 2762: FNODE fbase,fexp,a;
1.87 noro 2763: FUNC ff,pf;
2764: int r;
2765:
2766: switch ( pat->id ) {
2767: case I_PVAR:
2768: /* [[pat,f]] */
1.88 noro 2769: *rp = mknode(1,mknode(2,(int)FA0(pat),f),0);
1.87 noro 2770: return 1;
2771:
2772: case I_FORMULA:
2773: if ( !arf_comp(CO,(Obj)FA0(f),(Obj)FA0(pat)) ) {
2774: *rp = 0; return 1;
2775: } else
2776: return 0;
2777:
2778: case I_BOP:
2779: /* OPNAME should be "^" */
2780: if ( !IS_BINARYPWR(pat) )
1.90 noro 2781: error("fnode_normalize_match : invalid BOP");
1.87 noro 2782: if ( IS_BINARYPWR(f) ) {
2783: fbase = FA1(f); fexp = FA2(f);
2784: } else {
2785: fbase = f; fexp = mkfnode(1,I_FORMULA,ONE);
2786: }
1.90 noro 2787: if ( !fnode_normalize_match(fbase,FA1(pat),&base) ) return 0;
1.88 noro 2788: a = rewrite_fnode(FA2(pat),base);
1.90 noro 2789: if ( !fnode_normalize_match(fexp,a,&exp) ) return 0;
1.88 noro 2790: else {
2791: *rp = append_node(base,exp);
2792: return 1;
2793: }
1.87 noro 2794: break;
2795:
2796: case I_FUNC:
2797: if ( f->id != I_FUNC ) return 0;
2798: ff = (FUNC)FA0(f); pf = (FUNC)FA0(pat);
2799: if ( strcmp(ff->fullname,pf->fullname) ) return 0;
2800: /* FA1(f) and FA1(pat) are I_LIST */
2801: fa = (NODE)FA0((FNODE)FA1(f));
2802: pa = (NODE)FA0((FNODE)FA1(pat));
2803: m = 0;
2804: while ( fa && pa ) {
1.88 noro 2805: a = rewrite_fnode(BDY(pa),m);
1.90 noro 2806: if ( !fnode_normalize_match(BDY(fa),a,&m1) ) return 0;
1.88 noro 2807: m = append_node(m1,m);
2808: fa = NEXT(fa); pa = NEXT(pa);
1.87 noro 2809: }
2810: if ( fa || pa ) return 0;
2811: else {
2812: *rp = m;
2813: return 1;
2814: }
2815:
2816: case I_NARYOP:
2817: if ( IS_NARYADD(pat) )
1.90 noro 2818: return fnode_normalize_match_naryadd(f,pat,rp);
1.87 noro 2819: else if ( IS_NARYMUL(pat) )
1.90 noro 2820: return fnode_normalize_match_narymul(f,pat,rp);
1.87 noro 2821: else
1.90 noro 2822: error("fnode_normalize_match : invalid NARYOP");
1.87 noro 2823: break;
2824:
2825: default:
1.90 noro 2826: error("fnode_normalize_match : invalid pattern");
1.87 noro 2827: }
2828: }
2829:
1.88 noro 2830: /* remove i-th element */
1.87 noro 2831:
1.88 noro 2832: FNODE fnode_removeith_naryadd(FNODE p,int i)
2833: {
2834: int k,l;
2835: NODE t,r0,r,a;
2836:
2837: a = (NODE)FA1(p);
2838: l = length(a);
2839: if ( i < 0 || i >= l ) error("fnode_removeith_naryadd: invalid index");
2840: else if ( i == 0 )
2841: return fnode_node_to_naryadd(NEXT(a));
2842: else {
2843: for ( r0 = 0, k = 0, t = a; k < i; k++, t = NEXT(t) ) {
2844: NEXTNODE(r0,r);
2845: BDY(r) = BDY(t);
2846: }
2847: t = NEXT(t);
2848: NEXT(r) = 0;
2849: return fnode_node_to_naryadd(r0);
2850: }
2851:
2852: }
1.87 noro 2853:
1.88 noro 2854: /* a0,...,a(i-1) */
2855: FNODE fnode_left_narymul(FNODE p,int i)
1.87 noro 2856: {
1.88 noro 2857: int k,l;
2858: NODE t,r0,r,a;
2859:
2860: a = (NODE)FA1(p);
2861: l = length(a);
2862: if ( i < 0 || i >= l ) error("fnode_left_narymul : invalid index");
2863: if ( i == 0 ) return mkfnode(1,I_FORMULA,ONE);
2864: else if ( i == 1 ) return (FNODE)BDY(a);
2865: else {
2866: for ( r0 = 0, k = 0, t = a; k < i; k++, t = NEXT(t) ) {
2867: NEXTNODE(r0,r);
2868: BDY(r) = BDY(t);
2869: }
2870: NEXT(r) = 0;
2871: return fnode_node_to_narymul(r0);
2872: }
2873: }
2874:
2875: /* a(i+1),...,a(l-1) */
2876: FNODE fnode_right_narymul(FNODE p,int i)
2877: {
2878: NODE a,t;
2879: int l,k;
2880:
2881: a = (NODE)FA1(p);
2882: l = length(a);
2883: if ( i < 0 || i >= l ) error("fnode_right_narymul : invalid index");
2884: if ( i == l-1 ) return mkfnode(1,I_FORMULA,ONE);
2885: else {
2886: for ( k = 0, t = a; k <= i; k++, t = NEXT(t) );
2887: return fnode_node_to_narymul(t);
2888: }
2889: }
2890:
1.90 noro 2891: int fnode_normalize_match_naryadd(FNODE f,FNODE p,NODE *rp)
1.88 noro 2892: {
2893: int fl,pl,fi,pi;
2894: NODE fa,pa,t,s,m,m1;
2895: FNODE fr,pr,prr,pivot;
1.87 noro 2896:
2897: f = to_naryadd(f);
1.88 noro 2898: fa = (NODE)FA1(f); fl = length(fa);
2899: pa = (NODE)FA1(p); pl = length(pa);
2900: if ( fl < pl ) return 0;
2901: else if ( pl == 1 ) {
2902: if ( fl == 1 )
1.90 noro 2903: return fnode_normalize_match(BDY(fa),BDY(pa),rp);
1.87 noro 2904: else
2905: return 0;
2906: } else {
1.88 noro 2907: for ( t = pa, pi = 0; t; t = NEXT(t), pi++ )
2908: if ( ((FNODE)BDY(t))->id != I_PVAR ) break;
2909: if ( !t ) {
2910: /* all are I_PVAR */
2911: m = 0;
2912: for ( t = pa, s = fa; NEXT(t); t = NEXT(t), s = NEXT(s) ) {
1.90 noro 2913: fnode_normalize_match(BDY(s),BDY(t),&m1);
1.88 noro 2914: m = append_node(m1,m);
2915: }
2916: if ( !NEXT(s) )
2917: fr = (FNODE)BDY(s);
2918: else
2919: fr = mkfnode(2,I_NARYOP,FA0(f),s);
1.90 noro 2920: fnode_normalize_match(fr,BDY(t),&m1);
1.88 noro 2921: *rp = append_node(m1,m);
2922: return 1;
2923: } else {
2924: pivot = (FNODE)BDY(t);
2925: pr = fnode_removeith_naryadd(p,pi);
2926: for ( s = fa, fi = 0; s; s = NEXT(s), fi++ ) {
1.90 noro 2927: if ( fnode_normalize_match(BDY(s),pivot,&m) ) {
1.88 noro 2928: fr = fnode_removeith_naryadd(f,fi);
2929: prr = rewrite_fnode(pr,m);
1.90 noro 2930: if ( fnode_normalize_match(fr,prr,&m1) ) {
1.88 noro 2931: *rp = append_node(m,m1);
2932: return 1;
2933: }
2934: }
2935: }
2936: return 0;
2937: }
1.87 noro 2938: }
2939: }
2940:
1.90 noro 2941: int fnode_normalize_match_narymul(FNODE f,FNODE p,NODE *rp)
1.88 noro 2942: {
2943: int fl,pl,fi,pi;
2944: NODE fa,pa,t,s,m,m1;
2945: FNODE fr,pr,pleft,pleft1,pright,pright1,fleft,fright,pivot;
2946:
2947: f = to_narymul(f);
2948: fa = (NODE)FA1(f); fl = length(fa);
2949: pa = (NODE)FA1(p); pl = length(pa);
2950: if ( fl < pl ) return 0;
2951: else if ( pl == 1 ) {
2952: if ( fl == 1 )
1.90 noro 2953: return fnode_normalize_match(BDY(fa),BDY(pa),rp);
1.88 noro 2954: else
2955: return 0;
2956: } else {
2957: for ( t = pa, pi = 0; t; t = NEXT(t), pi++ )
2958: if ( ((FNODE)BDY(t))->id != I_PVAR ) break;
2959: if ( !t ) {
2960: /* all are I_PVAR */
2961: m = 0;
2962: for ( t = pa, s = fa; NEXT(t); t = NEXT(t), s = NEXT(s) ) {
2963: pr = rewrite_fnode(BDY(t),m);
1.90 noro 2964: if ( !fnode_normalize_match(BDY(s),pr,&m1) ) return 0;
1.88 noro 2965: m = append_node(m1,m);
2966: }
2967: if ( !NEXT(s) )
2968: fr = (FNODE)BDY(s);
2969: else
2970: fr = mkfnode(2,I_NARYOP,FA0(f),s);
2971: pr = rewrite_fnode(BDY(t),m);
1.90 noro 2972: if ( !fnode_normalize_match(fr,pr,&m1) ) return 0;
1.88 noro 2973: *rp = append_node(m1,m);
2974: return 1;
2975: } else {
2976: pivot = (FNODE)BDY(t);
2977: pleft = fnode_left_narymul(p,pi);
2978: pright = fnode_right_narymul(p,pi);
2979: /* XXX : incomplete */
2980: for ( s = fa, fi = 0; s; s = NEXT(s), fi++ ) {
1.90 noro 2981: if ( fnode_normalize_match(BDY(s),pivot,&m) ) {
1.88 noro 2982: fleft = fnode_left_narymul(f,fi);
2983: pleft1 = rewrite_fnode(pleft,m);
1.90 noro 2984: if ( fnode_normalize_match(fleft,pleft1,&m1) ) {
1.88 noro 2985: m = append_node(m1,m);
2986: fright = fnode_right_narymul(f,fi);
2987: pright1 = rewrite_fnode(pright,m);
1.90 noro 2988: if ( fnode_normalize_match(fright,pright1,&m1) ) {
1.88 noro 2989: *rp = append_node(m1,m);
2990: return 1;
2991: }
2992: }
2993: }
2994: }
2995: return 0;
2996: }
2997: }
2998: }