=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/strobj.c,v retrieving revision 1.84 retrieving revision 1.88 diff -u -p -r1.84 -r1.88 --- OpenXM_contrib2/asir2000/builtin/strobj.c 2005/10/26 10:47:00 1.84 +++ OpenXM_contrib2/asir2000/builtin/strobj.c 2005/11/01 07:24:11 1.88 @@ -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.83 2005/10/26 10:44:50 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.87 2005/10/31 10:03:48 noro Exp $ */ #include "ca.h" #include "parse.h" @@ -88,10 +88,12 @@ void Pquote_is_integer(),Pquote_is_rational(),Pquote_i void Pquote_is_dependent(),Pquote_is_function(); void Pquote_normalize(); void Pquote_normalize_comp(); +void Pquote_normalize_unify(); void Pquote_to_funargs(),Pfunargs_to_quote(),Pget_function_name(); void Pquote_unify(),Pget_quote_id(),Pquote_match_rewrite(); void Pquote_to_nary(),Pquote_to_bin(); +void fnode_do_assign(NODE arg); void do_assign(NODE arg); void fnodetotex_tb(FNODE f,TB tb); char *symbol_name(char *name); @@ -127,7 +129,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}, @@ -137,6 +139,7 @@ struct ftab str_tab[] = { {"flatten_quote",Pflatten_quote,-2}, {"quote_to_funargs",Pquote_to_funargs,1}, {"quote_unify",Pquote_unify,2}, + {"quote_normalize_unify",Pquote_normalize_unify,2}, {"quote_match_rewrite",Pquote_match_rewrite,-4}, {"funargs_to_quote",Pfunargs_to_quote,1}, {"get_function_name",Pget_function_name,1}, @@ -646,6 +649,23 @@ void Pquote_unify(NODE arg,Q *rp) *rp = 0; } +void Pquote_normalize_unify(NODE arg,Q *rp) +{ + QUOTE fq,pq; + FNODE f,p; + int ret; + NODE r; + + fq = (QUOTE)ARG0(arg); Pquote_normalize(mknode(2,fq,0),&fq); f = (FNODE)BDY(fq); + pq = (QUOTE)ARG1(arg); Pquote_normalize(mknode(2,pq,0),&pq); p = (FNODE)BDY(pq); + ret = fnode_normalize_unify(f,p,&r); + if ( ret ) { + fnode_do_assign(r); + *rp = ONE; + } else + *rp = 0; +} + FNODE rewrite_fnode(FNODE,NODE); extern Obj VOIDobj; @@ -704,6 +724,24 @@ void do_assign(NODE arg) } } +/* [[index,fnode],...] */ + +void fnode_do_assign(NODE arg) +{ + NODE t,pair; + int pv; + FNODE f; + QUOTE value; + + for ( t = arg; t; t = NEXT(t) ) { + pair = (NODE)BDY(t); + pv = (int)BDY(pair); + f = (FNODE)(BDY(NEXT(pair))); + MKQUOTE(value,f); + ASSPV(pv,value); + } +} + /* /* consistency check and merge */ @@ -1942,22 +1980,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); } @@ -2496,9 +2539,7 @@ 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) ) { fnode_coef_body(f1,&c1,&b1); @@ -2511,9 +2552,7 @@ int fnode_normalize_comp(FNODE f1,FNODE f2) 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); @@ -2530,14 +2569,12 @@ int fnode_normalize_comp(FNODE f1,FNODE f2) 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 ) { - /* e1id ) { + case I_PVAR: + /* [[pat,f]] */ + *rp = mknode(1,mknode(2,(int)FA0(pat),f),0); + 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); + } + if ( !fnode_normalize_unify(fbase,FA1(pat),&base) ) return 0; + a = rewrite_fnode(FA2(pat),base); + if ( !fnode_normalize_unify(fexp,a,&exp) ) return 0; + else { + *rp = append_node(base,exp); + return 1; + } + 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 ) { + a = rewrite_fnode(BDY(pa),m); + if ( !fnode_normalize_unify(BDY(fa),a,&m1) ) return 0; + m = append_node(m1,m); + fa = NEXT(fa); pa = NEXT(pa); + } + 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"); + } +} + +/* remove i-th element */ + +FNODE fnode_removeith_naryadd(FNODE p,int i) +{ + int k,l; + NODE t,r0,r,a; + + a = (NODE)FA1(p); + l = length(a); + if ( i < 0 || i >= l ) error("fnode_removeith_naryadd: invalid index"); + else if ( i == 0 ) + return fnode_node_to_naryadd(NEXT(a)); + else { + for ( r0 = 0, k = 0, t = a; k < i; k++, t = NEXT(t) ) { + NEXTNODE(r0,r); + BDY(r) = BDY(t); + } + t = NEXT(t); + NEXT(r) = 0; + return fnode_node_to_naryadd(r0); + } + +} + +/* a0,...,a(i-1) */ +FNODE fnode_left_narymul(FNODE p,int i) +{ + int k,l; + NODE t,r0,r,a; + + a = (NODE)FA1(p); + l = length(a); + if ( i < 0 || i >= l ) error("fnode_left_narymul : invalid index"); + if ( i == 0 ) return mkfnode(1,I_FORMULA,ONE); + else if ( i == 1 ) return (FNODE)BDY(a); + else { + for ( r0 = 0, k = 0, t = a; k < i; k++, t = NEXT(t) ) { + NEXTNODE(r0,r); + BDY(r) = BDY(t); + } + NEXT(r) = 0; + return fnode_node_to_narymul(r0); + } +} + +/* a(i+1),...,a(l-1) */ +FNODE fnode_right_narymul(FNODE p,int i) +{ + NODE a,t; + int l,k; + + a = (NODE)FA1(p); + l = length(a); + if ( i < 0 || i >= l ) error("fnode_right_narymul : invalid index"); + if ( i == l-1 ) return mkfnode(1,I_FORMULA,ONE); + else { + for ( k = 0, t = a; k <= i; k++, t = NEXT(t) ); + return fnode_node_to_narymul(t); + } +} + +int fnode_normalize_unify_naryadd(FNODE f,FNODE p,NODE *rp) +{ + int fl,pl,fi,pi; + NODE fa,pa,t,s,m,m1; + FNODE fr,pr,prr,pivot; + + f = to_naryadd(f); + fa = (NODE)FA1(f); fl = length(fa); + pa = (NODE)FA1(p); pl = length(pa); + if ( fl < pl ) return 0; + else if ( pl == 1 ) { + if ( fl == 1 ) + return fnode_normalize_unify(BDY(fa),BDY(pa),rp); + else + return 0; + } else { + for ( t = pa, pi = 0; t; t = NEXT(t), pi++ ) + if ( ((FNODE)BDY(t))->id != I_PVAR ) break; + if ( !t ) { + /* all are I_PVAR */ + m = 0; + for ( t = pa, s = fa; NEXT(t); t = NEXT(t), s = NEXT(s) ) { + fnode_normalize_unify(BDY(s),BDY(t),&m1); + m = append_node(m1,m); + } + if ( !NEXT(s) ) + fr = (FNODE)BDY(s); + else + fr = mkfnode(2,I_NARYOP,FA0(f),s); + fnode_normalize_unify(fr,BDY(t),&m1); + *rp = append_node(m1,m); + return 1; + } else { + pivot = (FNODE)BDY(t); + pr = fnode_removeith_naryadd(p,pi); + for ( s = fa, fi = 0; s; s = NEXT(s), fi++ ) { + if ( fnode_normalize_unify(BDY(s),pivot,&m) ) { + fr = fnode_removeith_naryadd(f,fi); + prr = rewrite_fnode(pr,m); + if ( fnode_normalize_unify(fr,prr,&m1) ) { + *rp = append_node(m,m1); + return 1; + } + } + } + return 0; + } + } +} + +int fnode_normalize_unify_narymul(FNODE f,FNODE p,NODE *rp) +{ + int fl,pl,fi,pi; + NODE fa,pa,t,s,m,m1; + FNODE fr,pr,pleft,pleft1,pright,pright1,fleft,fright,pivot; + + f = to_narymul(f); + fa = (NODE)FA1(f); fl = length(fa); + pa = (NODE)FA1(p); pl = length(pa); + if ( fl < pl ) return 0; + else if ( pl == 1 ) { + if ( fl == 1 ) + return fnode_normalize_unify(BDY(fa),BDY(pa),rp); + else + return 0; + } else { + for ( t = pa, pi = 0; t; t = NEXT(t), pi++ ) + if ( ((FNODE)BDY(t))->id != I_PVAR ) break; + if ( !t ) { + /* all are I_PVAR */ + m = 0; + for ( t = pa, s = fa; NEXT(t); t = NEXT(t), s = NEXT(s) ) { + pr = rewrite_fnode(BDY(t),m); + if ( !fnode_normalize_unify(BDY(s),pr,&m1) ) return 0; + m = append_node(m1,m); + } + if ( !NEXT(s) ) + fr = (FNODE)BDY(s); + else + fr = mkfnode(2,I_NARYOP,FA0(f),s); + pr = rewrite_fnode(BDY(t),m); + if ( !fnode_normalize_unify(fr,pr,&m1) ) return 0; + *rp = append_node(m1,m); + return 1; + } else { + pivot = (FNODE)BDY(t); + pleft = fnode_left_narymul(p,pi); + pright = fnode_right_narymul(p,pi); + /* XXX : incomplete */ + for ( s = fa, fi = 0; s; s = NEXT(s), fi++ ) { + if ( fnode_normalize_unify(BDY(s),pivot,&m) ) { + fleft = fnode_left_narymul(f,fi); + pleft1 = rewrite_fnode(pleft,m); + if ( fnode_normalize_unify(fleft,pleft1,&m1) ) { + m = append_node(m1,m); + fright = fnode_right_narymul(f,fi); + pright1 = rewrite_fnode(pright,m); + if ( fnode_normalize_unify(fright,pright1,&m1) ) { + *rp = append_node(m1,m); + return 1; + } + } + } + } + return 0; + } + } }