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