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