[BACK]Return to strobj.c CVS log [TXT][DIR] Up to [local] / OpenXM_contrib2 / asir2000 / builtin

Annotation of OpenXM_contrib2/asir2000/builtin/strobj.c, Revision 1.101

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>