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