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