![[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.116 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.115 2006/08/09 05:05:28 noro Exp $
1.6 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "parse.h"
52: #include "ctype.h"
1.10 ohara 53: #if defined(PARI)
1.1 noro 54: #include "genpari.h"
1.11 saito 55: # if !(PARI_VERSION_CODE > 131588)
1.1 noro 56: extern jmp_buf environnement;
1.11 saito 57: # endif
1.1 noro 58: #endif
1.5 noro 59: #include <string.h>
60:
1.89 noro 61: #if defined(__GNUC__)
62: #define INLINE inline
63: #elif defined(VISUAL)
64: #define INLINE __inline
65: #else
66: #define INLINE
67: #endif
68:
1.18 noro 69: struct TeXSymbol {
70: char *text;
71: char *symbol;
72: };
73:
1.71 noro 74: #define OPNAME(f) (((ARF)FA0(f))->name[0])
1.77 noro 75: #define IS_ZERO(f) (((f)->id==I_FORMULA) && FA0(f)==0 )
1.75 noro 76: #define IS_BINARYPWR(f) (((f)->id==I_BOP) &&(OPNAME(f)=='^'))
77: #define IS_NARYADD(f) (((f)->id==I_NARYOP) &&(OPNAME(f)=='+'))
78: #define IS_NARYMUL(f) (((f)->id==I_NARYOP) &&(OPNAME(f)=='*'))
1.111 noro 79: #define IS_MUL(f) (((f)->id==I_NARYOP||(f)->id==I_BOP) &&(OPNAME(f)=='*'))
1.71 noro 80:
1.1 noro 81: extern char *parse_strp;
82:
1.50 ohara 83: void Psprintf();
1.1 noro 84: void Prtostr(), Pstrtov(), Peval_str();
1.3 noro 85: void Pstrtoascii(), Pasciitostr();
1.5 noro 86: void Pstr_len(), Pstr_chr(), Psub_str();
1.14 noro 87: void Pwrite_to_tb();
88: void Ptb_to_string();
89: void Pclear_tb();
90: void Pstring_to_tb();
91: void Pquotetotex_tb();
92: void Pquotetotex();
1.24 noro 93: void Pquotetotex_env();
1.47 noro 94: void Pflatten_quote();
1.69 noro 95:
1.108 noro 96: void Pqt_is_integer(),Pqt_is_rational(),Pqt_is_number(),Pqt_is_coef();
97: void Pqt_is_dependent(),Pqt_is_function(),Pqt_is_var();
1.109 noro 98: void Pqt_set_ord(),Pqt_set_coef(),Pqt_set_weight();
1.105 noro 99: void Pqt_normalize();
1.111 noro 100: void Pnqt_comp(),Pnqt_weight();
1.105 noro 101: void Pnqt_match();
1.106 noro 102: void Pnqt_match_rewrite();
1.69 noro 103:
1.105 noro 104: void Pqt_to_nbp();
1.101 noro 105: void Pshuffle_mul(), Pharmonic_mul();
1.102 noro 106: void Pnbp_hm(), Pnbp_ht(), Pnbp_hc(), Pnbp_rest();
1.115 noro 107: void Pnbp_tm(), Pnbp_tt(), Pnbp_tc(), Pnbp_trest();
1.102 noro 108: void Pnbm_deg();
109: void Pnbm_hp_rest();
110: void Pnbm_hxky(), Pnbm_xky_rest();
1.116 ! noro 111: void Pnbm_hv(), Pnbm_tv(), Pnbm_rest();
1.98 noro 112:
1.52 noro 113: void Pquote_to_funargs(),Pfunargs_to_quote(),Pget_function_name();
1.107 noro 114: void Pqt_match(),Pget_quote_id();
1.105 noro 115: void Pqt_to_nary(),Pqt_to_bin();
1.88 noro 116: void fnode_do_assign(NODE arg);
1.58 ohara 117: void do_assign(NODE arg);
1.14 noro 118: void fnodetotex_tb(FNODE f,TB tb);
119: char *symbol_name(char *name);
1.28 noro 120: char *conv_rule(char *name);
1.38 noro 121: char *conv_subs(char *name);
1.28 noro 122: char *call_convfunc(char *name);
1.14 noro 123: void tb_to_string(TB tb,STRING *rp);
124: void fnodenodetotex_tb(NODE n,TB tb);
125: void fargstotex_tb(char *opname,FNODE f,TB tb);
1.35 noro 126: int top_is_minus(FNODE f);
1.105 noro 127: int qt_match(Obj f,Obj pat,NODE *rp);
1.106 noro 128: FNODE partial_eval(FNODE), fnode_to_nary(FNODE), fnode_to_bin(FNODE,int);
129: FNODE nfnode_add(FNODE a1,FNODE a2,int expand);
130: FNODE nfnode_mul(FNODE a1,FNODE a2,int expand);
131: FNODE nfnode_pwr(FNODE a1,FNODE a2,int expand);
1.108 noro 132: FNODE nfnode_mul_coef(Obj c,FNODE f,int expand);
1.106 noro 133: FNODE fnode_expand_pwr(FNODE f,int n,int expand);
134: FNODE to_narymul(FNODE f);
135: FNODE to_naryadd(FNODE f);
136: FNODE fnode_node_to_nary(ARF op,NODE n);
137: void fnode_base_exp(FNODE f,FNODE *bp,FNODE *ep);
1.108 noro 138: void fnode_coef_body(FNODE f,Obj *cp,FNODE *bp);
1.106 noro 139: FNODE nfnode_match_rewrite(FNODE f,FNODE p,FNODE c,FNODE a,int mode);
140: FNODE fnode_apply(FNODE f,FNODE (*func)(),int expand);
141: FNODE fnode_normalize(FNODE f,int expand);
1.107 noro 142: FNODE rewrite_fnode(FNODE f,NODE arg,int qarg);
1.1 noro 143:
144: struct ftab str_tab[] = {
1.50 ohara 145: {"sprintf",Psprintf,-99999999},
1.1 noro 146: {"rtostr",Prtostr,1},
147: {"strtov",Pstrtov,1},
148: {"eval_str",Peval_str,1},
1.3 noro 149: {"strtoascii",Pstrtoascii,1},
150: {"asciitostr",Pasciitostr,1},
1.5 noro 151: {"str_len",Pstr_len,1},
152: {"str_chr",Pstr_chr,3},
153: {"sub_str",Psub_str,3},
1.14 noro 154: {"write_to_tb",Pwrite_to_tb,2},
155: {"clear_tb",Pclear_tb,1},
156: {"tb_to_string",Ptb_to_string,1},
157: {"string_to_tb",Pstring_to_tb,1},
1.63 noro 158: {"get_quote_id",Pget_quote_id,1},
1.69 noro 159:
1.108 noro 160: {"qt_is_var",Pqt_is_var,1},
161: {"qt_is_coef",Pqt_is_coef,1},
1.105 noro 162: {"qt_is_number",Pqt_is_number,1},
163: {"qt_is_rational",Pqt_is_rational,1},
164: {"qt_is_integer",Pqt_is_integer,1},
165: {"qt_is_function",Pqt_is_function,1},
166: {"qt_is_dependent",Pqt_is_dependent,2},
167:
1.108 noro 168: {"qt_set_coef",Pqt_set_coef,-1},
1.105 noro 169: {"qt_set_ord",Pqt_set_ord,-1},
1.109 noro 170: {"qt_set_weight",Pqt_set_weight,-1},
1.105 noro 171: {"qt_normalize",Pqt_normalize,-2},
172: {"qt_match",Pqt_match,2},
1.106 noro 173: {"nqt_match_rewrite",Pnqt_match_rewrite,3},
1.105 noro 174:
1.111 noro 175: {"nqt_weight",Pnqt_weight,1},
1.105 noro 176: {"nqt_comp",Pnqt_comp,2},
177: {"nqt_match",Pnqt_match,-3},
178: {"qt_to_nbp",Pqt_to_nbp,1},
1.101 noro 179: {"shuffle_mul",Pshuffle_mul,2},
180: {"harmonic_mul",Pharmonic_mul,2},
1.70 noro 181:
1.100 noro 182: {"nbp_hm", Pnbp_hm,1},
183: {"nbp_ht", Pnbp_ht,1},
184: {"nbp_hc", Pnbp_hc,1},
185: {"nbp_rest", Pnbp_rest,1},
1.115 noro 186: {"nbp_tm", Pnbp_tm,1},
187: {"nbp_tt", Pnbp_tt,1},
188: {"nbp_tc", Pnbp_tc,1},
189: {"nbp_trest", Pnbp_trest,1},
1.102 noro 190: {"nbm_deg", Pnbm_deg,1},
191: {"nbm_hxky", Pnbm_hxky,1},
192: {"nbm_xky_rest", Pnbm_xky_rest,1},
193: {"nbm_hp_rest", Pnbm_hp_rest,1},
194: {"nbm_hv", Pnbm_hv,1},
1.116 ! noro 195: {"nbm_tv", Pnbm_tv,1},
1.100 noro 196: {"nbm_rest", Pnbm_rest,1},
197:
1.105 noro 198: {"qt_to_nary",Pqt_to_nary,1},
199: {"qt_to_bin",Pqt_to_bin,2},
1.95 noro 200:
1.60 noro 201: {"quotetotex_tb",Pquotetotex_tb,2},
202: {"quotetotex",Pquotetotex,1},
203: {"quotetotex_env",Pquotetotex_env,-99999999},
1.65 noro 204: {"flatten_quote",Pflatten_quote,-2},
1.60 noro 205: {"quote_to_funargs",Pquote_to_funargs,1},
1.48 noro 206: {"funargs_to_quote",Pfunargs_to_quote,1},
1.52 noro 207: {"get_function_name",Pget_function_name,1},
1.1 noro 208: {0,0,0},
209: };
1.13 noro 210:
1.14 noro 211: void write_tb(char *s,TB tb)
212: {
213: if ( tb->next == tb->size ) {
214: tb->size *= 2;
215: tb->body = (char **)REALLOC(tb->body,tb->size*sizeof(char *));
216: }
217: tb->body[tb->next] = s;
218: tb->next++;
219: }
1.13 noro 220:
1.18 noro 221: int register_symbol_table(Obj arg);
222: int register_conv_rule(Obj arg);
1.38 noro 223: int register_conv_func(Obj arg);
1.23 noro 224: int register_dp_vars(Obj arg);
1.46 noro 225: int register_dp_vars_origin(Obj arg);
226: int register_dp_dvars_origin(Obj arg);
227: int register_dp_dvars_prefix(Obj arg);
1.25 noro 228: int register_dp_vars_prefix(Obj arg);
1.31 noro 229: int register_dp_vars_hweyl(Obj arg);
1.27 noro 230: int register_show_lt(Obj arg);
1.40 noro 231: char *objtostr(Obj obj);
1.18 noro 232: static struct TeXSymbol *user_texsymbol;
1.23 noro 233: static char **dp_vars;
1.25 noro 234: static int dp_vars_len;
235: static char *dp_vars_prefix;
1.46 noro 236: static char *dp_dvars_prefix;
237: static int dp_vars_origin;
238: static int dp_dvars_origin;
1.27 noro 239: static int show_lt;
1.26 noro 240: static FUNC convfunc;
1.27 noro 241: static int is_lt;
1.28 noro 242: static int conv_flag;
1.31 noro 243: static int dp_vars_hweyl;
1.28 noro 244:
1.38 noro 245: #define CONV_TABLE (1U<<0)
246: #define CONV_SUBS (1U<<1)
247: #define CONV_DMODE (1U<<2)
1.18 noro 248:
249: static struct {
250: char *name;
251: Obj value;
252: int (*reg)();
253: } qtot_env[] = {
254: {"symbol_table",0,register_symbol_table},
255: {"conv_rule",0,register_conv_rule},
1.38 noro 256: {"conv_func",0,register_conv_func},
1.23 noro 257: {"dp_vars",0,register_dp_vars},
1.25 noro 258: {"dp_vars_prefix",0,register_dp_vars_prefix},
1.46 noro 259: {"dp_dvars_prefix",0,register_dp_dvars_prefix},
260: {"dp_vars_origin",0,register_dp_vars_origin},
261: {"dp_dvars_origin",0,register_dp_dvars_origin},
1.31 noro 262: {"dp_vars_hweyl",0,register_dp_vars_hweyl},
1.27 noro 263: {"show_lt",0,register_show_lt},
1.18 noro 264: {0,0,0},
265: };
266:
1.20 noro 267: #define PARTIAL "\\partial"
1.28 noro 268:
269: char *conv_rule(char *name)
270: {
271: char *body,*r;
1.41 noro 272: int len;
1.28 noro 273:
1.38 noro 274: if ( convfunc )
275: name = call_convfunc(name);
1.41 noro 276: if ( conv_flag & CONV_TABLE ) {
277: r = symbol_name(name);
278: if ( r ) return r;
279: }
280: if ( (conv_flag & CONV_DMODE) && *name == 'd' ) {
281: body = conv_rule(name+1);
282: r = MALLOC_ATOMIC((strlen(PARTIAL)+strlen(body)+5)*sizeof(char));
283: if ( !body || !(len=strlen(body)) )
284: strcpy(r,PARTIAL);
285: else if ( len == 1 )
286: sprintf(r,"%s_%s",PARTIAL,body);
287: else
288: sprintf(r,"%s_{%s}",PARTIAL,body);
289: return r;
290: } else
291: return conv_subs(name);
1.28 noro 292: }
293:
1.40 noro 294: int _is_delimiter(char c)
295: {
296: if ( (c == ' ' || c == '_' || c == ',') ) return 1;
297: else return 0;
298: }
299:
300: int _is_alpha(char c)
301: {
302: if ( isdigit(c) || c == '{' || _is_delimiter(c) ) return 0;
303: else return 1;
304: }
305:
1.38 noro 306: char *conv_subs(char *name)
1.19 noro 307: {
1.29 noro 308: int i,j,k,len,clen,slen,start,level;
1.41 noro 309: char *buf,*head,*r,*h,*brace,*buf_conv;
1.28 noro 310: char **subs;
311:
1.41 noro 312: if ( !name || !(len=strlen(name)) ) return "";
313: if ( !(conv_flag&CONV_SUBS) ) return name;
1.28 noro 314: subs = (char **)ALLOCA(len*sizeof(char* ));
1.32 noro 315: for ( i = 0, j = 0, start = i; ; j++ ) {
1.40 noro 316: while ( (i < len) && _is_delimiter(name[i]) ) i++;
1.32 noro 317: start = i;
1.28 noro 318: if ( i == len ) break;
1.29 noro 319: if ( name[i] == '{' ) {
320: for ( level = 1, i++; i < len && level; i++ ) {
321: if ( name[i] == '{' ) level++;
322: else if ( name[i] == '}' ) level--;
323: }
1.32 noro 324: slen = i-start;
1.37 noro 325: if ( slen >= 3 ) {
326: brace = (char *)ALLOCA((slen+1)*sizeof(char));
327: strncpy(brace,name+start+1,slen-2);
328: brace[slen-2] = 0;
1.38 noro 329: buf = conv_subs(brace);
1.37 noro 330: subs[j] = (char *)ALLOCA((strlen(buf)+3)*sizeof(char));
1.38 noro 331: if ( strlen(buf) == 1 )
332: strcpy(subs[j],buf);
333: else
334: sprintf(subs[j],"{%s}",buf);
1.37 noro 335: } else
336: subs[j] = "{}";
1.32 noro 337: } else {
338: if ( isdigit(name[i]) )
339: while ( i < len && isdigit(name[i]) ) i++;
340: else
1.40 noro 341: while ( i < len && _is_alpha(name[i]) ) i++;
1.32 noro 342: slen = i-start;
343: buf = (char *)ALLOCA((slen+1)*sizeof(char));
344: strncpy(buf,name+start,slen); buf[slen] = 0;
1.41 noro 345: buf_conv = symbol_name(buf);
346: subs[j] = buf_conv?buf_conv:buf;
1.32 noro 347: }
1.28 noro 348: }
1.32 noro 349: for ( k = 0, clen = 0; k < j; k++ ) clen += strlen(subs[k]);
350: /* {subs(0)}_{{subs(1)},...,{subs(j-1)}} => {}:j+1 _:1 ,:j-2 */
351: h = r = MALLOC_ATOMIC((clen+(j+1)*2+1+(j-2)+1)*sizeof(char));
352: if ( j == 1 )
353: sprintf(h,"{%s}",subs[0]);
1.28 noro 354: else {
1.38 noro 355: sprintf(h,"{%s}_{%s",subs[0],subs[1]);
1.28 noro 356: h += strlen(h);
1.32 noro 357: for ( k = 2; k < j; k++ ) {
1.38 noro 358: sprintf(h,",%s",subs[k]);
1.28 noro 359: h += strlen(h);
1.19 noro 360: }
1.28 noro 361: strcpy(h,"}");
1.20 noro 362: }
363: return r;
1.19 noro 364: }
365:
1.26 noro 366: char *call_convfunc(char *name)
367: {
368: STRING str,r;
369: NODE arg;
370:
371: MKSTR(str,name);
372: arg = mknode(1,str);
373: r = (STRING)bevalf(convfunc,arg);
374: if ( !r || OID(r) != O_STR )
375: error("call_convfunc : invalid result");
376: return BDY(r);
377: }
378:
1.18 noro 379: int register_symbol_table(Obj arg)
380: {
381: NODE n,t;
382: Obj b;
383: STRING a0,a1;
384: struct TeXSymbol *uts;
385: int i,len;
386:
387: /* check */
388: if ( !arg ) {
389: user_texsymbol = 0;
390: return 1;
391: }
392: if ( OID(arg) != O_LIST ) return 0;
393:
394: n = BDY((LIST)arg);
395: len = length(n);
396: uts = (struct TeXSymbol *)MALLOC((len+1)*sizeof(struct TeXSymbol));
397: for ( i = 0; n; n = NEXT(n), i++ ) {
398: b = (Obj)BDY(n);
399: if ( !b || OID(b) != O_LIST ) return 0;
400: t = BDY((LIST)b);
401: if ( !t || !NEXT(t) ) return 0;
402: a0 = (STRING)BDY(t);
403: a1 = (STRING)BDY(NEXT(t));
1.23 noro 404: if ( !a0 ) return 0;
405: if ( OID(a0) == O_STR )
406: uts[i].text = BDY(a0);
407: else if ( OID(a0) == O_P )
408: uts[i].text = NAME(VR((P)a0));
409: else
410: return 0;
411: if ( !a1 ) return 0;
412: if ( OID(a1) == O_STR )
413: uts[i].symbol = BDY(a1);
414: else if ( OID(a1) == O_P )
415: uts[i].symbol = NAME(VR((P)a1));
416: else
417: return 0;
1.18 noro 418: }
419: uts[i].text = 0;
420: uts[i].symbol = 0;
421: user_texsymbol = uts;
422: return 1;
423: }
424:
1.46 noro 425: int register_dp_vars_origin(Obj arg)
426: {
427: if ( INT(arg) ) {
428: dp_vars_origin = QTOS((Q)arg);
429: return 1;
430: } else return 0;
431: }
432:
433: int register_dp_dvars_origin(Obj arg)
434: {
435: if ( INT(arg) ) {
436: dp_dvars_origin = QTOS((Q)arg);
437: return 1;
438: } else return 0;
439: }
440:
1.31 noro 441: int register_dp_vars_hweyl(Obj arg)
442: {
443: if ( INT(arg) ) {
444: dp_vars_hweyl = QTOS((Q)arg);
445: return 1;
446: } else return 0;
447: }
448:
1.27 noro 449: int register_show_lt(Obj arg)
450: {
451: if ( INT(arg) ) {
452: show_lt = QTOS((Q)arg);
453: return 1;
454: } else return 0;
455: }
1.26 noro 456:
1.18 noro 457: int register_conv_rule(Obj arg)
458: {
1.19 noro 459: if ( INT(arg) ) {
1.28 noro 460: conv_flag = QTOS((Q)arg);
461: convfunc = 0;
462: return 1;
1.38 noro 463: } else return 0;
464: }
465:
466: int register_conv_func(Obj arg)
467: {
1.43 noro 468: if ( !arg ) {
469: convfunc = 0;
470: return 1;
471: } else if ( OID(arg) == O_P && (int)(VR((P)arg))->attr == V_SR ) {
1.26 noro 472: convfunc = (FUNC)(VR((P)arg)->priv);
473: /* f must be a function which takes single argument */
474: return 1;
1.19 noro 475: } else return 0;
1.18 noro 476: }
477:
1.23 noro 478: int register_dp_vars(Obj arg)
479: {
480: int l,i;
481: char **r;
482: NODE n;
483: STRING a;
484:
485: if ( !arg ) {
486: dp_vars = 0;
487: dp_vars_len = 0;
1.25 noro 488: return 1;
1.23 noro 489: } else if ( OID(arg) != O_LIST )
490: return 0;
491: else {
492: n = BDY((LIST)arg);
493: l = length(n);
494: r = (char **)MALLOC_ATOMIC(l*sizeof(char *));
495: for ( i = 0; i < l; i++, n = NEXT(n) ) {
496: a = (STRING)BDY(n);
497: if ( !a ) return 0;
498: if ( OID(a) == O_STR )
499: r[i] = BDY(a);
500: else if ( OID(a) == O_P )
501: r[i] = NAME(VR((P)a));
502: else
503: return 0;
504: }
505: dp_vars = r;
506: dp_vars_len = l;
507: return 1;
508: }
509: }
510:
1.25 noro 511: int register_dp_vars_prefix(Obj arg)
512: {
513: if ( !arg ) {
514: dp_vars_prefix = 0;
515: return 1;
516: } else if ( OID(arg) == O_STR ) {
517: dp_vars_prefix = BDY((STRING)arg);
518: return 1;
519: } else if ( OID(arg) == O_P ) {
520: dp_vars_prefix = NAME(VR((P)arg));
521: return 1;
522: } else return 0;
523: }
524:
1.46 noro 525: int register_dp_dvars_prefix(Obj arg)
526: {
527: if ( !arg ) {
528: dp_dvars_prefix = 0;
529: return 1;
530: } else if ( OID(arg) == O_STR ) {
531: dp_dvars_prefix = BDY((STRING)arg);
532: return 1;
533: } else if ( OID(arg) == O_P ) {
534: dp_dvars_prefix = NAME(VR((P)arg));
535: return 1;
536: } else return 0;
537: }
538:
1.24 noro 539: void Pquotetotex_env(NODE arg,Obj *rp)
1.18 noro 540: {
541: int ac,i;
542: char *name;
543: NODE n,n0;
544: STRING s;
545: LIST l;
546:
547: ac = argc(arg);
548: if ( !ac ) {
549: n0 = 0;
550: for ( i = 0; qtot_env[i].name; i++ ) {
551: NEXTNODE(n0,n); MKSTR(s,qtot_env[i].name); BDY(n) = (pointer)s;
552: NEXTNODE(n0,n); BDY(n) = (Q)qtot_env[i].value;
553: }
554: NEXT(n) = 0;
555: MKLIST(l,n0);
556: *rp = (Obj)l;
1.34 noro 557: } else if ( ac == 1 && !ARG0(arg) ) {
558: /* set to default */
1.43 noro 559: for ( i = 0; qtot_env[i].name; i++ ) {
560: (qtot_env[i].reg)(0);
1.34 noro 561: qtot_env[i].value = 0;
1.43 noro 562: }
1.34 noro 563: *rp = 0;
1.18 noro 564: } else if ( ac == 1 || ac == 2 ) {
1.24 noro 565: asir_assert(ARG0(arg),O_STR,"quotetotex_env");
1.18 noro 566: name = BDY((STRING)ARG0(arg));
567: for ( i = 0; qtot_env[i].name; i++ )
568: if ( !strcmp(qtot_env[i].name,name) ) {
569: if ( ac == 2 ) {
570: if ( (qtot_env[i].reg)((Obj)ARG1(arg)) )
571: qtot_env[i].value = (Obj)ARG1(arg);
572: else
1.24 noro 573: error("quotetotex_env : invalid argument");
1.18 noro 574: }
575: *rp = qtot_env[i].value;
576: return;
577: }
578: *rp = 0;
579: } else
580: *rp = 0;
581: }
582:
1.14 noro 583: void Pwrite_to_tb(NODE arg,Q *rp)
1.13 noro 584: {
585: int i;
1.16 noro 586: Obj obj;
587: TB tb;
1.13 noro 588:
1.14 noro 589: asir_assert(ARG1(arg),O_TB,"write_to_tb");
1.16 noro 590: obj = ARG0(arg);
591: if ( !obj )
592: write_tb("",ARG1(arg));
593: else if ( OID(obj) == O_STR )
594: write_tb(BDY((STRING)obj),ARG1(arg));
595: else if ( OID(obj) == O_TB ) {
596: tb = (TB)obj;
597: for ( i = 0; i < tb->next; i++ )
598: write_tb(tb->body[i],ARG1(arg));
599: }
1.14 noro 600: *rp = 0;
1.53 noro 601: }
602:
1.105 noro 603: void Pqt_to_nary(NODE arg,QUOTE *rp)
1.63 noro 604: {
605: FNODE f;
606:
1.70 noro 607: f = fnode_to_nary(BDY((QUOTE)ARG0(arg)));
1.63 noro 608: MKQUOTE(*rp,f);
609: }
610:
1.105 noro 611: void Pqt_to_bin(NODE arg,QUOTE *rp)
1.63 noro 612: {
613: FNODE f;
614: int direction;
615:
616: direction = QTOS((Q)ARG1(arg));
1.70 noro 617: f = fnode_to_bin(BDY((QUOTE)ARG0(arg)),direction);
1.63 noro 618:
619: MKQUOTE(*rp,f);
620: }
1.61 noro 621:
1.108 noro 622: void Pqt_is_var(NODE arg,Q *rp)
623: {
624: QUOTE q;
625: int ret;
626:
627: q = (QUOTE)ARG0(arg);
628: asir_assert(q,O_QUOTE,"qt_is_var");
629: ret = fnode_is_var(BDY(q));
630: STOQ(ret,*rp);
631: }
632:
633: void Pqt_is_coef(NODE arg,Q *rp)
634: {
635: QUOTE q;
636: int ret;
637:
638: q = (QUOTE)ARG0(arg);
639: asir_assert(q,O_QUOTE,"qt_is_coef");
640: ret = fnode_is_coef(BDY(q));
641: STOQ(ret,*rp);
642: }
643:
1.105 noro 644: void Pqt_is_number(NODE arg,Q *rp)
1.69 noro 645: {
646: QUOTE q;
647: int ret;
648:
649: q = (QUOTE)ARG0(arg);
1.105 noro 650: asir_assert(q,O_QUOTE,"qt_is_number");
1.69 noro 651: ret = fnode_is_number(BDY(q));
652: STOQ(ret,*rp);
653: }
654:
1.105 noro 655: void Pqt_is_rational(NODE arg,Q *rp)
1.69 noro 656: {
657: QUOTE q;
658: int ret;
659:
660: q = (QUOTE)ARG0(arg);
1.105 noro 661: asir_assert(q,O_QUOTE,"qt_is_rational");
1.69 noro 662: ret = fnode_is_rational(BDY(q));
663: STOQ(ret,*rp);
664: }
665:
1.105 noro 666: void Pqt_is_integer(NODE arg,Q *rp)
1.69 noro 667: {
668: QUOTE q;
669: int ret;
670:
671: q = (QUOTE)ARG0(arg);
1.105 noro 672: asir_assert(q,O_QUOTE,"qt_is_integer");
1.69 noro 673: ret = fnode_is_integer(BDY(q));
674: STOQ(ret,*rp);
675: }
676:
1.105 noro 677: void Pqt_is_function(NODE arg,Q *rp)
1.69 noro 678: {
679: QUOTE q;
680: int ret;
681:
682: q = (QUOTE)ARG0(arg);
1.105 noro 683: asir_assert(q,O_QUOTE,"qt_is_function");
1.69 noro 684: if ( q->id == I_FUNC || q->id == I_IFUNC )
685: ret = 1;
686: else
687: ret = 0;
688: STOQ(ret,*rp);
689: }
690:
1.105 noro 691: void Pqt_is_dependent(NODE arg,Q *rp)
1.69 noro 692: {
693: P x;
694: QUOTE q,v;
695: int ret;
696: V var;
697:
698: q = (QUOTE)ARG0(arg);
699: v = (QUOTE)ARG1(arg);
1.105 noro 700: asir_assert(q,O_QUOTE,"qt_is_dependent");
701: asir_assert(v,O_QUOTE,"qt_is_dependent");
1.69 noro 702: x = (P)eval(BDY(v));
703: if ( !x || OID(x) != O_P )
704: *rp = 0;
705: var = VR(x);
706: ret = fnode_is_dependent(BDY(q),var);
707: STOQ(ret,*rp);
708: }
709:
710:
1.105 noro 711: void Pqt_match(NODE arg,Q *rp)
1.53 noro 712: {
1.61 noro 713: FNODE f,g;
1.65 noro 714: Obj obj;
1.61 noro 715: QUOTE q;
1.53 noro 716: NODE r;
1.56 noro 717: int ret;
1.53 noro 718:
1.65 noro 719: obj = (Obj)ARG0(arg);
1.105 noro 720: ret = qt_match(obj,(Obj)ARG1(arg),&r);
1.57 noro 721: if ( ret ) {
722: do_assign(r);
723: *rp = ONE;
724: } else
1.56 noro 725: *rp = 0;
1.68 noro 726: }
727:
1.105 noro 728: void Pnqt_match(NODE arg,Q *rp)
1.88 noro 729: {
730: QUOTE fq,pq;
731: FNODE f,p;
732: int ret;
1.104 noro 733: Q mode;
1.88 noro 734: NODE r;
735:
1.104 noro 736: mode = argc(arg)==3 ? (Q)ARG2(arg) : 0;
1.105 noro 737: fq = (QUOTE)ARG0(arg); Pqt_normalize(mknode(2,fq,mode),&fq); f = (FNODE)BDY(fq);
738: pq = (QUOTE)ARG1(arg); Pqt_normalize(mknode(2,pq,mode),&pq); p = (FNODE)BDY(pq);
1.95 noro 739: ret = nfnode_match(f,p,&r);
1.88 noro 740: if ( ret ) {
741: fnode_do_assign(r);
742: *rp = ONE;
743: } else
744: *rp = 0;
745: }
746:
1.106 noro 747: void Pnqt_match_rewrite(NODE arg,Obj *rp)
748: {
749: FNODE f,p,c,a,r;
750: Obj obj,pat,cond,action;
751: NODE rule;
752: QUOTE q;
753: Q mode;
754: int m;
755:
756: obj = (Obj)ARG0(arg);
757: rule = BDY((LIST)ARG1(arg));
758: mode = (Q)ARG2(arg);
759: if ( length(rule) == 2 ) {
760: pat = ARG0(rule);
761: cond = (Obj)ONE;
762: action = (Obj)ARG1(rule);
763: } else {
764: pat = ARG0(rule);
765: cond = ARG1(rule);
766: action = (Obj)ARG2(rule);
767: }
768: Pqt_normalize(mknode(2,obj,mode),&q); f = (FNODE)BDY(q);
769: Pqt_normalize(mknode(2,pat,mode),&q); p = (FNODE)BDY(q);
770: Pqt_normalize(mknode(2,action,mode),&q);
771: a = (FNODE)BDY(q);
772: if ( OID(cond) == O_QUOTE ) c = BDY((QUOTE)cond);
773: else c = mkfnode(1,I_FORMULA,ONE);
774:
775: m = QTOS(mode);
776: r = nfnode_match_rewrite(f,p,c,a,m);
777: if ( r ) {
778: MKQUOTE(q,r);
779: *rp = (Obj)q;
780: } else
781: *rp = obj;
782: }
783:
784: /* f is NARYOP => do submatch */
785:
786: #define PV_ANY 99999999
787:
788: FNODE nfnode_match_rewrite(FNODE f,FNODE p,FNODE c,FNODE a,int mode)
789: {
790: ARF op;
791: NODE arg,h0,t,h,valuen;
792: NODE r,s0,s,pair;
1.107 noro 793: FNODE any,pany,head,tail,a1,a2;
1.106 noro 794: QUOTE q;
795: int ret;
796: FNODE value;
797: int ind;
798:
799: if ( f->id == I_NARYOP ) {
800: op = (ARF)FA0(f);
801: arg = (NODE)FA1(f);
802: pany = 0;
803: for ( h0 = 0, t = arg; t; t = NEXT(t) ) {
804: tail = fnode_node_to_nary(op,t);
805: ret = nfnode_match(tail,p,&r) && eval(rewrite_fnode(c,r,1));
806: if ( ret ) break;
807:
808: /* append a variable to the pattern */
809: if ( !pany ) {
810: any = mkfnode(1,I_PVAR,PV_ANY);
811: pany = mkfnode(3,I_BOP,op,p,any);
812: pany = fnode_normalize(pany,mode);
813: }
814: ret = nfnode_match(tail,pany,&r) && eval(rewrite_fnode(c,r,1));
815: if ( ret ) {
816: a = fnode_normalize(mkfnode(3,I_BOP,op,a,any),mode);
817: break;
818: }
819:
820: NEXTNODE(h0,h);
821: BDY(h) = BDY(t);
822: }
823: if ( t ) {
824: if ( h0 ) NEXT(h) = 0;
825: head = fnode_node_to_nary(op,h0);
826: a = fnode_normalize(mkfnode(3,I_BOP,op,head,a),mode);
827: ret = 1;
828: } else
829: ret = 0;
830: } else
831: ret = nfnode_match(f,p,&r) && eval(rewrite_fnode(c,r,1));
832:
833: if ( ret ) {
1.107 noro 834: a1 = rewrite_fnode(a,r,0);
835: a2 = partial_eval(a1);
836: return fnode_normalize(a2,mode);
1.106 noro 837: } else
838: return 0;
839: }
840:
1.56 noro 841: void do_assign(NODE arg)
842: {
843: NODE t,pair;
844: int pv;
845:
846: QUOTE value;
847:
848: for ( t = arg; t; t = NEXT(t) ) {
849: pair = BDY((LIST)BDY(t));
850: pv = (int)FA0((FNODE)BDY((QUOTE)BDY(pair)));
851: value = (QUOTE)(BDY(NEXT(pair)));
852: ASSPV(pv,value);
853: }
1.53 noro 854: }
855:
1.88 noro 856: /* [[index,fnode],...] */
857:
858: void fnode_do_assign(NODE arg)
859: {
860: NODE t,pair;
861: int pv;
862: FNODE f;
863: QUOTE value;
1.95 noro 864: QUOTEARG qa;
1.88 noro 865:
866: for ( t = arg; t; t = NEXT(t) ) {
867: pair = (NODE)BDY(t);
868: pv = (int)BDY(pair);
869: f = (FNODE)(BDY(NEXT(pair)));
1.96 noro 870: if ( f->id == I_FUNC_HEAD ) {
871: /* XXX : I_FUNC_HEAD is a dummy id to pass FUNC */
1.95 noro 872: MKQUOTEARG(qa,A_func,FA0(f));
873: value = (QUOTE)qa;
874: } else
875: MKQUOTE(value,f);
1.88 noro 876: ASSPV(pv,value);
877: }
878: }
879:
1.53 noro 880: /*
1.56 noro 881: /* consistency check and merge
882: */
1.53 noro 883:
1.56 noro 884: int merge_matching_node(NODE n,NODE a,NODE *rp)
1.53 noro 885: {
886: NODE ta,ba,tn,bn;
887: QUOTE pa,va,pn,vn;
888:
1.56 noro 889: if ( !n ) {
890: *rp = a;
891: return 1;
892: }
1.53 noro 893: for ( ta = a; ta; ta = NEXT(ta) ) {
894: ba = BDY((LIST)BDY(ta));
1.55 noro 895: if ( !ba ) continue;
1.53 noro 896: pa = (QUOTE)BDY(ba); va = (QUOTE)BDY(NEXT(ba));
897: for ( tn = n; tn; tn = NEXT(tn) ) {
898: bn = BDY((LIST)BDY(tn));
1.55 noro 899: if ( !bn ) continue;
1.53 noro 900: pn = (QUOTE)BDY(bn); vn = (QUOTE)BDY(NEXT(bn));
1.55 noro 901: if ( !compquote(CO,pa,pn) ) {
902: if ( !compquote(CO,va,vn) ) break;
903: else return 0;
904: }
1.53 noro 905: }
906: if ( !tn ) {
907: MKNODE(tn,(pointer)BDY(ta),n);
908: n = tn;
909: }
910: }
1.56 noro 911: *rp = n;
912: return 1;
1.53 noro 913: }
914:
1.105 noro 915: int qt_match_node(NODE f,NODE pat,NODE *rp) {
1.56 noro 916: NODE r,a,tf,tp,r1;
917: int ret;
1.53 noro 918:
919: if ( length(f) != length(pat) ) return 0;
920: r = 0;
921: for ( tf = f, tp = pat; tf; tf = NEXT(tf), tp = NEXT(tp) ) {
1.105 noro 922: ret = qt_match((Obj)BDY(tf),(Obj)BDY(tp),&a);
1.56 noro 923: if ( !ret ) return 0;
924: ret = merge_matching_node(r,a,&r1);
925: if ( !ret ) return 0;
926: else r = r1;
1.53 noro 927: }
1.56 noro 928: *rp = r;
929: return 1;
1.53 noro 930: }
931:
1.66 noro 932: /* f = [a,b,c,...] pat = [X,Y,...] rpat matches the rest of f */
933:
1.105 noro 934: int qt_match_cons(NODE f,NODE pat,Obj rpat,NODE *rp) {
1.66 noro 935: QUOTE q;
936: Q id;
937: FNODE fn;
938: NODE r,a,tf,tp,r1,arg;
939: int ret;
940: LIST list,alist;
941:
942: /* matching of the head part */
943: if ( length(f) < length(pat) ) return 0;
944: r = 0;
945: for ( tf = f, tp = pat; tp; tf = NEXT(tf), tp = NEXT(tp) ) {
1.105 noro 946: ret = qt_match((Obj)BDY(tf),(Obj)BDY(tp),&a);
1.66 noro 947: if ( !ret ) return 0;
948: ret = merge_matching_node(r,a,&r1);
949: if ( !ret ) return 0;
950: else r = r1;
951: }
952: /* matching of the rest */
953: MKLIST(list,tf);
954: STOQ(I_LIST,id); a = mknode(2,id,list);
955: MKLIST(alist,a);
956: arg = mknode(1,alist);
957: Pfunargs_to_quote(arg,&q);
1.105 noro 958: ret = qt_match((Obj)q,rpat,&a);
1.66 noro 959: if ( !ret ) return 0;
960: ret = merge_matching_node(r,a,&r1);
961: if ( !ret ) return 0;
962: *rp = r1;
963: return 1;
964: }
965:
1.53 noro 966: void get_quote_id_arg(QUOTE f,int *id,NODE *r)
967: {
968: LIST fa;
969: NODE arg,fab;
970:
971: arg = mknode(1,f); Pquote_to_funargs(arg,&fa); fab = BDY((LIST)fa);
972: *id = QTOS((Q)BDY(fab)); *r = NEXT(fab);
973: }
974:
1.56 noro 975: /* *rp : [[quote(A),quote(1)],...] */
1.53 noro 976:
1.105 noro 977: int qt_match(Obj f, Obj pat, NODE *rp)
1.53 noro 978: {
979: NODE tf,tp,head,body;
980: NODE parg,farg,r;
1.66 noro 981: Obj rpat;
1.53 noro 982: LIST fa,l;
983: int pid,id;
1.55 noro 984: FUNC ff,pf;
1.56 noro 985: int ret;
1.64 noro 986: QUOTE q;
987: FNODE g;
1.53 noro 988:
1.67 noro 989: if ( !f )
990: if ( !pat ) {
991: *rp = 0; return 1;
992: } else
993: return 0;
994: else if ( OID(pat) == O_LIST ) {
1.53 noro 995: if ( OID(f) == O_LIST )
1.105 noro 996: return qt_match_node(BDY((LIST)f),BDY((LIST)pat),rp);
1.53 noro 997: else
998: return 0;
999: } else if ( OID(pat) == O_QUOTE ) {
1.67 noro 1000: pid = ((FNODE)BDY((QUOTE)pat))->id;
1.53 noro 1001: switch ( pid ) {
1.55 noro 1002: case I_FORMULA:
1003: if ( compquote(CO,f,pat) )
1004: return 0;
1005: else {
1.67 noro 1006: *rp = 0; return 1;
1.55 noro 1007: }
1008: break;
1.67 noro 1009:
1010: case I_LIST: case I_CONS:
1011: get_quote_id_arg((QUOTE)pat,&pid,&parg);
1012: if ( OID(f) == O_LIST )
1013: tf = BDY((LIST)f);
1014: else if ( OID(f) == O_QUOTE
1015: && ((FNODE)BDY((QUOTE)f))->id == pid ) {
1016: get_quote_id_arg((QUOTE)f,&id,&farg);
1017: tf = BDY((LIST)BDY(farg));
1018: } else
1019: return 0;
1020:
1.66 noro 1021: tp = BDY((LIST)BDY(parg));
1.67 noro 1022: if ( pid == I_LIST )
1.105 noro 1023: return qt_match_node(tf,tp,rp);
1.67 noro 1024: else {
1025: rpat = (Obj)BDY(NEXT(parg));
1.105 noro 1026: return qt_match_cons(tf,tp,rpat,rp);
1.67 noro 1027: }
1028:
1.53 noro 1029: case I_PVAR:
1030: /* [[pat,f]] */
1031: r = mknode(2,pat,f); MKLIST(l,r);
1.56 noro 1032: *rp = mknode(1,l);
1033: return 1;
1.67 noro 1034:
1.53 noro 1035: case I_IFUNC:
1036: /* F(X,Y,...) = ... */
1.67 noro 1037: get_quote_id_arg((QUOTE)f,&id,&farg);
1038: get_quote_id_arg((QUOTE)pat,&pid,&parg);
1.53 noro 1039: if ( id == I_FUNC ) {
1.54 noro 1040: r = mknode(2,BDY(parg),BDY(farg)); MKLIST(l,r);
1041: head = mknode(1,l);
1.105 noro 1042: ret = qt_match(BDY(NEXT(farg)),
1.56 noro 1043: BDY(NEXT(parg)),&body);
1044: if ( !ret ) return 0;
1045: else return merge_matching_node(head,body,rp);
1.53 noro 1046: } else
1047: return 0;
1.64 noro 1048:
1.67 noro 1049: case I_NARYOP: case I_BOP: case I_FUNC:
1.64 noro 1050: /* X+Y = ... */
1.67 noro 1051: /* f(...) = ... */
1052: if ( OID(f) != O_QUOTE ) return 0;
1053: id = ((FNODE)BDY((QUOTE)f))->id;
1054: if ( pid == I_FUNC )
1055: ;
1056: else {
1057: /* XXX converting to I_BOP */
1058: if ( pid == I_NARYOP ) {
1.70 noro 1059: g = fnode_to_bin(BDY((QUOTE)pat),1);
1.67 noro 1060: MKQUOTE(q,g); pat = (Obj)q;
1061: }
1062: if ( id == I_NARYOP ) {
1.70 noro 1063: g = fnode_to_bin(BDY((QUOTE)f),1);
1.67 noro 1064: MKQUOTE(q,g); f = (Obj)q;
1065: }
1066: }
1067: get_quote_id_arg((QUOTE)pat,&pid,&parg);
1068: get_quote_id_arg((QUOTE)f,&id,&farg);
1.64 noro 1069: if ( compqa(CO,BDY(farg),BDY(parg)) ) return 0;
1.105 noro 1070: return qt_match_node(NEXT(farg),NEXT(parg),rp);
1.64 noro 1071:
1.53 noro 1072: default:
1.67 noro 1073: if ( OID(f) != O_QUOTE ) return 0;
1074: id = ((FNODE)BDY((QUOTE)f))->id;
1075: if ( id != pid ) return 0;
1076: get_quote_id_arg((QUOTE)pat,&pid,&parg);
1077: get_quote_id_arg((QUOTE)f,&id,&farg);
1.105 noro 1078: return qt_match_node(farg,parg,rp);
1.53 noro 1079: }
1080: }
1.13 noro 1081: }
1082:
1.14 noro 1083: void Pquotetotex(NODE arg,STRING *rp)
1.13 noro 1084: {
1.14 noro 1085: TB tb;
1.13 noro 1086:
1.14 noro 1087: NEWTB(tb);
1.27 noro 1088: /* XXX for DP */
1089: is_lt = 1;
1.14 noro 1090: fnodetotex_tb(BDY((QUOTE)ARG0(arg)),tb);
1091: tb_to_string(tb,rp);
1.13 noro 1092: }
1093:
1.14 noro 1094: void Pquotetotex_tb(NODE arg,Q *rp)
1.13 noro 1095: {
1096: int i;
1.14 noro 1097: TB tb;
1.13 noro 1098:
1.14 noro 1099: asir_assert(ARG1(arg),O_TB,"quotetotex_tb");
1.27 noro 1100: /* XXX for DP */
1101: is_lt = 1;
1.14 noro 1102: fnodetotex_tb(BDY((QUOTE)ARG0(arg)),ARG1(arg));
1.13 noro 1103: *rp = 0;
1104: }
1105:
1.14 noro 1106: void Pstring_to_tb(NODE arg,TB *rp)
1107: {
1108: TB tb;
1109:
1110: asir_assert(ARG0(arg),O_STR,"string_to_tb");
1111: NEWTB(tb);
1112: tb->body[0] = BDY((STRING)ARG0(arg));
1113: tb->next++;
1114: *rp = tb;
1115: }
1116:
1117: void Ptb_to_string(NODE arg,STRING *rp)
1118: {
1119: TB tb;
1120:
1121: asir_assert(ARG0(arg),O_TB,"tb_to_string");
1122: tb = (TB)ARG0(arg);
1123: tb_to_string(tb,rp);
1124: }
1125:
1126: void tb_to_string(TB tb,STRING *rp)
1.13 noro 1127: {
1.14 noro 1128: int j,len;
1.13 noro 1129: char *all,*p,*q;
1130:
1.14 noro 1131: for ( j = 0, len = 0; j < tb->next; j++ )
1132: len += strlen(tb->body[j]);
1133: all = (char *)MALLOC_ATOMIC((len+1)*sizeof(char));
1134: for ( j = 0, p = all; j < tb->next; j++ )
1135: for ( q = tb->body[j]; *q; *p++ = *q++ );
1136: *p = 0;
1137: MKSTR(*rp,all);
1138: }
1139:
1140: void Pclear_tb(NODE arg,Q *rp)
1141: {
1142: TB tb;
1143: int j;
1144:
1145: asir_assert(ARG0(arg),O_TB,"clear_tb");
1146: tb = (TB)ARG0(arg);
1147: for ( j = 0; j < tb->next; j++ )
1148: tb->body[j] = 0;
1149: tb->next = 0;
1150: *rp = 0;
1.13 noro 1151: }
1.5 noro 1152:
1153: void Pstr_len(arg,rp)
1154: NODE arg;
1155: Q *rp;
1156: {
1.16 noro 1157: Obj obj;
1158: TB tb;
1159: int r,i;
1.5 noro 1160:
1.16 noro 1161: obj = (Obj)ARG0(arg);
1162: if ( !obj || (OID(obj) != O_STR && OID(obj) != O_TB) )
1163: error("str_len : invalid argument");
1164: if ( OID(obj) == O_STR)
1165: r = strlen(BDY((STRING)obj));
1166: else if ( OID(obj) == O_TB ) {
1167: tb = (TB)obj;
1168: for ( r = i = 0; i < tb->next; i++ )
1169: r += strlen(tb->body[i]);
1170: }
1.5 noro 1171: STOQ(r,*rp);
1172: }
1173:
1174: void Pstr_chr(arg,rp)
1175: NODE arg;
1176: Q *rp;
1177: {
1178: STRING str,terminator;
1179: Q start;
1180: char *p,*ind;
1181: int chr,spos,r;
1182:
1183: str = (STRING)ARG0(arg);
1184: start = (Q)ARG1(arg);
1185: terminator = (STRING)ARG2(arg);
1186: asir_assert(str,O_STR,"str_chr");
1187: asir_assert(start,O_N,"str_chr");
1188: asir_assert(terminator,O_STR,"str_chr");
1189: p = BDY(str);
1190: spos = QTOS(start);
1191: chr = BDY(terminator)[0];
1.8 noro 1192: if ( spos > (int)strlen(p) )
1.5 noro 1193: r = -1;
1194: else {
1195: ind = strchr(p+spos,chr);
1196: if ( ind )
1197: r = ind-p;
1198: else
1199: r = -1;
1200: }
1201: STOQ(r,*rp);
1202: }
1203:
1204: void Psub_str(arg,rp)
1205: NODE arg;
1206: STRING *rp;
1207: {
1208: STRING str;
1209: Q head,tail;
1210: char *p,*r;
1211: int spos,epos,len;
1212:
1213: str = (STRING)ARG0(arg);
1214: head = (Q)ARG1(arg);
1215: tail = (Q)ARG2(arg);
1216: asir_assert(str,O_STR,"sub_str");
1217: asir_assert(head,O_N,"sub_str");
1218: asir_assert(tail,O_N,"sub_str");
1219: p = BDY(str);
1220: spos = QTOS(head);
1221: epos = QTOS(tail);
1222: len = strlen(p);
1223: if ( (spos >= len) || (epos < spos) ) {
1224: *rp = 0; return;
1225: }
1226: if ( epos >= len )
1227: epos = len-1;
1228: len = epos-spos+1;
1229: r = (char *)MALLOC(len+1);
1230: strncpy(r,p+spos,len);
1231: r[len] = 0;
1232: MKSTR(*rp,r);
1233: }
1.3 noro 1234:
1235: void Pstrtoascii(arg,rp)
1236: NODE arg;
1237: LIST *rp;
1238: {
1239: STRING str;
1240: unsigned char *p;
1241: int len,i;
1242: NODE n,n1;
1243: Q q;
1244:
1245: str = (STRING)ARG0(arg);
1246: asir_assert(str,O_STR,"strtoascii");
1247: p = BDY(str);
1248: len = strlen(p);
1249: for ( i = len-1, n = 0; i >= 0; i-- ) {
1250: UTOQ((unsigned int)p[i],q);
1251: MKNODE(n1,q,n);
1252: n = n1;
1253: }
1254: MKLIST(*rp,n);
1255: }
1256:
1257: void Pasciitostr(arg,rp)
1258: NODE arg;
1259: STRING *rp;
1260: {
1261: LIST list;
1262: unsigned char *p;
1263: int len,i,j;
1264: NODE n;
1265: Q q;
1266:
1267: list = (LIST)ARG0(arg);
1268: asir_assert(list,O_LIST,"asciitostr");
1269: n = BDY(list);
1270: len = length(n);
1271: p = MALLOC_ATOMIC(len+1);
1272: for ( i = 0; i < len; i++, n = NEXT(n) ) {
1273: q = (Q)BDY(n);
1274: asir_assert(q,O_N,"asciitostr");
1275: j = QTOS(q);
1.4 noro 1276: if ( j >= 256 || j <= 0 )
1.3 noro 1277: error("asciitostr : argument out of range");
1278: p[i] = j;
1279: }
1280: p[i] = 0;
1281: MKSTR(*rp,(char *)p);
1282: }
1.1 noro 1283:
1284: void Peval_str(arg,rp)
1285: NODE arg;
1286: Obj *rp;
1287: {
1288: FNODE fnode;
1289: char *cmd;
1.10 ohara 1290: #if defined(PARI)
1.8 noro 1291: void recover(int);
1292:
1.1 noro 1293: recover(0);
1.11 saito 1294: # if !(PARI_VERSION_CODE > 131588)
1.1 noro 1295: if ( setjmp(environnement) ) {
1296: avma = top; recover(1);
1297: resetenv("");
1298: }
1.11 saito 1299: # endif
1.1 noro 1300: #endif
1301: cmd = BDY((STRING)ARG0(arg));
1.9 noro 1302: exprparse_create_var(0,cmd,&fnode);
1.1 noro 1303: *rp = eval(fnode);
1304: }
1305:
1306: void Prtostr(arg,rp)
1307: NODE arg;
1308: STRING *rp;
1309: {
1310: char *b;
1311: int len;
1312:
1.2 noro 1313: len = estimate_length(CO,ARG0(arg));
1.12 noro 1314: b = (char *)MALLOC_ATOMIC(len+1);
1.1 noro 1315: soutput_init(b);
1316: sprintexpr(CO,ARG0(arg));
1317: MKSTR(*rp,b);
1318: }
1319:
1320: void Pstrtov(arg,rp)
1321: NODE arg;
1322: P *rp;
1323: {
1.8 noro 1324: char *p;
1.1 noro 1325:
1326: p = BDY((STRING)ARG0(arg));
1327: #if 0
1328: if ( !islower(*p) )
1329: *rp = 0;
1330: else {
1331: for ( t = p+1; t && (isalnum(*t) || *t == '_'); t++ );
1332: if ( *t )
1333: *rp = 0;
1334: else
1335: makevar(p,rp);
1336: }
1337: #else
1338: makevar(p,rp);
1339: #endif
1.14 noro 1340: }
1341:
1.15 noro 1342: static struct TeXSymbol texsymbol[] = {
1343: {"sin","\\sin"},
1344: {"cos","\\cos"},
1345: {"tan","\\tan"},
1346: {"sinh","\\sinh"},
1347: {"cosh","\\cosh"},
1348: {"tanh","\\tanh"},
1349: {"exp","\\exp"},
1350: {"log","\\log"},
1351:
1352: /* Greek Letters (lower case) */
1353: {"alpha","\\alpha"},
1354: {"beta","\\beta"},
1355: {"gamma","\\gamma"},
1356: {"delta","\\delta"},
1357: {"epsilon","\\epsilon"},
1358: {"varepsilon","\\varepsilon"},
1359: {"zeta","\\zeta"},
1360: {"eta","\\eta"},
1361: {"theta","\\theta"},
1362: {"vartheta","\\vartheta"},
1363: {"iota","\\iota"},
1364: {"kappa","\\kappa"},
1365: {"lambda","\\lambda"},
1366: {"mu","\\mu"},
1367: {"nu","\\nu"},
1368: {"xi","\\xi"},
1369: {"pi","\\pi"},
1370: {"varpi","\\varpi"},
1371: {"rho","\\rho"},
1372: {"sigma","\\sigma"},
1373: {"varsigma","\\varsigma"},
1374: {"tau","\\tau"},
1375: {"upsilon","\\upsilon"},
1376: {"phi","\\phi"},
1377: {"varphi","\\varphi"},
1378: {"chi","\\chi"},
1379: {"omega","\\omega"},
1380:
1381: /* Greek Letters, (upper case) */
1382: {"ggamma","\\Gamma"},
1383: {"ddelta","\\Delta"},
1384: {"ttheta","\\Theta"},
1385: {"llambda","\\Lambda"},
1386: {"xxi","\\Xi"},
1387: {"ppi","\\Pi"},
1388: {"ssigma","\\Sigma"},
1389: {"uupsilon","\\Upsilon"},
1390: {"pphi","\\Phi"},
1391: {"ppsi","\\Psi"},
1392: {"oomega","\\Omega"},
1393:
1394: /* Our own mathematical functions */
1395: {"algebra_tensor","\\otimes"},
1396: {"base_where","{\\rm \\ where \\ }"},
1397: /* Mathematical constants */
1398: {"c_pi","\\pi"},
1399: {"c_i","\\sqrt{-1}"},
1400:
1401: /* Temporary */
1402: {0,0}
1403: };
1404:
1.14 noro 1405: char *symbol_name(char *name)
1406: {
1.15 noro 1407: int i;
1408:
1.41 noro 1409: if ( !name || strlen(name) == 0 )
1410: return "";
1.38 noro 1411: if ( !(conv_flag & CONV_TABLE) )
1412: return name;
1413:
1.18 noro 1414: if ( user_texsymbol )
1415: for ( i = 0; user_texsymbol[i].text; i++ )
1416: if ( !strcmp(user_texsymbol[i].text,name) )
1417: return user_texsymbol[i].symbol;
1.15 noro 1418: for ( i = 0; texsymbol[i].text; i++ )
1419: if ( !strcmp(texsymbol[i].text,name) )
1420: return texsymbol[i].symbol;
1.41 noro 1421: return 0;
1.52 noro 1422: }
1423:
1424: void Pget_function_name(NODE arg,STRING *rp)
1425: {
1426: QUOTEARG qa;
1427: ARF f;
1428: char *opname;
1429:
1430: qa = (QUOTEARG)BDY(arg);
1431: if ( !qa || OID(qa) != O_QUOTEARG || qa->type != A_arf )
1432: *rp = 0;
1433: else {
1434: f = (ARF)BDY(qa);
1435: opname = f->name;
1436: MKSTR(*rp,opname);
1437: }
1.14 noro 1438: }
1439:
1.51 noro 1440: FNODE strip_paren(FNODE);
1.111 noro 1441: void objtotex_tb(Obj obj,TB tb);
1.51 noro 1442:
1.14 noro 1443: void fnodetotex_tb(FNODE f,TB tb)
1444: {
1.91 noro 1445: NODE n,t,t0,args;
1.38 noro 1446: char vname[BUFSIZ],prefix[BUFSIZ];
1447: char *opname,*vname_conv,*prefix_conv;
1.14 noro 1448: Obj obj;
1.46 noro 1449: int i,len,allzero,elen,elen2,si;
1.40 noro 1450: char *r;
1.91 noro 1451: FNODE fi,f2,f1;
1.14 noro 1452:
1453: write_tb(" ",tb);
1454: if ( !f ) {
1455: write_tb("0",tb);
1456: return;
1457: }
1458: switch ( f->id ) {
1459: /* unary operators */
1.23 noro 1460: case I_NOT:
1461: write_tb("\\neg (",tb);
1462: fnodetotex_tb((FNODE)FA0(f),tb);
1463: write_tb(")",tb);
1464: break;
1465: case I_PAREN:
1466: write_tb("(",tb);
1467: fnodetotex_tb((FNODE)FA0(f),tb);
1468: write_tb(")",tb);
1469: break;
1470: case I_MINUS:
1471: write_tb("-",tb);
1472: fnodetotex_tb((FNODE)FA0(f),tb);
1473: break;
1474:
1475: /* binary operators */
1476: /* arg list */
1477: /* I_AND, I_OR => FA0(f), FA1(f) */
1478: /* otherwise => FA1(f), FA2(f) */
1479: case I_BOP:
1480: opname = ((ARF)FA0(f))->name;
1.70 noro 1481: switch ( opname[0] ) {
1482: case '+':
1483: fnodetotex_tb((FNODE)FA1(f),tb);
1484: if ( !top_is_minus((FNODE)FA2(f)) ) write_tb(opname,tb);
1485: fnodetotex_tb((FNODE)FA2(f),tb);
1486: break;
1487: case '-':
1488: if ( FA1(f) ) fnodetotex_tb((FNODE)FA1(f),tb);
1489: write_tb(opname,tb);
1490: fnodetotex_tb((FNODE)FA2(f),tb);
1491: break;
1492: case '*':
1493: fnodetotex_tb((FNODE)FA1(f),tb);
1494: write_tb(" ",tb);
1495: /* XXX special care for DP */
1496: f2 = (FNODE)FA2(f);
1497: if ( f2->id == I_EV ) {
1498: n = (NODE)FA0(f2);
1499: for ( i = 0; n; n = NEXT(n), i++ ) {
1500: fi = (FNODE)BDY(n);
1501: if ( fi->id != I_FORMULA || FA0(fi) )
1502: break;
1503: }
1504: if ( n )
1505: fnodetotex_tb((FNODE)FA2(f),tb);
1506: } else
1.23 noro 1507: fnodetotex_tb((FNODE)FA2(f),tb);
1.70 noro 1508: break;
1509: case '/':
1510: write_tb("\\frac{",tb);
1511: fnodetotex_tb((FNODE)FA1(f),tb);
1512: write_tb("} {",tb);
1513: fnodetotex_tb((FNODE)FA2(f),tb);
1514: write_tb("}",tb);
1515: break;
1516: case '^':
1.111 noro 1517: f1 = (FNODE)FA1(f);
1518: if ( fnode_is_var(f1) )
1519: fnodetotex_tb(f1,tb);
1520: else {
1521: write_tb("(",tb);
1522: fnodetotex_tb(f1,tb);
1523: write_tb(")",tb);
1524: }
1.70 noro 1525: write_tb("^{",tb);
1526: fnodetotex_tb(strip_paren((FNODE)FA2(f)),tb);
1527: write_tb("} ",tb);
1528: break;
1529: case '%':
1530: fnodetotex_tb((FNODE)FA1(f),tb);
1531: write_tb(" {\\rm mod}\\, ",tb);
1.23 noro 1532: fnodetotex_tb((FNODE)FA2(f),tb);
1.70 noro 1533: break;
1534: default:
1535: error("invalid binary operator");
1536: break;
1537: }
1.23 noro 1538: break;
1.91 noro 1539: case I_NARYOP:
1540: args = (NODE)FA1(f);
1541: switch ( OPNAME(f) ) {
1542: case '+':
1543: fnodetotex_tb((FNODE)BDY(args),tb);
1544: for ( args = NEXT(args); args; args = NEXT(args) ) {
1545: write_tb("+",tb);
1.111 noro 1546: f1 = (FNODE)BDY(args);
1.114 noro 1547: /* if ( fnode_is_var(f1) || IS_MUL(f1) )
1.111 noro 1548: fnodetotex_tb(f1,tb);
1.114 noro 1549: else */ {
1.111 noro 1550: write_tb("(",tb);
1551: fnodetotex_tb(f1,tb);
1552: write_tb(")",tb);
1553: }
1.91 noro 1554: }
1555: break;
1556: case '*':
1557: f1 = (FNODE)BDY(args);
1.111 noro 1558: if ( f1->id == I_FORMULA && MUNIQ(FA0(f1)) ) {
1559: write_tb("- ",tb); args = NEXT(args);
1560: }
1561: for ( ; args; args = NEXT(args) ) {
1.91 noro 1562: f2 = (FNODE)BDY(args);
1.111 noro 1563: if ( fnode_is_var(f2) || IS_BINARYPWR(f2) )
1564: fnodetotex_tb(f2,tb);
1565: else {
1566: write_tb("(",tb);
1.91 noro 1567: fnodetotex_tb(f2,tb);
1.111 noro 1568: write_tb(")",tb);
1569: }
1.91 noro 1570: }
1571: break;
1572: default:
1573: error("invalid nary op");
1574: break;
1575: }
1576: break;
1.23 noro 1577:
1578: case I_COP:
1579: switch( (cid)FA0(f) ) {
1580: case C_EQ:
1581: fnodetotex_tb((FNODE)FA1(f),tb);
1582: write_tb(" = ",tb);
1583: fnodetotex_tb((FNODE)FA2(f),tb);
1584: break;
1585: case C_NE:
1586: fnodetotex_tb((FNODE)FA1(f),tb);
1587: write_tb(" \\neq ",tb);
1588: fnodetotex_tb((FNODE)FA2(f),tb);
1589: break;
1590: case C_GT:
1591: fnodetotex_tb((FNODE)FA1(f),tb);
1.45 noro 1592: write_tb(" > ",tb);
1.23 noro 1593: fnodetotex_tb((FNODE)FA2(f),tb);
1594: break;
1595: case C_LT:
1596: fnodetotex_tb((FNODE)FA1(f),tb);
1.45 noro 1597: write_tb(" < ",tb);
1.23 noro 1598: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1599: break;
1.23 noro 1600: case C_GE:
1601: fnodetotex_tb((FNODE)FA1(f),tb);
1602: write_tb(" \\geq ",tb);
1603: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1604: break;
1.23 noro 1605: case C_LE:
1606: fnodetotex_tb((FNODE)FA1(f),tb);
1607: write_tb(" \\leq ",tb);
1608: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1609: break;
1610: }
1611: break;
1612:
1.23 noro 1613: case I_LOP:
1614: switch( (lid)FA0(f) ) {
1615: case L_EQ:
1616: fnodetotex_tb((FNODE)FA1(f),tb);
1617: write_tb(" = ",tb);
1618: fnodetotex_tb((FNODE)FA2(f),tb);
1619: break;
1620: case L_NE:
1621: fnodetotex_tb((FNODE)FA1(f),tb);
1622: write_tb(" \\neq ",tb);
1623: fnodetotex_tb((FNODE)FA2(f),tb);
1624: break;
1625: case L_GT:
1626: fnodetotex_tb((FNODE)FA1(f),tb);
1.45 noro 1627: write_tb(" > ",tb);
1.23 noro 1628: fnodetotex_tb((FNODE)FA2(f),tb);
1629: break;
1630: case L_LT:
1631: fnodetotex_tb((FNODE)FA1(f),tb);
1.45 noro 1632: write_tb(" < ",tb);
1.23 noro 1633: fnodetotex_tb((FNODE)FA2(f),tb);
1634: break;
1635: case L_GE:
1636: fnodetotex_tb((FNODE)FA1(f),tb);
1637: write_tb(" \\geq ",tb);
1638: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1639: break;
1.23 noro 1640: case L_LE:
1641: fnodetotex_tb((FNODE)FA1(f),tb);
1642: write_tb(" \\leq ",tb);
1643: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1644: break;
1.23 noro 1645: case L_AND:
1646: fnodetotex_tb((FNODE)FA1(f),tb);
1.14 noro 1647: write_tb(" {\\rm \\ and\\ } ",tb);
1.23 noro 1648: fnodetotex_tb((FNODE)FA2(f),tb);
1649: break;
1650: case L_OR:
1.14 noro 1651: fnodetotex_tb((FNODE)FA1(f),tb);
1.23 noro 1652: write_tb(" {\\rm \\ or\\ } ",tb);
1653: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 1654: break;
1.23 noro 1655: case L_NOT:
1656: /* XXX : L_NOT is a unary operator */
1657: write_tb("\\neg (",tb);
1.14 noro 1658: fnodetotex_tb((FNODE)FA1(f),tb);
1.23 noro 1659: write_tb(")",tb);
1660: return;
1.14 noro 1661: }
1662: break;
1663:
1.23 noro 1664: case I_AND:
1665: fnodetotex_tb((FNODE)FA0(f),tb);
1666: write_tb(" {\\rm \\ and\\ } ",tb);
1667: fnodetotex_tb((FNODE)FA1(f),tb);
1668: break;
1669:
1670: case I_OR:
1671: fnodetotex_tb((FNODE)FA0(f),tb);
1672: write_tb(" {\\rm \\ or\\ } ",tb);
1673: fnodetotex_tb((FNODE)FA1(f),tb);
1674: break;
1675:
1.14 noro 1676: /* ternary operators */
1677: case I_CE:
1678: error("fnodetotex_tb : not implemented yet");
1679: break;
1680:
1681: /* lists */
1682: case I_LIST:
1683: write_tb(" [ ",tb);
1684: n = (NODE)FA0(f);
1685: fnodenodetotex_tb(n,tb);
1686: write_tb("]",tb);
1687: break;
1688:
1689: /* function */
1.23 noro 1690: case I_FUNC:
1.40 noro 1691: if ( !strcmp(((FUNC)FA0(f))->name,"@pi") )
1692: write_tb("\\pi",tb);
1693: else if ( !strcmp(((FUNC)FA0(f))->name,"@e") )
1694: write_tb("e",tb);
1695: else {
1696: opname = conv_rule(((FUNC)FA0(f))->name);
1697: write_tb(opname,tb);
1698: write_tb("(",tb);
1699: fargstotex_tb(opname,FA1(f),tb);
1700: write_tb(")",tb);
1701: }
1.23 noro 1702: break;
1703:
1704: /* XXX */
1705: case I_CAR:
1.28 noro 1706: opname = conv_rule("car");
1.23 noro 1707: write_tb(opname,tb);
1708: write_tb("(",tb);
1709: fargstotex_tb(opname,FA0(f),tb);
1710: write_tb(")",tb);
1711: break;
1712:
1713: case I_CDR:
1.28 noro 1714: opname = conv_rule("cdr");
1.23 noro 1715: write_tb(opname,tb);
1716: write_tb("(",tb);
1717: fargstotex_tb(opname,FA0(f),tb);
1718: write_tb(")",tb);
1719: break;
1720:
1721: /* exponent vector */
1722: case I_EV:
1723: n = (NODE)FA0(f);
1.31 noro 1724: if ( dp_vars_hweyl ) {
1725: elen = length(n);
1726: elen2 = elen>>1;
1727: elen = elen2<<1;
1728: }
1.23 noro 1729: allzero = 1;
1.27 noro 1730: if ( show_lt && is_lt )
1731: write_tb("\\underline{",tb);
1.23 noro 1732: for ( t0 = 0, i = 0; n; n = NEXT(n), i++ ) {
1733: fi = (FNODE)BDY(n);
1734: if ( fi->id == I_FORMULA && !FA0(fi) ) continue;
1735: allzero = 0;
1.38 noro 1736: if ( dp_vars && i < dp_vars_len ) {
1737: strcpy(vname,dp_vars[i]);
1738: vname_conv = conv_rule(vname);
1739: } else {
1740: if ( dp_vars_hweyl ) {
1.44 noro 1741: if ( i < elen2 ) {
1.38 noro 1742: strcpy(prefix,dp_vars_prefix?dp_vars_prefix:"x");
1.44 noro 1743: prefix_conv = conv_rule(prefix);
1744: vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46 noro 1745: si = i+dp_vars_origin;
1746: sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
1747: prefix_conv,si);
1.44 noro 1748: } else if ( i < elen ) {
1.46 noro 1749: strcpy(prefix,
1750: dp_dvars_prefix?dp_dvars_prefix:"\\partial");
1.44 noro 1751: prefix_conv = conv_rule(prefix);
1752: vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46 noro 1753: si = i+dp_dvars_origin-elen2;
1754: sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
1755: prefix_conv,si);
1.44 noro 1756: } else {
1.38 noro 1757: strcpy(prefix,"h");
1.44 noro 1758: vname_conv = conv_rule(prefix);
1759: }
1760: } else {
1.38 noro 1761: strcpy(prefix,dp_vars_prefix?dp_vars_prefix:"x");
1.44 noro 1762: prefix_conv = conv_rule(prefix);
1763: vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1.46 noro 1764: si = i+dp_vars_origin;
1765: sprintf(vname_conv,(si>=0&&si<10)?"%s_%d":"%s_{%d}",
1766: prefix_conv,si);
1.44 noro 1767: }
1.38 noro 1768: }
1.23 noro 1769: if ( fi->id == I_FORMULA && UNIQ(FA0(fi)) ) {
1770: len = strlen(vname_conv);
1771: opname = MALLOC_ATOMIC(len+2);
1772: sprintf(opname,"%s ",vname_conv);
1.14 noro 1773: write_tb(opname,tb);
1.23 noro 1774: } else {
1775: len = strlen(vname_conv);
1776: /* 2: ^{ */
1777: opname = MALLOC_ATOMIC(len+1+2);
1778: sprintf(opname,"%s^{",vname_conv);
1.14 noro 1779: write_tb(opname,tb);
1.23 noro 1780: fnodetotex_tb((FNODE)BDY(n),tb);
1781: write_tb("} ",tb);
1782: }
1.14 noro 1783: }
1.23 noro 1784: /* XXX */
1785: if ( allzero )
1786: write_tb(" 1 ",tb);
1.27 noro 1787: if ( show_lt && is_lt ) {
1788: write_tb("}",tb);
1789: is_lt = 0;
1790: }
1.14 noro 1791: break;
1792:
1.23 noro 1793: /* string */
1.14 noro 1794: case I_STR:
1795: write_tb((char *)FA0(f),tb);
1796: break;
1797:
1.23 noro 1798: /* internal object */
1.14 noro 1799: case I_FORMULA:
1.111 noro 1800: objtotex_tb((Obj)FA0(f),tb);
1.14 noro 1801: break;
1802:
1.23 noro 1803: /* program variable */
1.14 noro 1804: case I_PVAR:
1805: if ( FA1(f) )
1806: error("fnodetotex_tb : not implemented yet");
1807: GETPVNAME(FA0(f),opname);
1808: write_tb(opname,tb);
1809: break;
1810:
1811: default:
1812: error("fnodetotex_tb : not implemented yet");
1813: }
1.40 noro 1814: }
1815:
1.111 noro 1816: void objtotex_tb(Obj obj,TB tb)
1817: {
1818: C cplx;
1819: char *r;
1820: P t;
1821: DCP dc;
1822: char *v;
1823:
1824: if ( !obj ) {
1825: write_tb("0",tb);
1826: return;
1827: }
1828: switch ( OID(obj) ) {
1829: case O_N:
1830: switch ( NID(obj) ) {
1831: case N_C:
1832: cplx = (C)obj;
1833: write_tb("(",tb);
1834: if ( cplx->r ) {
1835: r = objtostr((Obj)cplx->r); write_tb(r,tb);
1836: }
1837: if ( cplx->i ) {
1838: if ( cplx->r && compnum(0,cplx->i,0) > 0 ) {
1839: write_tb("+",tb);
1840: if ( !UNIQ(cplx->i) ) {
1841: r = objtostr((Obj)cplx->i); write_tb(r,tb);
1842: }
1843: } else if ( MUNIQ(cplx->i) )
1844: write_tb("-",tb);
1845: else if ( !UNIQ(cplx->i) ) {
1846: r = objtostr((Obj)cplx->i); write_tb(r,tb);
1847: }
1848: write_tb("\\sqrt{-1}",tb);
1849: }
1850: write_tb(")",tb);
1851: break;
1852: default:
1853: write_tb(objtostr(obj),tb);
1854: break;
1855: }
1856: break;
1857: case O_P:
1858: v = conv_rule(VR((P)obj)->name);
1859: for ( dc = DC((P)obj); dc; dc = NEXT(dc) ) {
1860: if ( !DEG(dc) )
1861: objtotex_tb((Obj)COEF(dc),tb);
1862: else {
1863: if ( NUM(COEF(dc)) && UNIQ((Q)COEF(dc)) )
1864: ;
1865: else if ( NUM(COEF(dc)) && MUNIQ((Q)COEF(dc)) )
1866: write_tb("-",tb);
1867: else if ( NUM(COEF(dc)) || !NEXT(DC(COEF(dc))))
1868: objtotex_tb((Obj)COEF(dc),tb);
1869: else {
1870: write_tb("(",tb); objtotex_tb((Obj)COEF(dc),tb);
1871: write_tb(")",tb);
1872: }
1873: write_tb(v,tb);
1874: if ( cmpq(DEG(dc),ONE) ) {
1875: write_tb("^",tb);
1876: if ( INT(DEG(dc)) && SGN(DEG(dc))>0 ) {
1877: write_tb("{",tb);
1878: objtotex_tb((Obj)DEG(dc),tb);
1879: write_tb("}",tb);
1880: } else {
1881: write_tb("{",tb); objtotex_tb((Obj)DEG(dc),tb);
1882: write_tb("}",tb);
1883: }
1884: }
1885: }
1886: if ( NEXT(dc) ) {
1887: t = COEF(NEXT(dc));
1888: if ( !DEG(NEXT(dc)) ) {
1889: if ( NUM(t) ) {
1890: if ( !mmono(t) ) write_tb("+",tb);
1891: } else {
1892: if ( !mmono(COEF(DC(t))) ) write_tb("+",tb);
1893: }
1894: } else {
1895: if ( !mmono(t) ) write_tb("+",tb);
1896: }
1897: }
1898: }
1899: break;
1900: case O_R:
1901: write_tb("\\frac{",tb);
1902: objtotex_tb((Obj)NM((R)obj),tb);
1903: write_tb("}{",tb);
1904: objtotex_tb((Obj)DN((R)obj),tb);
1905: write_tb("}",tb);
1906: break;
1907: default:
1908: write_tb(objtostr(obj),tb);
1909: break;
1910: }
1911: }
1912:
1.40 noro 1913: char *objtostr(Obj obj)
1914: {
1915: int len;
1916: char *r;
1917:
1918: len = estimate_length(CO,obj);
1919: r = (char *)MALLOC_ATOMIC(len+1);
1920: soutput_init(r);
1921: sprintexpr(CO,obj);
1922: return r;
1.50 ohara 1923: }
1924:
1925: void Psprintf(NODE arg,STRING *rp)
1926: {
1927: STRING string;
1928: char *s,*t,*r;
1929: int argc,n,len;
1930: NODE node;
1931:
1932: string = (STRING)ARG0(arg);
1933: asir_assert(string,O_STR,"sprintf");
1934: s = BDY(string);
1935: for(n = 0, t = s; *t; t++) {
1936: if (*t=='%' && *(t+1)=='a') {
1937: n++;
1938: }
1939: }
1940: for(node = NEXT(arg), argc = 0, len = strlen(s); node; node = NEXT(node), argc++) {
1941: len += estimate_length(CO,BDY(node));
1942: }
1943: if (argc < n) {
1944: error("sprintf: invalid argument");
1945: }
1946: r = (char *)MALLOC_ATOMIC(len);
1947: for(node = NEXT(arg), t = r; *s; s++) {
1948: if (*s=='%' && *(s+1)=='a') {
1949: strcpy(t,objtostr(BDY(node)));
1950: node = NEXT(node);
1951: t = strchr(t,0);
1952: s++;
1953: }else {
1954: *t++ = *s;
1955: }
1956: }
1957: *t = 0;
1958: MKSTR(*rp,r);
1.14 noro 1959: }
1960:
1961: void fnodenodetotex_tb(NODE n,TB tb)
1962: {
1963: for ( ; n; n = NEXT(n) ) {
1.27 noro 1964: is_lt = 1;
1.14 noro 1965: fnodetotex_tb((FNODE)BDY(n),tb);
1966: if ( NEXT(n) ) write_tb(", ",tb);
1967: }
1968: }
1969:
1970: void fargstotex_tb(char *name,FNODE f,TB tb)
1971: {
1972: NODE n;
1973:
1974: if ( !strcmp(name,"matrix") ) {
1975: error("fargstotex_tb : not implemented yet");
1976: } else if ( !strcmp(name,"vector") ) {
1977: error("fargstotex_tb : not implemented yet");
1978: } else {
1979: if ( f->id == I_LIST ) {
1980: n = (NODE)FA0(f);
1981: fnodenodetotex_tb(n,tb);
1982: } else
1983: fnodetotex_tb(f,tb);
1.35 noro 1984: }
1985: }
1986:
1987: int top_is_minus(FNODE f)
1988: {
1989: char *opname;
1990: int len;
1991: Obj obj;
1992:
1993: if ( !f )
1994: return 0;
1995: switch ( f->id ) {
1996: case I_MINUS:
1997: return 1;
1998: case I_BOP:
1999: opname = ((ARF)FA0(f))->name;
2000: switch ( opname[0] ) {
2001: case '+': case '*': case '/': case '^': case '%':
2002: return top_is_minus((FNODE)FA1(f));
2003: case '-':
2004: if ( FA1(f) )
2005: return top_is_minus((FNODE)FA1(f));
2006: else
2007: return 1;
2008: default:
2009: return 0;
2010: }
2011: break;
2012: case I_COP:
2013: return top_is_minus((FNODE)FA1(f));
2014: case I_LOP:
2015: if ( (lid)FA0(f) == L_NOT ) return 0;
2016: else return top_is_minus((FNODE)FA1(f));
2017: case I_AND: case I_OR:
2018: return top_is_minus((FNODE)FA0(f));
2019: case I_FORMULA:
2020: obj = (Obj)FA0(f);
1.36 noro 2021: if ( !obj )
2022: return 0;
2023: else {
2024: switch ( OID(obj) ) {
2025: case O_N:
2026: return mmono((P)obj);
2027: case O_P:
1.111 noro 2028: #if 0
1.36 noro 2029: /* must be a variable */
2030: opname = conv_rule(VR((P)obj)->name);
2031: return opname[0]=='-';
1.111 noro 2032: #else
2033: return mmono((P)obj);
2034: #endif
1.36 noro 2035: default:
2036: /* ??? */
2037: len = estimate_length(CO,obj);
2038: opname = (char *)MALLOC_ATOMIC(len+1);
2039: soutput_init(opname);
2040: sprintexpr(CO,obj);
2041: return opname[0]=='-';
2042: }
1.35 noro 2043: }
1.91 noro 2044: case I_NARYOP:
2045: return top_is_minus((FNODE)BDY((NODE)FA1(f)));
2046:
1.35 noro 2047: default:
2048: return 0;
1.14 noro 2049: }
1.47 noro 2050: }
2051:
2052: FNODE flatten_fnode(FNODE,char *);
2053:
1.48 noro 2054: void Pflatten_quote(NODE arg,Obj *rp)
1.47 noro 2055: {
2056: FNODE f;
2057: QUOTE q;
2058:
1.48 noro 2059: if ( !ARG0(arg) || OID((Obj)ARG0(arg)) != O_QUOTE )
2060: *rp = (Obj)ARG0(arg);
1.65 noro 2061: else if ( argc(arg) == 1 ) {
2062: f = flatten_fnode(BDY((QUOTE)ARG0(arg)),"+");
2063: f = flatten_fnode(f,"*");
2064: MKQUOTE(q,f);
2065: *rp = (Obj)q;
2066: } else {
1.48 noro 2067: f = flatten_fnode(BDY((QUOTE)ARG0(arg)),BDY((STRING)ARG1(arg)));
2068: MKQUOTE(q,f);
2069: *rp = (Obj)q;
2070: }
1.63 noro 2071: }
2072:
2073: void Pget_quote_id(NODE arg,Q *rp)
2074: {
2075: FNODE f;
2076: QUOTE q;
2077:
2078: q = (QUOTE)ARG0(arg);
2079: if ( !q || OID(q) != O_QUOTE )
2080: error("get_quote_id : invalid argument");
2081: f = BDY(q);
2082: STOQ((int)f->id,*rp);
1.48 noro 2083: }
2084:
2085: void Pquote_to_funargs(NODE arg,LIST *rp)
2086: {
2087: fid_spec_p spec;
2088: QUOTE q;
2089: QUOTEARG qa;
2090: FNODE f;
2091: STRING s;
2092: QUOTE r;
2093: int i;
2094: Q id,a;
1.49 noro 2095: LIST l;
2096: NODE t0,t,w,u,u0;
1.48 noro 2097:
2098: q = (QUOTE)ARG0(arg);
2099: if ( !q || OID(q) != O_QUOTE )
2100: error("quote_to_funargs : invalid argument");
2101: f = BDY(q);
2102: if ( !f ) {
2103: MKLIST(*rp,0);
2104: return;
2105: }
2106: get_fid_spec(f->id,&spec);
2107: if ( !spec )
2108: error("quote_to_funargs : not supported yet");
2109: t0 = 0;
2110: STOQ((int)f->id,id);
2111: NEXTNODE(t0,t);
2112: BDY(t) = (pointer)id;
2113: for ( i = 0; spec->type[i] != A_end; i++ ) {
2114: NEXTNODE(t0,t);
2115: switch ( spec->type[i] ) {
2116: case A_fnode:
2117: MKQUOTE(r,(FNODE)f->arg[i]);
2118: BDY(t) = (pointer)r;
2119: break;
2120: case A_int:
2121: STOQ((int)f->arg[i],a);
2122: BDY(t) = (pointer)a;
2123: break;
2124: case A_str:
2125: MKSTR(s,(char *)f->arg[i]);
2126: BDY(t) = (pointer)s;
2127: break;
2128: case A_internal:
2129: BDY(t) = (pointer)f->arg[i];
2130: break;
1.49 noro 2131: case A_node:
2132: w = (NODE)f->arg[i];
2133: for ( u0 = 0; w; w = NEXT(w) ){
2134: NEXTNODE(u0,u);
2135: MKQUOTE(r,(FNODE)BDY(w));
2136: BDY(u) = (pointer)r;
2137: }
2138: if ( u0 ) NEXT(u) = 0;
2139: MKLIST(l,u0);
2140: BDY(t) = (pointer)l;
2141: break;
1.48 noro 2142: default:
2143: MKQUOTEARG(qa,spec->type[i],f->arg[i]);
2144: BDY(t) = (pointer)qa;
2145: break;
2146: }
2147: }
2148: if ( t0 ) NEXT(t) = 0;
2149: MKLIST(*rp,t0);
2150: }
2151:
2152: void Pfunargs_to_quote(NODE arg,QUOTE *rp)
2153: {
2154: fid_spec_p spec;
2155: QUOTE q;
2156: QUOTEARG qa;
2157: FNODE f;
2158: STRING s;
1.49 noro 2159: QUOTE r,b;
1.48 noro 2160: int i;
2161: LIST l;
2162: fid id;
2163: Obj a;
1.49 noro 2164: NODE t0,t,u0,u,w;
1.48 noro 2165:
2166: l = (LIST)ARG0(arg);
2167: if ( !l || OID(l) != O_LIST || !(t=BDY(l)) )
2168: error("funargs_to_quote : invalid argument");
2169: t = BDY(l);
2170: id = (fid)QTOS((Q)BDY(t)); t = NEXT(t);
2171: get_fid_spec(id,&spec);
2172: if ( !spec )
2173: error("funargs_to_quote : not supported yet");
2174: for ( i = 0; spec->type[i] != A_end; i++ );
2175: NEWFNODE(f,i);
2176: f->id = id;
2177: for ( i = 0; spec->type[i] != A_end; i++, t = NEXT(t) ) {
2178: if ( !t )
2179: error("funargs_to_quote : argument mismatch");
2180: a = (Obj)BDY(t);
2181: switch ( spec->type[i] ) {
2182: case A_fnode:
2183: if ( !a || OID(a) != O_QUOTE )
2184: error("funargs_to_quote : invalid argument");
2185: f->arg[i] = BDY((QUOTE)a);
2186: break;
2187: case A_int:
2188: if ( !INT(a) )
2189: error("funargs_to_quote : invalid argument");
2190: f->arg[i] = (pointer)QTOS((Q)a);
2191: break;
2192: case A_str:
2193: if ( !a || OID(a) != O_STR )
2194: error("funargs_to_quote : invalid argument");
2195: f->arg[i] = (pointer)BDY((STRING)a);
2196: break;
2197: case A_internal:
2198: f->arg[i] = (pointer)a;
1.49 noro 2199: break;
2200: case A_node:
2201: if ( !a || OID(a) != O_LIST )
2202: error("funargs_to_quote : invalid argument");
2203: u0 = 0;
2204: for ( w = BDY((LIST)a); w; w = NEXT(w) ) {
2205: NEXTNODE(u0,u);
2206: b = (QUOTE)BDY(w);
2207: if ( !b || OID(b) != O_QUOTE )
2208: error("funargs_to_quote : invalid argument");
2209: BDY(u) = BDY(b);
2210: }
2211: if ( u0 ) NEXT(u) = 0;
2212: f->arg[i] = (pointer)u0;
1.48 noro 2213: break;
2214: default:
2215: if ( !a || OID(a) != O_QUOTEARG ||
2216: ((QUOTEARG)a)->type != spec->type[i] )
2217: error("funargs_to_quote : invalid argument");
2218: f->arg[i] = BDY((QUOTEARG)a);
2219: break;
2220: }
2221: }
2222: MKQUOTE(*rp,f);
1.69 noro 2223: }
2224:
1.105 noro 2225: VL reordvars(VL vl0,NODE head)
2226: {
2227: VL vl,svl,tvl;
2228: int i,j;
2229: NODE n;
2230: P t;
2231: V *va;
2232: V v;
2233:
2234: for ( vl = 0, i = 0, n = head; n; n = NEXT(n), i++ ) {
2235: NEXTVL(vl,tvl);
2236: if ( !(t = (P)BDY(n)) || (OID(t) != O_P) )
2237: error("reordvars : invalid argument");
2238: VR(tvl) = VR(t);
2239: }
2240: va = (V *)ALLOCA(i*sizeof(V));
2241: for ( j = 0, svl = vl; j < i; j++, svl = NEXT(svl) )
2242: va[j] = VR(svl);
2243: for ( svl = vl0; svl; svl = NEXT(svl) ) {
2244: v = VR(svl);
2245: for ( j = 0; j < i; j++ )
2246: if ( v == va[j] )
2247: break;
2248: if ( j == i ) {
2249: NEXTVL(vl,tvl);
2250: VR(tvl) = v;
2251: }
2252: }
2253: if ( vl )
2254: NEXT(tvl) = 0;
2255: return vl;
2256: }
2257:
1.109 noro 2258: struct wtab {
2259: V v;
2260: int w;
2261: };
2262:
2263: struct wtab *qt_weight_tab;
1.108 noro 2264: VL qt_current_ord, qt_current_coef;
1.109 noro 2265: LIST qt_current_ord_obj,qt_current_coef_obj,qt_current_weight_obj;
2266: LIST qt_current_weight_obj;
1.105 noro 2267:
2268: void Pqt_set_ord(NODE arg,LIST *rp)
2269: {
2270: NODE r0,r;
2271: VL vl;
2272: P v;
2273:
2274: if ( !argc(arg) )
2275: *rp = qt_current_ord_obj;
1.109 noro 2276: else if ( !ARG0(arg) ) {
2277: qt_current_ord_obj = 0;
2278: qt_current_ord = 0;
2279: } else {
1.105 noro 2280: qt_current_ord = reordvars(CO,BDY((LIST)ARG0(arg)));
2281: for ( r0 = 0, vl = qt_current_ord; vl; vl = NEXT(vl) ) {
2282: NEXTNODE(r0,r); MKV(vl->v,v); BDY(r) = v;
2283: }
2284: if ( r0 ) NEXT(r) = 0;
2285: MKLIST(*rp,r0);
2286: qt_current_ord_obj = *rp;
2287: }
2288: }
2289:
1.109 noro 2290: void Pqt_set_weight(NODE arg,LIST *rp)
2291: {
2292: NODE n,pair;
2293: int l,i;
2294: struct wtab *tab;
2295:
2296: if ( !argc(arg) )
2297: *rp = qt_current_weight_obj;
2298: else if ( !ARG0(arg) ) {
2299: qt_current_weight_obj = 0;
2300: qt_weight_tab = 0;
2301: } else {
2302: n = BDY((LIST)ARG0(arg));
2303: l = length(n);
2304: tab = qt_weight_tab = (struct wtab *)MALLOC((l+1)*sizeof(struct wtab));
2305: for ( i = 0; i < l; i++, n = NEXT(n) ) {
2306: pair = BDY((LIST)BDY(n));
2307: tab[i].v = VR((P)ARG0(pair));
2308: tab[i].w = QTOS((Q)ARG1(pair));
2309: }
2310: tab[i].v = 0;
2311: qt_current_weight_obj = (LIST)ARG0(arg);
2312: *rp = qt_current_weight_obj;
2313: }
2314: }
2315:
1.108 noro 2316: void Pqt_set_coef(NODE arg,LIST *rp)
2317: {
2318: NODE r0,r,n;
2319: VL vl0,vl;
2320: P v;
2321:
2322: if ( !argc(arg) )
2323: *rp = qt_current_coef_obj;
1.109 noro 2324: else if ( !ARG0(arg) ) {
2325: qt_current_coef_obj = 0;
2326: qt_current_coef = 0;
2327: } else {
1.108 noro 2328: n = BDY((LIST)ARG0(arg));
2329: for ( vl0 = 0, r0 = 0; n; n = NEXT(n) ) {
2330: NEXTNODE(r0,r);
2331: NEXTVL(vl0,vl);
2332: vl->v = VR((P)BDY(n));
2333: MKV(vl->v,v); BDY(r) = v;
2334: }
2335: if ( r0 ) NEXT(r) = 0;
2336: if ( vl0 ) NEXT(vl) = 0;
2337: qt_current_coef = vl0;
2338: MKLIST(*rp,r0);
2339: qt_current_coef_obj = *rp;
2340: }
2341: }
2342:
1.105 noro 2343: void Pqt_normalize(NODE arg,QUOTE *rp)
1.70 noro 2344: {
2345: QUOTE q,r;
2346: FNODE f;
1.76 noro 2347: int expand,ac;
1.70 noro 2348:
1.76 noro 2349: ac = argc(arg);
1.105 noro 2350: if ( !ac ) error("qt_normalize : invalid argument");
1.70 noro 2351: q = (QUOTE)ARG0(arg);
1.103 noro 2352: if ( ac == 2 )
2353: expand = QTOS((Q)ARG1(arg));
1.97 noro 2354: if ( !q || OID(q) != O_QUOTE )
1.87 noro 2355: *rp = q;
2356: else {
1.76 noro 2357: f = fnode_normalize(BDY(q),expand);
1.70 noro 2358: MKQUOTE(r,f);
2359: *rp = r;
1.98 noro 2360: }
2361: }
2362:
2363: NBP fnode_to_nbp(FNODE f);
2364:
1.105 noro 2365: void Pqt_to_nbp(NODE arg,NBP *rp)
1.98 noro 2366: {
2367: QUOTE q;
2368: FNODE f;
2369:
2370: q = (QUOTE)ARG0(arg); f = (FNODE)BDY(q);
2371: f = fnode_normalize(f,0);
2372: *rp = fnode_to_nbp(f);
2373: }
2374:
1.101 noro 2375: void Pshuffle_mul(NODE arg,NBP *rp)
1.98 noro 2376: {
2377: NBP p1,p2;
2378:
2379: p1 = (NBP)ARG0(arg);
2380: p2 = (NBP)ARG1(arg);
2381: shuffle_mulnbp(CO,p1,p2,rp);
2382: }
1.99 noro 2383:
1.101 noro 2384: void Pharmonic_mul(NODE arg,NBP *rp)
1.99 noro 2385: {
2386: NBP p1,p2;
2387:
2388: p1 = (NBP)ARG0(arg);
2389: p2 = (NBP)ARG1(arg);
2390: harmonic_mulnbp(CO,p1,p2,rp);
2391: }
2392:
1.100 noro 2393: void Pnbp_hm(NODE arg, NBP *rp)
2394: {
2395: NBP p;
2396: NODE n;
2397: NBM m;
2398:
2399: p = (NBP)ARG0(arg);
2400: if ( !p ) *rp = 0;
2401: else {
2402: m = (NBM)BDY(BDY(p));
2403: MKNODE(n,m,0);
2404: MKNBP(*rp,n);
2405: }
2406: }
2407:
2408: void Pnbp_ht(NODE arg, NBP *rp)
2409: {
2410: NBP p;
2411: NODE n;
2412: NBM m,m1;
2413:
2414: p = (NBP)ARG0(arg);
2415: if ( !p ) *rp = 0;
2416: else {
2417: m = (NBM)BDY(BDY(p));
2418: NEWNBM(m1);
1.115 noro 2419: m1->d = m->d; m1->c = (P)ONE; m1->b = m->b;
1.100 noro 2420: MKNODE(n,m1,0);
2421: MKNBP(*rp,n);
2422: }
2423: }
2424:
1.115 noro 2425: void Pnbp_hc(NODE arg, P *rp)
1.100 noro 2426: {
2427: NBP p;
2428: NBM m;
2429:
2430: p = (NBP)ARG0(arg);
2431: if ( !p ) *rp = 0;
2432: else {
2433: m = (NBM)BDY(BDY(p));
2434: *rp = m->c;
2435: }
2436: }
2437:
2438: void Pnbp_rest(NODE arg, NBP *rp)
2439: {
2440: NBP p;
2441: NODE n;
2442:
2443: p = (NBP)ARG0(arg);
2444: if ( !p ) *rp = 0;
2445: else {
2446: n = BDY(p);
2447: if ( !NEXT(n) ) *rp = 0;
2448: else
2449: MKNBP(*rp,NEXT(n));
2450: }
2451: }
2452:
1.115 noro 2453: void Pnbp_tm(NODE arg, NBP *rp)
2454: {
2455: NBP p;
2456: NODE n;
2457: NBM m;
2458:
2459: p = (NBP)ARG0(arg);
2460: if ( !p ) *rp = 0;
2461: else {
2462: for ( n = BDY(p); NEXT(n); n = NEXT(n) );
2463: m = (NBM)BDY(n);
2464: MKNODE(n,m,0);
2465: MKNBP(*rp,n);
2466: }
2467: }
2468:
2469: void Pnbp_tt(NODE arg, NBP *rp)
2470: {
2471: NBP p;
2472: NODE n;
2473: NBM m,m1;
2474:
2475: p = (NBP)ARG0(arg);
2476: if ( !p ) *rp = 0;
2477: else {
2478: for ( n = BDY(p); NEXT(n); n = NEXT(n) );
2479: m = (NBM)BDY(n);
2480: NEWNBM(m1);
2481: m1->d = m->d; m1->c = (P)ONE; m1->b = m->b;
2482: MKNODE(n,m1,0);
2483: MKNBP(*rp,n);
2484: }
2485: }
2486:
2487: void Pnbp_tc(NODE arg, P *rp)
2488: {
2489: NBP p;
2490: NBM m;
2491: NODE n;
2492:
2493: p = (NBP)ARG0(arg);
2494: if ( !p ) *rp = 0;
2495: else {
2496: for ( n = BDY(p); NEXT(n); n = NEXT(n) );
2497: m = (NBM)BDY(n);
2498: *rp = m->c;
2499: }
2500: }
2501:
2502: void Pnbp_trest(NODE arg, NBP *rp)
2503: {
2504: NBP p;
2505: NODE n,r,r0;
2506:
2507: p = (NBP)ARG0(arg);
2508: if ( !p ) *rp = 0;
2509: else {
2510: n = BDY(p);
2511: for ( r0 = 0; NEXT(n); n = NEXT(n) ) {
2512: NEXTNODE(r0,r);
2513: BDY(r) = (pointer)BDY(n);
2514: }
2515: if ( r0 ) {
2516: NEXT(r) = 0;
2517: MKNBP(*rp,r0);
2518: } else
2519: *rp = 0;
2520: }
2521: }
2522:
1.102 noro 2523: void Pnbm_deg(NODE arg, Q *rp)
1.100 noro 2524: {
2525: NBP p;
2526: NBM m;
1.102 noro 2527:
2528: p = (NBP)ARG0(arg);
2529: if ( !p )
2530: STOQ(-1,*rp);
2531: else {
2532: m = (NBM)BDY(BDY(p));
2533: STOQ(m->d,*rp);
2534: }
2535: }
2536:
2537: void Pnbm_hp_rest(NODE arg, LIST *rp)
2538: {
2539: NBP p,h,r;
2540: NBM m,m1;
1.100 noro 2541: NODE n;
1.102 noro 2542: int *b,*b1;
2543: int d,d1,v,i,j,k;
1.100 noro 2544:
2545: p = (NBP)ARG0(arg);
1.102 noro 2546: if ( !p )
1.100 noro 2547: MKLIST(*rp,0);
1.102 noro 2548: else {
2549: m = (NBM)BDY(BDY(p));
2550: b = m->b; d = m->d;
1.100 noro 2551: if ( !d )
2552: MKLIST(*rp,0);
2553: else {
1.102 noro 2554: v = NBM_GET(b,0);
1.100 noro 2555: for ( i = 1; i < d; i++ )
1.102 noro 2556: if ( NBM_GET(b,i) != v ) break;
2557: NEWNBM(m1); NEWNBMBDY(m1,i);
1.115 noro 2558: b1 = m1->b; m1->d = i; m1->c = (P)ONE;
1.102 noro 2559: if ( v ) for ( j = 0; j < i; j++ ) NBM_SET(b1,j);
2560: else for ( j = 0; j < i; j++ ) NBM_CLR(b1,j);
2561: MKNODE(n,m1,0); MKNBP(h,n);
2562:
2563: d1 = d-i;
2564: NEWNBM(m1); NEWNBMBDY(m1,d1);
1.115 noro 2565: b1 = m1->b; m1->d = d1; m1->c = (P)ONE;
1.102 noro 2566: for ( j = 0, k = i; j < d1; j++, k++ )
2567: if ( NBM_GET(b,k) ) NBM_SET(b1,j);
2568: else NBM_CLR(b1,j);
2569: MKNODE(n,m1,0); MKNBP(r,n);
2570: n = mknode(2,h,r);
1.100 noro 2571: MKLIST(*rp,n);
2572: }
2573: }
2574: }
2575:
1.102 noro 2576: void Pnbm_hxky(NODE arg, LIST *rp)
2577: {
2578: NBP p;
2579:
2580: p = (NBP)ARG0(arg);
2581: if ( !p )
2582: *rp = 0;
2583: else
2584: separate_xky_nbm((NBM)BDY(BDY(p)),0,rp,0);
2585: }
2586:
2587: void Pnbm_xky_rest(NODE arg,NBP *rp)
1.100 noro 2588: {
2589: NBP p;
2590:
2591: p = (NBP)ARG0(arg);
2592: if ( !p )
2593: *rp = 0;
1.102 noro 2594: else
2595: separate_xky_nbm((NBM)BDY(BDY(p)),0,0,rp);
2596: }
2597:
2598: void Pnbm_hv(NODE arg, NBP *rp)
2599: {
2600: NBP p;
2601:
2602: p = (NBP)ARG0(arg);
2603: if ( !p )
2604: *rp = 0;
2605: else
2606: separate_nbm((NBM)BDY(BDY(p)),0,rp,0);
1.116 ! noro 2607: }
! 2608:
! 2609: void Pnbm_tv(NODE arg, NBP *rp)
! 2610: {
! 2611: NBP p;
! 2612: NBM m,t;
! 2613: int d;
! 2614:
! 2615: p = (NBP)ARG0(arg);
! 2616: if ( !p )
! 2617: *rp = 0;
! 2618: else {
! 2619: m = (NBM)BDY(BDY(p));
! 2620: d = m->d;
! 2621: if ( !d ) error("nbm_tv : invalid argument");
! 2622: NEWNBM(t); NEWNBMBDY(t,1); t->d = 1; t->c = (P)ONE;
! 2623: if ( NBM_GET(m->b,d-1) ) NBM_SET(t->b,0);
! 2624: else NBM_CLR(t->b,0);
! 2625: *rp = (NBP)nbmtonbp(t);
! 2626: }
1.102 noro 2627: }
2628:
2629: void Pnbm_rest(NODE arg, NBP *rp)
2630: {
2631: NBP p;
2632:
2633: p = (NBP)ARG0(arg);
2634: if ( !p )
2635: *rp = 0;
2636: else
2637: separate_nbm((NBM)BDY(BDY(p)),0,0,rp);
1.100 noro 2638: }
1.98 noro 2639:
2640: NBP fnode_to_nbp(FNODE f)
2641: {
2642: Q r;
2643: int n,i;
2644: NBM m;
2645: V v;
2646: NBP u,u1,u2;
2647: NODE t,b;
2648:
2649: if ( f->id == I_FORMULA ) {
2650: r = eval(f);
2651: NEWNBM(m);
2652: if ( OID(r) == O_N ) {
1.115 noro 2653: m->d = 0; m->c = (P)r; m->b = 0;
1.98 noro 2654: } else {
2655: v = VR((P)r);
1.115 noro 2656: m->d = 1; m->c = (P)ONE; NEWNBMBDY(m,1);
1.98 noro 2657: if ( !strcmp(NAME(v),"x") ) NBM_SET(m->b,0);
2658: else NBM_CLR(m->b,0);
2659: }
2660: MKNODE(b,m,0); MKNBP(u,b);
2661: return u;
2662: } else if ( IS_NARYADD(f) ) {
2663: t = (NODE)FA1(f); u = fnode_to_nbp((FNODE)BDY(t));
2664: for ( t = NEXT(t); t; t = NEXT(t) ) {
2665: u1 = fnode_to_nbp((FNODE)BDY(t));
2666: addnbp(CO,u,u1,&u2); u = u2;
2667: }
2668: return u;
2669: } else if ( IS_NARYMUL(f) ) {
2670: t = (NODE)FA1(f); u = fnode_to_nbp((FNODE)BDY(t));
2671: for ( t = NEXT(t); t; t = NEXT(t) ) {
2672: u1 = fnode_to_nbp((FNODE)BDY(t));
2673: mulnbp(CO,u,u1,&u2); u = u2;
2674: }
2675: return u;
2676: } else if ( IS_BINARYPWR(f) ) {
2677: u = fnode_to_nbp((FNODE)FA1(f));
2678: r = eval((FNODE)FA2(f));
2679: pwrnbp(CO,u,r,&u1);
2680: return u1;
1.70 noro 2681: }
2682: }
2683:
1.111 noro 2684: void Pnqt_weight(NODE arg,Q *rp)
2685: {
2686: QUOTE q;
2687: FNODE f;
2688: int w;
2689:
2690: q = (QUOTE)ARG0(arg); f = (FNODE)BDY(q);
2691: f = fnode_normalize(f,0);
1.112 noro 2692: w = nfnode_weight(qt_weight_tab,f);
1.111 noro 2693: STOQ(w,*rp);
2694: }
2695:
1.105 noro 2696: void Pnqt_comp(NODE arg,Q *rp)
1.80 noro 2697: {
1.87 noro 2698: QUOTE q1,q2;
1.80 noro 2699: FNODE f1,f2;
2700: int r;
2701:
1.87 noro 2702: q1 = (QUOTE)ARG0(arg); f1 = (FNODE)BDY(q1);
2703: q2 = (QUOTE)ARG1(arg); f2 = (FNODE)BDY(q2);
1.97 noro 2704: f1 = fnode_normalize(f1,0);
2705: f2 = fnode_normalize(f2,0);
1.95 noro 2706: r = nfnode_comp(f1,f2);
1.80 noro 2707: STOQ(r,*rp);
2708: }
2709:
1.108 noro 2710: int fnode_is_var(FNODE f)
2711: {
2712: Obj obj;
2713: VL vl,t,s;
2714: DCP dc;
2715:
2716: if ( fnode_is_coef(f) ) return 0;
2717: switch ( f->id ) {
2718: case I_PAREN:
2719: return fnode_is_var(FA0(f));
2720:
2721: case I_FORMULA:
2722: obj = FA0(f);
2723: if ( obj && OID(obj) == O_P ) {
2724: dc = DC((P)obj);
2725: if ( !cmpq(DEG(dc),ONE) && !NEXT(dc)
2726: && !arf_comp(CO,(Obj)COEF(dc),(Obj)ONE) ) return 1;
2727: else return 0;
2728: } else return 0;
2729:
2730: default:
2731: return 0;
2732: }
2733: }
2734:
2735: int fnode_is_coef(FNODE f)
2736: {
2737: Obj obj;
2738: VL vl,t,s;
2739:
2740: switch ( f->id ) {
2741: case I_MINUS: case I_PAREN:
2742: return fnode_is_coef(FA0(f));
2743:
2744: case I_FORMULA:
2745: obj = FA0(f);
2746: if ( !obj ) return 1;
2747: else if ( OID(obj) == O_QUOTE )
2748: return fnode_is_coef(BDY((QUOTE)obj));
2749: else if ( NUM(obj) ) return 1;
2750: else if ( OID(obj) == O_P || OID(obj) == O_R) {
2751: get_vars_recursive(obj,&vl);
2752: for ( t = vl; t; t = NEXT(t) ) {
1.111 noro 2753: if ( t->v->attr == (pointer)V_PF ) continue;
1.108 noro 2754: for ( s = qt_current_coef; s; s = NEXT(s) )
2755: if ( t->v == s->v ) break;
1.111 noro 2756: if ( !s )
2757: return 0;
1.108 noro 2758: }
2759: return 1;
2760: } else return 0;
2761:
2762: case I_BOP:
2763: return fnode_is_coef(FA1(f)) && fnode_is_coef(FA2(f));
2764:
2765: default:
2766: return 0;
2767: }
2768: }
2769:
2770: int fnode_is_number(FNODE f)
1.69 noro 2771: {
2772: Obj obj;
2773:
2774: switch ( f->id ) {
2775: case I_MINUS: case I_PAREN:
2776: return fnode_is_number(FA0(f));
2777:
2778: case I_FORMULA:
2779: obj = FA0(f);
2780: if ( !obj ) return 1;
2781: else if ( OID(obj) == O_QUOTE )
2782: return fnode_is_number(BDY((QUOTE)obj));
2783: else if ( NUM(obj) ) return 1;
2784: else return 0;
2785:
2786: case I_BOP:
2787: return fnode_is_number(FA1(f)) && fnode_is_number(FA2(f));
2788:
2789: default:
2790: return 0;
2791: }
2792: }
2793:
2794: int fnode_is_rational(FNODE f)
2795: {
2796: Obj obj;
2797:
2798: switch ( f->id ) {
2799: case I_MINUS: case I_PAREN:
2800: return fnode_is_number(FA0(f));
2801:
2802: case I_FORMULA:
2803: obj = FA0(f);
2804: if ( !obj ) return 1;
2805: else if ( OID(obj) == O_QUOTE )
2806: return fnode_is_rational(BDY((QUOTE)obj));
2807: else if ( NUM(obj) && RATN(obj) ) return 1;
2808: else return 0;
2809:
2810: case I_BOP:
2811: if ( !strcmp(((ARF)FA0(f))->name,"^") )
2812: return fnode_is_rational(FA1(f)) && fnode_is_integer(FA2(f));
2813: else
2814: return fnode_is_rational(FA1(f)) && fnode_is_rational(FA2(f));
2815:
2816: default:
2817: return 0;
2818: }
2819: }
2820:
2821: int fnode_is_integer(FNODE f)
2822: {
2823: Obj obj;
2824:
2825: switch ( f->id ) {
2826: case I_MINUS: case I_PAREN:
2827: return fnode_is_integer(FA0(f));
2828:
2829: case I_FORMULA:
2830: obj = FA0(f);
2831: if ( !obj ) return 1;
2832: else if ( OID(obj) == O_QUOTE )
2833: return fnode_is_integer(BDY((QUOTE)obj));
2834: else if ( INT(obj)) return 1;
2835: else return 0;
2836:
2837: case I_BOP:
1.70 noro 2838: switch ( ((ARF)FA0(f))->name[0] ) {
2839: case '^':
2840: return fnode_is_integer(FA1(f))
2841: && fnode_is_nonnegative_integer(FA2(f));
2842: case '/':
2843: return fnode_is_integer(FA1(f)) &&
2844: ( fnode_is_one(FA2(f)) || fnode_is_minusone(FA2(f)) );
2845: default:
2846: return fnode_is_integer(FA1(f)) && fnode_is_integer(FA2(f));
2847: }
2848: break;
2849:
1.69 noro 2850: default:
2851: return 0;
2852: }
2853: }
2854:
2855: int fnode_is_nonnegative_integer(FNODE f)
2856: {
2857: Q n;
2858:
2859: n = eval(f);
2860: if ( !n || (INT(n) && SGN(n) > 0) ) return 1;
2861: else return 0;
2862: }
2863:
2864: int fnode_is_one(FNODE f)
2865: {
2866: Q n;
2867:
2868: n = eval(f);
2869: if ( UNIQ(n) ) return 1;
2870: else return 0;
2871: }
2872:
2873: int fnode_is_minusone(FNODE f)
2874: {
2875: Q n;
2876:
2877: n = eval(f);
2878: if ( MUNIQ(n) ) return 1;
2879: else return 0;
2880: }
2881:
2882: int fnode_is_dependent(FNODE f,V v)
2883: {
2884: Obj obj;
2885: FNODE arg;
2886: NODE t;
2887:
2888: switch ( f->id ) {
2889: case I_MINUS: case I_PAREN:
2890: return fnode_is_dependent(FA0(f),v);
2891:
2892: case I_FORMULA:
2893: obj = FA0(f);
2894: if ( !obj ) return 0;
2895: else if ( OID(obj) == O_QUOTE )
2896: return fnode_is_dependent(BDY((QUOTE)obj),v);
2897: else if ( obj_is_dependent(obj,v) ) return 1;
2898: else return 0;
2899:
2900: case I_BOP:
2901: return fnode_is_dependent(FA1(f),v) || fnode_is_dependent(FA2(f),v);
2902:
2903: case I_FUNC:
2904: arg = (FNODE)FA1(f);
2905: for ( t = FA0(arg); t; t = NEXT(t) )
2906: if ( fnode_is_dependent(BDY(t),v) ) return 1;
2907: return 0;
2908:
2909: default:
2910: return 0;
2911: }
1.1 noro 2912: }
1.70 noro 2913:
1.72 noro 2914:
1.76 noro 2915: FNODE fnode_normalize(FNODE f,int expand)
1.70 noro 2916: {
1.73 noro 2917: FNODE a1,a2,mone,r,b2;
1.72 noro 2918: NODE n;
1.70 noro 2919: Q q;
2920:
1.103 noro 2921: if ( f->normalized && (f->expanded == expand) ) return f;
1.72 noro 2922: STOQ(-1,q);
2923: mone = mkfnode(1,I_FORMULA,q);
1.70 noro 2924: switch ( f->id ) {
2925: case I_PAREN:
1.89 noro 2926: r = fnode_normalize(FA0(f),expand);
2927: break;
1.71 noro 2928:
2929: case I_MINUS:
1.108 noro 2930: r = nfnode_mul_coef((Obj)q,
1.76 noro 2931: fnode_normalize(FA0(f),expand),expand);
1.89 noro 2932: break;
1.71 noro 2933:
1.70 noro 2934: case I_BOP:
2935: /* arf fnode fnode */
1.76 noro 2936: a1 = fnode_normalize(FA1(f),expand);
2937: a2 = fnode_normalize(FA2(f),expand);
1.72 noro 2938: switch ( OPNAME(f) ) {
2939: case '+':
1.95 noro 2940: r = nfnode_add(a1,a2,expand);
1.89 noro 2941: break;
1.70 noro 2942: case '-':
1.108 noro 2943: a2 = nfnode_mul_coef((Obj)q,a2,expand);
1.95 noro 2944: r = nfnode_add(a1,a2,expand);
1.89 noro 2945: break;
1.72 noro 2946: case '*':
1.95 noro 2947: r = nfnode_mul(a1,a2,expand);
1.89 noro 2948: break;
1.70 noro 2949: case '/':
1.95 noro 2950: a2 = nfnode_pwr(a2,mone,expand);
2951: r = nfnode_mul(a1,a2,expand);
1.89 noro 2952: break;
1.73 noro 2953: case '^':
1.95 noro 2954: r = nfnode_pwr(a1,a2,expand);
1.89 noro 2955: break;
1.70 noro 2956: default:
1.89 noro 2957: r = mkfnode(3,I_BOP,FA0(f),a1,a2);
2958: break;
1.70 noro 2959: }
2960: break;
1.71 noro 2961:
1.70 noro 2962: case I_NARYOP:
1.72 noro 2963: switch ( OPNAME(f) ) {
1.71 noro 2964: case '+':
1.73 noro 2965: n = (NODE)FA1(f);
1.76 noro 2966: r = fnode_normalize(BDY(n),expand); n = NEXT(n);
1.72 noro 2967: for ( ; n; n = NEXT(n) ) {
1.76 noro 2968: a1 = fnode_normalize(BDY(n),expand);
1.95 noro 2969: r = nfnode_add(r,a1,expand);
1.72 noro 2970: }
1.89 noro 2971: break;
1.70 noro 2972: case '*':
1.73 noro 2973: n = (NODE)FA1(f);
1.76 noro 2974: r = fnode_normalize(BDY(n),expand); n = NEXT(n);
1.72 noro 2975: for ( ; n; n = NEXT(n) ) {
1.76 noro 2976: a1 = fnode_normalize(BDY(n),expand);
1.95 noro 2977: r = nfnode_mul(r,a1,expand);
1.72 noro 2978: }
1.89 noro 2979: break;
1.70 noro 2980: default:
1.72 noro 2981: error("fnode_normallize : cannot happen");
1.70 noro 2982: }
1.89 noro 2983: break;
1.72 noro 2984:
1.70 noro 2985: default:
1.76 noro 2986: return fnode_apply(f,fnode_normalize,expand);
1.70 noro 2987: }
1.89 noro 2988: r->normalized = 1;
2989: r->expanded = expand;
2990: return r;
1.70 noro 2991: }
2992:
1.76 noro 2993: FNODE fnode_apply(FNODE f,FNODE (*func)(),int expand)
1.70 noro 2994: {
2995: fid_spec_p spec;
2996: FNODE r;
2997: int i,n;
2998: NODE t,t0,s;
2999:
3000: get_fid_spec(f->id,&spec);
3001: for ( n = 0; spec->type[n] != A_end; n++ );
3002: NEWFNODE(r,n); r->id = f->id;
3003: for ( i = 0; i < n; i++ ) {
3004: switch ( spec->type[i] ) {
3005: case A_fnode:
1.78 noro 3006: r->arg[i] = func(f->arg[i],expand);
1.70 noro 3007: break;
3008: case A_node:
3009: s = (NODE)f->arg[i];
3010: for ( t0 = 0; s; s = NEXT(s) ) {
3011: NEXTNODE(t0,t);
1.76 noro 3012: BDY(t) = (pointer)func((FNODE)BDY(s),expand);
1.70 noro 3013: }
3014: if ( t0 ) NEXT(t) = 0;
3015: r->arg[i] = t0;
3016: break;
3017: default:
3018: r->arg[i] = f->arg[i];
3019: break;
3020: }
3021: }
3022: return r;
3023: }
3024:
1.95 noro 3025: FNODE nfnode_add(FNODE f1,FNODE f2,int expand)
1.71 noro 3026: {
1.72 noro 3027: NODE n1,n2,r0,r;
3028: FNODE b1,b2;
3029: int s;
1.108 noro 3030: Obj c1,c2,c;
1.72 noro 3031:
1.77 noro 3032: if ( IS_ZERO(f1) ) return f2;
3033: else if ( IS_ZERO(f2) ) return f1;
1.75 noro 3034: f1 = to_naryadd(f1); f2 = to_naryadd(f2);
3035: n1 = (NODE)FA1(f1); n2 = (NODE)FA1(f2);
1.72 noro 3036: r0 = 0;
3037: while ( n1 && n2 ) {
1.75 noro 3038: fnode_coef_body(BDY(n1),&c1,&b1); fnode_coef_body(BDY(n2),&c2,&b2);
1.95 noro 3039: if ( (s = nfnode_comp(b1,b2)) > 0 ) {
1.73 noro 3040: NEXTNODE(r0,r); BDY(r) = BDY(n1); n1 = NEXT(n1);
1.72 noro 3041: } else if ( s < 0 ) {
1.73 noro 3042: NEXTNODE(r0,r); BDY(r) = BDY(n2); n2 = NEXT(n2);
1.72 noro 3043: } else {
1.108 noro 3044: arf_add(CO,c1,c2,&c);
1.72 noro 3045: if ( c ) {
1.95 noro 3046: NEXTNODE(r0,r); BDY(r) = nfnode_mul_coef(c,b1,expand);
1.71 noro 3047: }
1.72 noro 3048: n1 = NEXT(n1); n2 = NEXT(n2);
1.71 noro 3049: }
3050: }
1.72 noro 3051: if ( n1 )
3052: if ( r0 ) NEXT(r) = n1;
3053: else r0 = n1;
3054: else if ( n2 )
3055: if ( r0 ) NEXT(r) = n2;
3056: else r0 = n2;
3057: else if ( r0 )
3058: NEXT(r) = 0;
3059:
1.106 noro 3060: return fnode_node_to_nary(addfs,r0);
1.75 noro 3061: }
3062:
1.106 noro 3063: FNODE fnode_node_to_nary(ARF op,NODE n)
1.75 noro 3064: {
1.106 noro 3065: if ( !n ) {
3066: if ( op->name[0] == '+' )
3067: return mkfnode(1,I_FORMULA,0);
3068: else
3069: return mkfnode(1,I_FORMULA,ONE);
3070: } else if ( !NEXT(n) ) return BDY(n);
3071: else return mkfnode(2,I_NARYOP,op,n);
1.71 noro 3072: }
3073:
1.95 noro 3074: FNODE nfnode_mul(FNODE f1,FNODE f2,int expand)
1.71 noro 3075: {
1.72 noro 3076: NODE n1,n2,r0,r,r1;
1.76 noro 3077: FNODE b1,b2,e1,e2,cc,t,t1;
1.72 noro 3078: FNODE *m;
3079: int s;
1.109 noro 3080: Obj c1,c2,c,e;
1.75 noro 3081: int l1,l,i,j;
1.72 noro 3082:
1.77 noro 3083: if ( IS_ZERO(f1) || IS_ZERO(f2) ) return mkfnode(1,I_FORMULA,0);
1.108 noro 3084: else if ( fnode_is_coef(f1) )
3085: return nfnode_mul_coef((Obj)eval(f1),f2,expand);
3086: else if ( fnode_is_coef(f2) )
3087: return nfnode_mul_coef((Obj)eval(f2),f1,expand);
1.76 noro 3088:
3089: if ( expand && IS_NARYADD(f1) ) {
3090: t = mkfnode(1,I_FORMULA,0);
3091: for ( n1 = (NODE)FA1(f1); n1; n1 = NEXT(n1) ) {
1.95 noro 3092: t1 = nfnode_mul(BDY(n1),f2,expand);
3093: t = nfnode_add(t,t1,expand);
1.76 noro 3094: }
3095: return t;
3096: }
3097: if ( expand && IS_NARYADD(f2) ) {
3098: t = mkfnode(1,I_FORMULA,0);
3099: for ( n2 = (NODE)FA1(f2); n2; n2 = NEXT(n2) ) {
1.95 noro 3100: t1 = nfnode_mul(f1,BDY(n2),expand);
3101: t = nfnode_add(t,t1,expand);
1.76 noro 3102: }
3103: return t;
3104: }
1.72 noro 3105:
1.75 noro 3106: fnode_coef_body(f1,&c1,&b1); fnode_coef_body(f2,&c2,&b2);
1.108 noro 3107: arf_mul(CO,c1,c2,&c);
1.72 noro 3108: if ( !c ) return mkfnode(1,I_FORMULA,0);
1.71 noro 3109:
1.76 noro 3110:
1.75 noro 3111: n1 = (NODE)FA1(to_narymul(b1)); n2 = (NODE)FA1(to_narymul(b2));
3112: l1 = length(n1); l = l1+length(n2);
1.72 noro 3113: m = (FNODE *)ALLOCA(l*sizeof(FNODE));
3114: for ( r = n1, i = 0; i < l1; r = NEXT(r), i++ ) m[i] = BDY(r);
3115: for ( r = n2; r; r = NEXT(r) ) {
1.113 noro 3116: if ( i == 0 )
1.72 noro 3117: m[i++] = BDY(r);
3118: else {
1.75 noro 3119: fnode_base_exp(m[i-1],&b1,&e1); fnode_base_exp(BDY(r),&b2,&e2);
3120: if ( compfnode(b1,b2) ) break;
1.109 noro 3121: arf_add(CO,eval(e1),eval(e2),&e);
1.75 noro 3122: if ( !e ) i--;
1.113 noro 3123: else if ( expand == 2 ) {
3124: if ( INT(e) && SGN((Q)e) < 0 ) {
3125: t1 = mkfnode(3,I_BOP,pwrfs,b1,mkfnode(1,I_FORMULA,e));
3126: /* r=(r0|rest)->(r0,t1|rest) */
3127: t = BDY(r);
3128: MKNODE(r1,t1,NEXT(r));
3129: MKNODE(r,t,r1);
3130: i--;
3131: } else
3132: m[i++] = BDY(r);
3133: } else if ( UNIQ(e) )
1.75 noro 3134: m[i-1] = b1;
3135: else
3136: m[i-1] = mkfnode(3,I_BOP,pwrfs,b1,mkfnode(1,I_FORMULA,e));
1.71 noro 3137: }
3138: }
1.75 noro 3139: for ( j = i-1; j >= 0; j-- ) {
3140: MKNODE(r1,m[j],r); r = r1;
3141: }
3142: if ( !UNIQ(c) ) {
3143: cc = mkfnode(1,I_FORMULA,c); MKNODE(r1,cc,r); r = r1;
1.72 noro 3144: }
1.106 noro 3145: return fnode_node_to_nary(mulfs,r);
1.73 noro 3146: }
3147:
1.95 noro 3148: FNODE nfnode_pwr(FNODE f1,FNODE f2,int expand)
1.73 noro 3149: {
1.89 noro 3150: FNODE b,b1,e1,e,cc,r,mf2,mone,inv;
1.108 noro 3151: Obj c,c1;
3152: Num nf2;
1.89 noro 3153: int ee;
3154: NODE arg,n,t0,t1;
1.76 noro 3155: Q q;
1.73 noro 3156:
1.77 noro 3157: if ( IS_ZERO(f2) ) return mkfnode(1,I_FORMULA,ONE);
3158: else if ( IS_ZERO(f1) ) return mkfnode(1,I_FORMULA,0);
1.108 noro 3159: else if ( fnode_is_coef(f1) ) {
1.73 noro 3160: if ( fnode_is_integer(f2) ) {
1.92 noro 3161: if ( fnode_is_one(f2) ) return f1;
3162: else {
1.108 noro 3163: arf_pwr(CO,eval(f1),(Obj)eval(f2),&c);
1.92 noro 3164: return mkfnode(1,I_FORMULA,c);
3165: }
1.108 noro 3166: } else {
3167: f1 = mkfnode(1,I_FORMULA,eval(f1));
1.73 noro 3168: return mkfnode(3,I_BOP,pwrfs,f1,f2);
1.108 noro 3169: }
1.92 noro 3170: } else if ( IS_BINARYPWR(f1) ) {
1.73 noro 3171: b1 = FA1(f1); e1 = FA2(f1);
1.95 noro 3172: e = nfnode_mul(e1,f2,expand);
1.73 noro 3173: if ( fnode_is_one(e) )
3174: return b1;
3175: else
3176: return mkfnode(3,I_BOP,FA0(f1),b1,e);
1.92 noro 3177: } else if ( expand && IS_NARYMUL(f1) && fnode_is_number(f2)
3178: && fnode_is_integer(f2) ) {
1.73 noro 3179: fnode_coef_body(f1,&c1,&b1);
1.89 noro 3180: nf2 = (Num)eval(f2);
1.108 noro 3181: arf_pwr(CO,c1,(Obj)nf2,&c);
1.89 noro 3182: ee = QTOS((Q)nf2);
1.75 noro 3183: cc = mkfnode(1,I_FORMULA,c);
1.89 noro 3184: if ( fnode_is_nonnegative_integer(f2) )
1.103 noro 3185: b = fnode_expand_pwr(b1,ee,expand);
1.89 noro 3186: else {
3187: STOQ(-1,q);
3188: mone = mkfnode(1,I_FORMULA,q);
1.92 noro 3189: b1 = to_narymul(b1);
1.89 noro 3190: for ( t0 = 0, n = (NODE)FA1(b1); n; n = NEXT(n) ) {
3191: inv = mkfnode(3,I_BOP,pwrfs,BDY(n),mone);
3192: MKNODE(t1,inv,t0); t0 = t1;
3193: }
1.106 noro 3194: b1 = fnode_node_to_nary(mulfs,t0);
1.103 noro 3195: b = fnode_expand_pwr(b1,-ee,expand);
1.89 noro 3196: }
1.75 noro 3197: if ( fnode_is_one(cc) )
3198: return b;
3199: else
1.106 noro 3200: return fnode_node_to_nary(mulfs,mknode(2,cc,b));
1.82 noro 3201: } else if ( expand && fnode_is_integer(f2)
3202: && fnode_is_nonnegative_integer(f2) ) {
1.76 noro 3203: q = (Q)eval(f2);
1.95 noro 3204: if ( PL(NM(q)) > 1 ) error("nfnode_pwr : exponent too large");
1.103 noro 3205: return fnode_expand_pwr(f1,QTOS(q),expand);
1.73 noro 3206: } else
3207: return mkfnode(3,I_BOP,pwrfs,f1,f2);
1.72 noro 3208: }
3209:
1.103 noro 3210: FNODE fnode_expand_pwr(FNODE f,int n,int expand)
1.76 noro 3211: {
1.103 noro 3212: int n1,i;
3213: FNODE f1,f2,fn;
3214: Q q;
1.76 noro 3215:
3216: if ( !n ) return mkfnode(1,I_FORMULA,ONE);
1.77 noro 3217: else if ( IS_ZERO(f) ) return mkfnode(1,I_FORMULA,0);
1.76 noro 3218: else if ( n == 1 ) return f;
3219: else {
1.103 noro 3220: switch ( expand ) {
3221: case 1:
3222: n1 = n/2;
3223: f1 = fnode_expand_pwr(f,n1,expand);
3224: f2 = nfnode_mul(f1,f1,expand);
3225: if ( n%2 ) f2 = nfnode_mul(f2,f,1);
3226: return f2;
3227: case 2:
3228: for ( i = 1, f1 = f; i < n; i++ )
3229: f1 = nfnode_mul(f1,f,expand);
3230: return f1;
3231: case 0: default:
3232: STOQ(n,q);
3233: fn = mkfnode(1,I_FORMULA,q);
3234: return mkfnode(3,I_BOP,pwrfs,f,fn);
3235: }
1.76 noro 3236: }
3237: }
3238:
1.72 noro 3239: /* f = b^e */
3240: void fnode_base_exp(FNODE f,FNODE *bp,FNODE *ep)
3241: {
1.75 noro 3242: if ( IS_BINARYPWR(f) ) {
1.72 noro 3243: *bp = FA1(f); *ep = FA2(f);
3244: } else {
3245: *bp = f; *ep = mkfnode(1,I_FORMULA,ONE);
3246: }
3247: }
3248:
3249: FNODE to_naryadd(FNODE f)
3250: {
3251: FNODE r;
3252: NODE n;
3253:
1.75 noro 3254: if ( IS_NARYADD(f) ) return f;
3255:
3256: NEWFNODE(r,2); r->id = I_NARYOP;
3257: FA0(r) = addfs; MKNODE(n,f,0); FA1(r) = n;
1.72 noro 3258: return r;
3259: }
3260:
3261: FNODE to_narymul(FNODE f)
3262: {
3263: FNODE r;
3264: NODE n;
3265:
1.75 noro 3266: if ( IS_NARYMUL(f) ) return f;
3267:
3268: NEWFNODE(r,2); r->id = I_NARYOP;
3269: FA0(r) = mulfs; MKNODE(n,f,0); FA1(r) = n;
1.72 noro 3270: return r;
3271: }
3272:
1.108 noro 3273: FNODE nfnode_mul_coef(Obj c,FNODE f,int expand)
1.72 noro 3274: {
1.76 noro 3275: FNODE b1,cc;
1.108 noro 3276: Obj c1,c2;
1.76 noro 3277: NODE n,r,r0;
1.72 noro 3278:
3279: if ( !c )
3280: return mkfnode(I_FORMULA,0);
1.75 noro 3281: else {
3282: fnode_coef_body(f,&c1,&b1);
1.108 noro 3283: arf_mul(CO,c,c1,&c2);
1.75 noro 3284: if ( UNIQ(c2) ) return b1;
3285: else {
3286: cc = mkfnode(1,I_FORMULA,c2);
3287: if ( fnode_is_number(b1) ) {
3288: if ( !fnode_is_one(b1) )
1.95 noro 3289: error("nfnode_mul_coef : cannot happen");
1.75 noro 3290: else
3291: return cc;
1.76 noro 3292: } else if ( IS_NARYMUL(b1) ) {
1.75 noro 3293: MKNODE(n,cc,FA1(b1));
1.106 noro 3294: return fnode_node_to_nary(mulfs,n);
1.76 noro 3295: } else if ( expand && IS_NARYADD(b1) ) {
3296: for ( r0 = 0, n = (NODE)FA1(b1); n; n = NEXT(n) ) {
3297: NEXTNODE(r0,r);
1.95 noro 3298: BDY(r) = nfnode_mul_coef(c2,BDY(n),expand);
1.76 noro 3299: }
3300: if ( r0 ) NEXT(r) = 0;
1.106 noro 3301: return fnode_node_to_nary(addfs,r0);
1.76 noro 3302: } else
1.106 noro 3303: return fnode_node_to_nary(mulfs,mknode(2,cc,b1));
1.72 noro 3304: }
1.71 noro 3305: }
3306: }
3307:
1.108 noro 3308: void fnode_coef_body(FNODE f,Obj *cp,FNODE *bp)
1.70 noro 3309: {
1.72 noro 3310: FNODE c;
1.70 noro 3311:
1.108 noro 3312: if ( fnode_is_coef(f) ) {
3313: *cp = (Obj)eval(f); *bp = mkfnode(1,I_FORMULA,ONE);
1.75 noro 3314: } else if ( IS_NARYMUL(f) ) {
3315: c=(FNODE)BDY((NODE)FA1(f));
1.108 noro 3316: if ( fnode_is_coef(c) ) {
3317: *cp = (Obj)eval(c);
1.106 noro 3318: *bp = fnode_node_to_nary(mulfs,NEXT((NODE)FA1(f)));
1.70 noro 3319: } else {
1.108 noro 3320: *cp = (Obj)ONE; *bp = f;
1.70 noro 3321: }
3322: } else {
1.108 noro 3323: *cp = (Obj)ONE; *bp = f;
1.70 noro 3324: }
1.80 noro 3325: }
3326:
1.109 noro 3327: int nfnode_weight(struct wtab *tab,FNODE f)
3328: {
3329: NODE n;
3330: int w,w1;
3331: int i;
3332: Q a2;
3333: V v;
3334:
3335: switch ( f->id ) {
3336: case I_FORMULA:
3337: if ( fnode_is_coef(f) ) return 0;
3338: else if ( fnode_is_var(f) ) {
1.113 noro 3339: if ( !tab ) return 0;
1.109 noro 3340: v = VR((P)FA0(f));
3341: for ( i = 0; tab[i].v; i++ )
3342: if ( v == tab[i].v ) return tab[i].w;
1.113 noro 3343: return 0;
1.109 noro 3344: } else return 0;
3345:
3346: /* XXX */
3347: case I_PVAR: return 1;
3348: /* XXX */
3349: case I_FUNC: I_FUNC: I_FUNC_QARG:
3350: /* w(f) = 1 */
3351: /* w(f(a1,...,an)=w(a1)+...+w(an) */
3352: n = FA0((FNODE)FA1(f));
3353: for ( w = 0; n; n = NEXT(n) )
3354: w += nfnode_weight(tab,BDY(n));
3355: return w;
3356: case I_NARYOP:
3357: n = (NODE)FA1(f);
3358: if ( IS_NARYADD(f) )
3359: for ( w = nfnode_weight(tab,BDY(n)),
3360: n = NEXT(n); n; n = NEXT(n) ) {
3361: w1 = nfnode_weight(tab,BDY(n));
3362: w = MAX(w,w1);
3363: }
3364: else
3365: for ( w = 0; n; n = NEXT(n) )
3366: w += nfnode_weight(tab,BDY(n));
3367: return w;
3368: case I_BOP:
3369: /* must be binary power */
3370: /* XXX w(2^x)=0 ? */
3371: if ( fnode_is_rational(FA2(f)) ) {
3372: a2 = (Q)eval(FA2(f));
3373: w = QTOS(a2);
3374: } else
3375: w = nfnode_weight(tab,FA2(f));
3376: return nfnode_weight(tab,FA1(f))*w;
3377: default:
3378: error("nfnode_weight : not_implemented");
3379: }
3380: }
3381:
1.95 noro 3382: int nfnode_comp(FNODE f1,FNODE f2)
1.80 noro 3383: {
1.109 noro 3384: int w1,w2;
3385:
3386: if ( qt_weight_tab ) {
3387: w1 = nfnode_weight(qt_weight_tab,f1);
3388: w2 = nfnode_weight(qt_weight_tab,f2);
3389: if ( w1 > w2 ) return 1;
3390: if ( w1 < w2 ) return -1;
3391: }
1.110 noro 3392: return nfnode_comp_lex(f1,f2);
3393: }
3394:
3395: int nfnode_comp_lex(FNODE f1,FNODE f2)
3396: {
3397: NODE n1,n2;
3398: int r,i1,i2,ret;
3399: char *nm1,*nm2;
1.114 noro 3400: FNODE b1,b2,e1,e2,g,a1,a2,fn1,fn2,h1,h2;
1.110 noro 3401: Num ee,ee1;
3402: Obj c1,c2;
3403: int w1,w2;
1.80 noro 3404:
3405: if ( IS_NARYADD(f1) || IS_NARYADD(f2) ) {
3406: f1 = to_naryadd(f1); f2 = to_naryadd(f2);
3407: n1 = (NODE)FA1(f1); n2 = (NODE)FA1(f2);
1.114 noro 3408: for ( ; n1 && n2; n1 = NEXT(n1), n2 = NEXT(n2) ) {
3409: r = nfnode_comp_lex(BDY(n1),BDY(n2));
3410: if ( r ) return r;
3411: }
3412: if ( !n1 && !n2 ) return 0;
3413: h1 = n1 ? (FNODE)BDY(n1) : mkfnode(1,I_FORMULA,0);
3414: h2 = n2 ? (FNODE)BDY(n2) : mkfnode(1,I_FORMULA,0);
3415: return nfnode_comp_lex(h1,h2);
1.80 noro 3416: }
3417: if ( IS_NARYMUL(f1) || IS_NARYMUL(f2) ) {
1.83 noro 3418: fnode_coef_body(f1,&c1,&b1);
3419: fnode_coef_body(f2,&c2,&b2);
1.108 noro 3420: if ( !compfnode(b1,b2) ) return arf_comp(CO,c1,c2);
1.83 noro 3421: b1 = to_narymul(b1); b2 = to_narymul(b2);
3422: n1 = (NODE)FA1(b1); n2 = (NODE)FA1(b2);
1.114 noro 3423: for ( ; n1 && n2; n1 = NEXT(n1), n2 = NEXT(n2) ) {
3424: r = nfnode_comp_lex(BDY(n1),BDY(n2));
3425: if ( r ) return r;
3426: }
3427: if ( !n1 && !n2 ) return 0;
3428: h1 = n1 ? (FNODE)BDY(n1) : mkfnode(1,I_FORMULA,ONE);
3429: h2 = n2 ? (FNODE)BDY(n2) : mkfnode(1,I_FORMULA,ONE);
3430: return nfnode_comp_lex(h1,h2);
1.80 noro 3431: }
1.110 noro 3432: if ( IS_BINARYPWR(f1) || IS_BINARYPWR(f2) ) {
3433: fnode_base_exp(f1,&b1,&e1);
3434: fnode_base_exp(f2,&b2,&e2);
3435: if ( r = nfnode_comp_lex(b1,b2) ) {
3436: if ( r > 0 )
3437: return nfnode_comp_lex(e1,mkfnode(1,I_FORMULA,0));
3438: else if ( r < 0 )
3439: return nfnode_comp_lex(mkfnode(1,I_FORMULA,0),e2);
3440: } else return nfnode_comp_lex(e1,e2);
3441: }
1.80 noro 3442:
1.95 noro 3443: /* now, IDs of f1 and f2 must be I_FORMULA, I_FUNC, I_IFUNC or I_PVAR */
1.106 noro 3444: /* I_IFUNC > I_PVAR > I_FUNC=I_FUNC_QARG > I_FORMULA */
1.80 noro 3445: switch ( f1->id ) {
3446: case I_FORMULA:
3447: switch ( f2->id ) {
3448: case I_FORMULA:
1.105 noro 3449: return arf_comp(qt_current_ord?qt_current_ord:CO,FA0(f1),FA0(f2));
1.95 noro 3450: case I_FUNC: case I_IFUNC: case I_PVAR:
1.80 noro 3451: return -1;
3452: default:
1.110 noro 3453: error("nfnode_comp_lex : undefined");
1.80 noro 3454: }
3455: break;
1.106 noro 3456: case I_FUNC: case I_FUNC_QARG:
1.80 noro 3457: switch ( f2->id ) {
3458: case I_FORMULA:
3459: return 1;
1.95 noro 3460: case I_PVAR: case I_IFUNC:
3461: return -1;
1.106 noro 3462: case I_FUNC: case I_FUNC_QARG:
1.82 noro 3463: nm1 = ((FUNC)FA0(f1))->name; nm2 = ((FUNC)FA0(f2))->name;
3464: r = strcmp(nm1,nm2);
3465: if ( r > 0 ) return 1;
3466: else if ( r < 0 ) return -1;
1.80 noro 3467: else {
3468: /* compare args */
3469: n1 = FA0((FNODE)FA1(f1)); n2 = FA0((FNODE)FA1(f2));
3470: while ( n1 && n2 )
1.110 noro 3471: if ( r = nfnode_comp_lex(BDY(n1),BDY(n2)) ) return r;
1.82 noro 3472: else {
3473: n1 = NEXT(n1); n2 = NEXT(n2);
3474: }
1.85 noro 3475: return n1?1:(n2?-1:0);
1.80 noro 3476: }
3477: break;
3478: default:
1.110 noro 3479: error("nfnode_comp_lex : undefined");
1.80 noro 3480: }
3481: case I_PVAR:
3482: switch ( f2->id ) {
1.106 noro 3483: case I_FORMULA: case I_FUNC: case I_FUNC_QARG:
1.80 noro 3484: return 1;
1.95 noro 3485: case I_IFUNC:
3486: return -1;
1.80 noro 3487: case I_PVAR:
3488: i1 = (int)FA0(f1); i2 = (int)FA0(f2);
3489: if ( i1 > i2 ) return 1;
3490: else if ( i1 < i2 ) return -1;
3491: else return 0;
3492: default:
1.110 noro 3493: error("nfnode_comp_lex : undefined");
1.95 noro 3494: }
3495: break;
3496: case I_IFUNC:
3497: switch ( f2->id ) {
1.106 noro 3498: case I_FORMULA: case I_FUNC: case I_FUNC_QARG: case I_PVAR:
1.95 noro 3499: return 1;
3500: case I_IFUNC:
3501: i1 = (int)FA0((FNODE)FA0(f1));
3502: i2 = (int)FA0((FNODE)FA0(f2));
3503: if ( i1 > i2 ) return 1;
3504: else if ( i1 < i2 ) return -1;
3505: else {
3506: /* compare args */
3507: n1 = FA0((FNODE)FA1(f1)); n2 = FA0((FNODE)FA1(f2));
3508: while ( n1 && n2 )
1.110 noro 3509: if ( r = nfnode_comp_lex(BDY(n1),BDY(n2)) ) return r;
1.95 noro 3510: else {
3511: n1 = NEXT(n1); n2 = NEXT(n2);
3512: }
3513: return n1?1:(n2?-1:0);
3514: }
3515: break;
3516:
3517: default:
1.110 noro 3518: error("nfnode_comp_lex : undefined");
1.80 noro 3519: }
3520: break;
3521: default:
1.110 noro 3522: error("nfnode_comp_lex : undefined");
1.80 noro 3523: }
1.70 noro 3524: }
1.87 noro 3525:
1.88 noro 3526: NODE append_node(NODE a1,NODE a2)
3527: {
3528: NODE t,t0;
3529:
3530: if ( !a1 )
3531: return a2;
3532: else {
3533: for ( t0 = 0; a1; a1 = NEXT(a1) ) {
3534: NEXTNODE(t0,t); BDY(t) = BDY(a1);
3535: }
3536: NEXT(t) = a2;
3537: return t0;
3538: }
3539: }
3540:
1.95 noro 3541: int nfnode_match(FNODE f,FNODE pat,NODE *rp)
1.87 noro 3542: {
3543: NODE m,m1,m2,base,exp,fa,pa,n;
3544: LIST l;
3545: QUOTE qp,qf;
1.96 noro 3546: FNODE fbase,fexp,a,fh;
1.87 noro 3547: FUNC ff,pf;
3548: int r;
3549:
1.97 noro 3550: if ( !pat )
3551: if ( !f ) {
3552: *rp = 0;
3553: return 1;
3554: } else
3555: return 0;
3556: else if ( !f )
3557: return 0;
1.87 noro 3558: switch ( pat->id ) {
3559: case I_PVAR:
3560: /* [[pat,f]] */
1.103 noro 3561: *rp = mknode(1,mknode(2,(int)FA0(pat),f));
1.87 noro 3562: return 1;
3563:
3564: case I_FORMULA:
1.93 noro 3565: if ( f->id == I_FORMULA && !arf_comp(CO,(Obj)FA0(f),(Obj)FA0(pat)) ) {
1.87 noro 3566: *rp = 0; return 1;
3567: } else
3568: return 0;
3569:
3570: case I_BOP:
3571: /* OPNAME should be "^" */
3572: if ( !IS_BINARYPWR(pat) )
1.95 noro 3573: error("nfnode_match : invalid BOP");
1.87 noro 3574: if ( IS_BINARYPWR(f) ) {
3575: fbase = FA1(f); fexp = FA2(f);
3576: } else {
3577: fbase = f; fexp = mkfnode(1,I_FORMULA,ONE);
3578: }
1.95 noro 3579: if ( !nfnode_match(fbase,FA1(pat),&base) ) return 0;
1.106 noro 3580: a = rewrite_fnode(FA2(pat),base,0);
1.95 noro 3581: if ( !nfnode_match(fexp,a,&exp) ) return 0;
1.88 noro 3582: else {
3583: *rp = append_node(base,exp);
3584: return 1;
3585: }
1.87 noro 3586: break;
3587:
1.95 noro 3588: case I_FUNC: case I_IFUNC:
1.87 noro 3589: if ( f->id != I_FUNC ) return 0;
1.95 noro 3590: ff = (FUNC)FA0(f);
3591: if ( pat->id == I_FUNC ) {
3592: pf = (FUNC)FA0(pat);
3593: if ( strcmp(ff->fullname,pf->fullname) ) return 0;
3594: m = 0;
3595: } else {
1.96 noro 3596: /* XXX : I_FUNC_HEAD is a dummy id to pass FUNC */
3597: fh = mkfnode(1,I_FUNC_HEAD,FA0(f));
3598: m = mknode(1,mknode(2,FA0((FNODE)FA0(pat)),fh),0);
1.95 noro 3599: }
1.87 noro 3600: /* FA1(f) and FA1(pat) are I_LIST */
3601: fa = (NODE)FA0((FNODE)FA1(f));
3602: pa = (NODE)FA0((FNODE)FA1(pat));
3603: while ( fa && pa ) {
1.106 noro 3604: a = rewrite_fnode(BDY(pa),m,0);
1.95 noro 3605: if ( !nfnode_match(BDY(fa),a,&m1) ) return 0;
1.88 noro 3606: m = append_node(m1,m);
3607: fa = NEXT(fa); pa = NEXT(pa);
1.87 noro 3608: }
3609: if ( fa || pa ) return 0;
3610: else {
3611: *rp = m;
3612: return 1;
3613: }
3614:
3615: case I_NARYOP:
3616: if ( IS_NARYADD(pat) )
1.95 noro 3617: return nfnode_match_naryadd(f,pat,rp);
1.87 noro 3618: else if ( IS_NARYMUL(pat) )
1.95 noro 3619: return nfnode_match_narymul(f,pat,rp);
1.87 noro 3620: else
1.95 noro 3621: error("nfnode_match : invalid NARYOP");
1.87 noro 3622: break;
3623:
3624: default:
1.95 noro 3625: error("nfnode_match : invalid pattern");
1.87 noro 3626: }
3627: }
3628:
1.88 noro 3629: /* remove i-th element */
1.87 noro 3630:
1.88 noro 3631: FNODE fnode_removeith_naryadd(FNODE p,int i)
3632: {
3633: int k,l;
3634: NODE t,r0,r,a;
3635:
3636: a = (NODE)FA1(p);
3637: l = length(a);
3638: if ( i < 0 || i >= l ) error("fnode_removeith_naryadd: invalid index");
3639: else if ( i == 0 )
1.106 noro 3640: return fnode_node_to_nary(addfs,NEXT(a));
1.88 noro 3641: else {
3642: for ( r0 = 0, k = 0, t = a; k < i; k++, t = NEXT(t) ) {
3643: NEXTNODE(r0,r);
3644: BDY(r) = BDY(t);
3645: }
1.94 noro 3646: NEXT(r) = NEXT(t);
1.106 noro 3647: return fnode_node_to_nary(addfs,r0);
1.88 noro 3648: }
3649:
3650: }
1.87 noro 3651:
1.88 noro 3652: /* a0,...,a(i-1) */
3653: FNODE fnode_left_narymul(FNODE p,int i)
1.87 noro 3654: {
1.88 noro 3655: int k,l;
3656: NODE t,r0,r,a;
3657:
3658: a = (NODE)FA1(p);
3659: l = length(a);
3660: if ( i < 0 || i >= l ) error("fnode_left_narymul : invalid index");
1.97 noro 3661: if ( i == 0 ) return 0;
1.88 noro 3662: else if ( i == 1 ) return (FNODE)BDY(a);
3663: else {
3664: for ( r0 = 0, k = 0, t = a; k < i; k++, t = NEXT(t) ) {
3665: NEXTNODE(r0,r);
3666: BDY(r) = BDY(t);
3667: }
3668: NEXT(r) = 0;
1.106 noro 3669: return fnode_node_to_nary(mulfs,r0);
1.88 noro 3670: }
3671: }
3672:
3673: /* a(i+1),...,a(l-1) */
3674: FNODE fnode_right_narymul(FNODE p,int i)
3675: {
3676: NODE a,t;
3677: int l,k;
3678:
3679: a = (NODE)FA1(p);
3680: l = length(a);
3681: if ( i < 0 || i >= l ) error("fnode_right_narymul : invalid index");
1.97 noro 3682: if ( i == l-1 ) return 0;
1.88 noro 3683: else {
3684: for ( k = 0, t = a; k <= i; k++, t = NEXT(t) );
1.106 noro 3685: return fnode_node_to_nary(mulfs,t);
1.88 noro 3686: }
3687: }
3688:
1.95 noro 3689: int nfnode_match_naryadd(FNODE f,FNODE p,NODE *rp)
1.88 noro 3690: {
3691: int fl,pl,fi,pi;
3692: NODE fa,pa,t,s,m,m1;
3693: FNODE fr,pr,prr,pivot;
1.87 noro 3694:
3695: f = to_naryadd(f);
1.88 noro 3696: fa = (NODE)FA1(f); fl = length(fa);
3697: pa = (NODE)FA1(p); pl = length(pa);
3698: if ( fl < pl ) return 0;
3699: else if ( pl == 1 ) {
3700: if ( fl == 1 )
1.95 noro 3701: return nfnode_match(BDY(fa),BDY(pa),rp);
1.87 noro 3702: else
3703: return 0;
3704: } else {
1.88 noro 3705: for ( t = pa, pi = 0; t; t = NEXT(t), pi++ )
3706: if ( ((FNODE)BDY(t))->id != I_PVAR ) break;
3707: if ( !t ) {
3708: /* all are I_PVAR */
3709: m = 0;
3710: for ( t = pa, s = fa; NEXT(t); t = NEXT(t), s = NEXT(s) ) {
1.95 noro 3711: nfnode_match(BDY(s),BDY(t),&m1);
1.88 noro 3712: m = append_node(m1,m);
3713: }
3714: if ( !NEXT(s) )
3715: fr = (FNODE)BDY(s);
3716: else
3717: fr = mkfnode(2,I_NARYOP,FA0(f),s);
1.95 noro 3718: nfnode_match(fr,BDY(t),&m1);
1.88 noro 3719: *rp = append_node(m1,m);
3720: return 1;
3721: } else {
3722: pivot = (FNODE)BDY(t);
3723: pr = fnode_removeith_naryadd(p,pi);
3724: for ( s = fa, fi = 0; s; s = NEXT(s), fi++ ) {
1.95 noro 3725: if ( nfnode_match(BDY(s),pivot,&m) ) {
1.88 noro 3726: fr = fnode_removeith_naryadd(f,fi);
1.106 noro 3727: prr = rewrite_fnode(pr,m,0);
1.95 noro 3728: if ( nfnode_match(fr,prr,&m1) ) {
1.88 noro 3729: *rp = append_node(m,m1);
3730: return 1;
3731: }
3732: }
3733: }
3734: return 0;
3735: }
1.87 noro 3736: }
3737: }
3738:
1.95 noro 3739: int nfnode_match_narymul(FNODE f,FNODE p,NODE *rp)
1.88 noro 3740: {
3741: int fl,pl,fi,pi;
3742: NODE fa,pa,t,s,m,m1;
3743: FNODE fr,pr,pleft,pleft1,pright,pright1,fleft,fright,pivot;
3744:
3745: f = to_narymul(f);
3746: fa = (NODE)FA1(f); fl = length(fa);
3747: pa = (NODE)FA1(p); pl = length(pa);
3748: if ( fl < pl ) return 0;
3749: else if ( pl == 1 ) {
3750: if ( fl == 1 )
1.95 noro 3751: return nfnode_match(BDY(fa),BDY(pa),rp);
1.88 noro 3752: else
3753: return 0;
3754: } else {
3755: for ( t = pa, pi = 0; t; t = NEXT(t), pi++ )
3756: if ( ((FNODE)BDY(t))->id != I_PVAR ) break;
3757: if ( !t ) {
3758: /* all are I_PVAR */
3759: m = 0;
3760: for ( t = pa, s = fa; NEXT(t); t = NEXT(t), s = NEXT(s) ) {
1.106 noro 3761: pr = rewrite_fnode(BDY(t),m,0);
1.95 noro 3762: if ( !nfnode_match(BDY(s),pr,&m1) ) return 0;
1.88 noro 3763: m = append_node(m1,m);
3764: }
3765: if ( !NEXT(s) )
3766: fr = (FNODE)BDY(s);
3767: else
3768: fr = mkfnode(2,I_NARYOP,FA0(f),s);
1.106 noro 3769: pr = rewrite_fnode(BDY(t),m,0);
1.95 noro 3770: if ( !nfnode_match(fr,pr,&m1) ) return 0;
1.88 noro 3771: *rp = append_node(m1,m);
3772: return 1;
3773: } else {
3774: pivot = (FNODE)BDY(t);
3775: pleft = fnode_left_narymul(p,pi);
3776: pright = fnode_right_narymul(p,pi);
3777: /* XXX : incomplete */
3778: for ( s = fa, fi = 0; s; s = NEXT(s), fi++ ) {
1.97 noro 3779: if ( fi < pi ) continue;
1.95 noro 3780: if ( nfnode_match(BDY(s),pivot,&m) ) {
1.88 noro 3781: fleft = fnode_left_narymul(f,fi);
1.106 noro 3782: pleft1 = rewrite_fnode(pleft,m,0);
1.95 noro 3783: if ( nfnode_match(fleft,pleft1,&m1) ) {
1.88 noro 3784: m = append_node(m1,m);
3785: fright = fnode_right_narymul(f,fi);
1.106 noro 3786: pright1 = rewrite_fnode(pright,m,0);
1.95 noro 3787: if ( nfnode_match(fright,pright1,&m1) ) {
1.88 noro 3788: *rp = append_node(m1,m);
3789: return 1;
3790: }
3791: }
3792: }
3793: }
3794: return 0;
3795: }
1.95 noro 3796: }
3797: }
3798:
3799: NODE nfnode_pvars(FNODE pat,NODE found)
3800: {
3801: int ind;
3802: NODE prev,t;
3803: int *pair;
3804:
3805: switch ( pat->id ) {
3806: case I_PVAR:
3807: ind = (int)FA0(pat);
3808: for ( prev = 0, t = found; t; prev = t, t = NEXT(t) ) {
3809: pair = (int *)BDY(t);
3810: if ( pair[0] == ind ) {
3811: pair[1]++;
3812: return found;
3813: }
3814: }
3815: pair = (int *)MALLOC_ATOMIC(sizeof(int)*2);
3816: pair[0] = ind; pair[1] = 1;
3817: if ( !prev )
3818: MKNODE(found,pair,0);
3819: else
3820: MKNODE(NEXT(prev),pair,0);
3821: return found;
3822:
3823: case I_FORMULA:
3824: return found;
3825:
3826: case I_BOP:
3827: /* OPNAME should be "^" */
3828: if ( !IS_BINARYPWR(pat) )
3829: error("nfnode_pvar : invalid BOP");
3830: found = nfnode_pvars(FA1(pat),found);
3831: found = nfnode_pvars(FA2(pat),found);
3832: return found;
3833:
3834: case I_FUNC:
3835: t = (NODE)FA0((FNODE)FA1(pat));
3836: for ( ; t; t = NEXT(t) )
3837: found = nfnode_pvars(BDY(t),found);
3838: return found;
3839:
3840: case I_NARYOP:
3841: t = (NODE)FA1(pat);
3842: for ( ; t; t = NEXT(t) )
3843: found = nfnode_pvars(BDY(t),found);
3844: return found;
3845:
3846: default:
3847: error("nfnode_match : invalid pattern");
1.88 noro 3848: }
3849: }