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