=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/strobj.c,v retrieving revision 1.81 retrieving revision 1.87 diff -u -p -r1.81 -r1.87 --- OpenXM_contrib2/asir2000/builtin/strobj.c 2005/10/26 07:33:03 1.81 +++ OpenXM_contrib2/asir2000/builtin/strobj.c 2005/10/31 10:03:48 1.87 @@ -45,7 +45,7 @@ * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE, * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE. * - * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.80 2005/10/26 02:58:25 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.86 2005/10/26 23:43:23 noro Exp $ */ #include "ca.h" #include "parse.h" @@ -127,7 +127,7 @@ struct ftab str_tab[] = { {"quote_is_dependent",Pquote_is_dependent,2}, {"quote_normalize",Pquote_normalize,-2}, - {"quote_normalize_comp",Pquote_normalize_comp,2,0x3}, + {"quote_normalize_comp",Pquote_normalize_comp,2}, {"quote_to_nary",Pquote_to_nary,1}, {"quote_to_bin",Pquote_to_bin,2}, @@ -1942,22 +1942,27 @@ void Pquote_normalize(NODE arg,QUOTE *rp) if ( !q || OID(q) != O_QUOTE ) { *rp = q; return; - } else { + } else if ( q->normalized && (q->expanded || !expand) ) + *rp = q; + else { f = fnode_normalize(BDY(q),expand); MKQUOTE(r,f); + r->normalized = 1; + if ( expand ) r->expanded = 1; *rp = r; } } void Pquote_normalize_comp(NODE arg,Q *rp) { + QUOTE q1,q2; FNODE f1,f2; int r; - f1 = BDY((QUOTE)ARG0(arg)); - f2 = BDY((QUOTE)ARG1(arg)); - f1 = fnode_normalize(f1,0); - f2 = fnode_normalize(f2,0); + q1 = (QUOTE)ARG0(arg); f1 = (FNODE)BDY(q1); + q2 = (QUOTE)ARG1(arg); f2 = (FNODE)BDY(q2); + if ( !q1->normalized ) f1 = fnode_normalize(f1,0); + if ( !q2->normalized ) f2 = fnode_normalize(f2,0); r = fnode_normalize_comp(f1,f2); STOQ(r,*rp); } @@ -2364,7 +2369,8 @@ FNODE fnode_normalize_pwr(FNODE f1,FNODE f2,int expand return b; else return fnode_node_to_narymul(mknode(2,cc,b)); - } else if ( expand && fnode_is_nonnegative_integer(f2) ) { + } else if ( expand && fnode_is_integer(f2) + && fnode_is_nonnegative_integer(f2) ) { q = (Q)eval(f2); if ( PL(NM(q)) > 1 ) error("fnode_normalize_pwr : exponent too large"); return fnode_expand_pwr(f1,QTOS(q)); @@ -2483,15 +2489,10 @@ int fnode_normalize_comp(FNODE f1,FNODE f2) { NODE n1,n2; int r,i1,i2; - FUNC fp1,fp2; + char *nm1,*nm2; FNODE b1,b2,e1,e2,g; - Num ee,ee1; + Num ee,ee1,c1,c2; - if ( IS_ZERO(f1) ) - if ( IS_ZERO(f2) ) return 0; - else return -1; - else if ( IS_ZERO(f2) ) return 1; - if ( IS_NARYADD(f1) || IS_NARYADD(f2) ) { f1 = to_naryadd(f1); f2 = to_naryadd(f2); n1 = (NODE)FA1(f1); n2 = (NODE)FA1(f2); @@ -2500,45 +2501,48 @@ int fnode_normalize_comp(FNODE f1,FNODE f2) else { n1 = NEXT(n1); n2 = NEXT(n2); } - if ( n1 ) return 1; - else if ( n2 ) return -1; - else return 0; + return n1?1:(n2?-1:0); } if ( IS_NARYMUL(f1) || IS_NARYMUL(f2) ) { - f1 = to_narymul(f1); f2 = to_narymul(f2); - n1 = (NODE)FA1(f1); n2 = (NODE)FA1(f2); + fnode_coef_body(f1,&c1,&b1); + fnode_coef_body(f2,&c2,&b2); + if ( !compfnode(b1,b2) ) return compnum(0,c1,c2); + b1 = to_narymul(b1); b2 = to_narymul(b2); + n1 = (NODE)FA1(b1); n2 = (NODE)FA1(b2); while ( 1 ) { while ( n1 && n2 && !compfnode(BDY(n1),BDY(n2)) ) { n1 = NEXT(n1); n2 = NEXT(n2); } if ( !n1 || !n2 ) { - if ( n1 ) return 1; - else if ( n2 ) return -1; - else return 0; + return n1?1:(n2?-1:0); } fnode_base_exp(BDY(n1),&b1,&e1); fnode_base_exp(BDY(n2),&b2,&e2); - n1 = NEXT(n1); n2 = NEXT(n2); - if ( r = fnode_normalize_comp(b1,b2) ) return r; - else if ( fnode_is_number(e1) && fnode_is_number(e2) ) { - /* f1 = t b^e1 ... , f2 = t b^e2 ... */ - subnum(0,eval(e1),eval(e2),&ee); - r = compnum(0,ee,0); - if ( r > 0 ) { - /* e1>e2 */ - g = mkfnode(3,I_BOP,pwrfs,b1,mkfnode(1,I_FORMULA,ee)); - MKNODE(n1,g,n1); - } else if ( r < 0 ) { - /* e1 0 ) + return fnode_normalize_comp(e1,mkfnode(1,I_FORMULA,0)); + else if ( r < 0 ) + return fnode_normalize_comp(mkfnode(1,I_FORMULA,0),e2); } else { - r = fnode_normalize_comp(e1,e2); - if ( r > 0 ) return 1; - else if ( r < 0 ) return -1; + n1 = NEXT(n1); n2 = NEXT(n2); + if ( fnode_is_number(e1) && fnode_is_number(e2) ) { + /* f1 = t b^e1 ... , f2 = t b^e2 ... */ + subnum(0,eval(e1),eval(e2),&ee); + r = compnum(0,ee,0); + if ( r > 0 ) { + g = mkfnode(3,I_BOP,pwrfs,b1,mkfnode(1,I_FORMULA,ee)); + MKNODE(n1,g,n1); + } else if ( r < 0 ) { + chsgnnum(ee,&ee1); + g = mkfnode(3,I_BOP,pwrfs,b1,mkfnode(1,I_FORMULA,ee1)); + MKNODE(n2,g,n2); + } + } else { + r = fnode_normalize_comp(e1,e2); + if ( r > 0 ) return 1; + else if ( r < 0 ) return -1; + } } } } @@ -2562,18 +2566,19 @@ int fnode_normalize_comp(FNODE f1,FNODE f2) case I_FORMULA: return 1; case I_FUNC: - fp1 = (FUNC)FA0(f1); fp2 = (FUNC)FA0(f2); - if ( fp1 > fp2 ) return 1; - else if ( fp1 < fp2 ) return -1; + nm1 = ((FUNC)FA0(f1))->name; nm2 = ((FUNC)FA0(f2))->name; + r = strcmp(nm1,nm2); + if ( r > 0 ) return 1; + else if ( r < 0 ) return -1; else { /* compare args */ n1 = FA0((FNODE)FA1(f1)); n2 = FA0((FNODE)FA1(f2)); while ( n1 && n2 ) - if ( r = fnode_normalize_comp(BDY(n1),BDY(n2)) ) - return r; - if ( n1 ) return 1; - else if ( n2 ) return -1; - else return 0; + if ( r = fnode_normalize_comp(BDY(n1),BDY(n2)) ) return r; + else { + n1 = NEXT(n1); n2 = NEXT(n2); + } + return n1?1:(n2?-1:0); } break; case I_PVAR: @@ -2606,6 +2611,111 @@ int fnode_normalize_comp_pwr(FNODE f1,FNODE f2) fnode_base_exp(f1,&b1,&e1); fnode_base_exp(f2,&b2,&e2); - if ( r = fnode_normalize_comp(b1,b2) ) return r; - else return fnode_normalize_comp(e1,e2); + if ( r = fnode_normalize_comp(b1,b2) ) { + if ( r > 0 ) + return fnode_normalize_comp(e1,mkfnode(1,I_FORMULA,0)); + else if ( r < 0 ) + return fnode_normalize_comp(mkfnode(1,I_FORMULA,0),e2); + } else return fnode_normalize_comp(e1,e2); } + +int fnode_normalize_unify(FNODE f,FNODE pat,NODE *rp) +{ + NODE m,m1,m2,base,exp,fa,pa,n; + LIST l; + QUOTE qp,qf; + FNODE fbase,fexp; + FUNC ff,pf; + int r; + + switch ( pat->id ) { + case I_PVAR: + /* [[pat,f]] */ + MKQUOTE(qf,f); + MKQUOTE(qp,pat); + n = mknode(2,qp,qf); MKLIST(l,n); + *rp = mknode(1,l); + return 1; + + case I_FORMULA: + if ( !arf_comp(CO,(Obj)FA0(f),(Obj)FA0(pat)) ) { + *rp = 0; return 1; + } else + return 0; + + case I_BOP: + /* OPNAME should be "^" */ + if ( !IS_BINARYPWR(pat) ) + error("fnode_normalize_unify : invalid BOP"); + if ( IS_BINARYPWR(f) ) { + fbase = FA1(f); fexp = FA2(f); + } else { + fbase = f; fexp = mkfnode(1,I_FORMULA,ONE); + } + r = fnode_normalize_unify(fbase,FA1(pat),&base); + if ( !r ) return 0; + r = fnode_normalize_unify(fexp,FA2(pat),&exp); + if ( !r ) return 0; + else return merge_matching_node(base,exp,rp); + break; + + case I_FUNC: + if ( f->id != I_FUNC ) return 0; + ff = (FUNC)FA0(f); pf = (FUNC)FA0(pat); + if ( strcmp(ff->fullname,pf->fullname) ) return 0; + /* FA1(f) and FA1(pat) are I_LIST */ + fa = (NODE)FA0((FNODE)FA1(f)); + pa = (NODE)FA0((FNODE)FA1(pat)); + m = 0; + while ( fa && pa ) { + r = fnode_normalize_unify(BDY(fa),BDY(pa),&m1); + if ( !r ) return 0; + r = merge_matching_node(m,m1,&m2); + if ( !r ) return 0; + else m = m2; + } + if ( fa || pa ) return 0; + else { + *rp = m; + return 1; + } + + case I_NARYOP: + if ( IS_NARYADD(pat) ) + return fnode_normalize_unify_naryadd(f,pat,rp); + else if ( IS_NARYMUL(pat) ) + return fnode_normalize_unify_narymul(f,pat,rp); + else + error("fnode_normalize_unify : invalid NARYOP"); + break; + + default: + error("fnode_normalize_unify : invalid pattern"); + } +} + +int fnode_normalize_unify_naryadd(FNODE f,FNODE pat,NODE *rp){} + +int fnode_normalize_unify_narymul(FNODE f,FNODE pat,NODE *rp){} + +/* +int fnode_normalize_unify_naryadd(FNODE f,FNODE pat,NODE *rp) +{ + int lf,lp; + + f = to_naryadd(f); + lf = length((NODE)FA1(f)); + lp = length((NODE)FA1(pat)); + if ( lf < lp ) return 0; + else if ( lp == 1 ) { + if ( lf == 1 ) + return fnode_normalize_unify( + BDY((NODE)FA1(f)),BDY((NODE)FA1(pat)),rp); + else + return 0; + } else { + sel = (int *)ALLOCA(lf); + } +} +*/ +