=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/strobj.c,v retrieving revision 1.95 retrieving revision 1.104 diff -u -p -r1.95 -r1.104 --- OpenXM_contrib2/asir2000/builtin/strobj.c 2005/11/03 07:41:22 1.95 +++ OpenXM_contrib2/asir2000/builtin/strobj.c 2005/11/30 05:08:00 1.104 @@ -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.94 2005/11/02 10:02:32 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.103 2005/11/30 04:51:46 noro Exp $ */ #include "ca.h" #include "parse.h" @@ -98,6 +98,14 @@ void Pquote_normalize(); void Pnquote_comp(); void Pnquote_match(); +void Pquote_to_nbp(); +void Pshuffle_mul(), Pharmonic_mul(); +void Pnbp_hm(), Pnbp_ht(), Pnbp_hc(), Pnbp_rest(); +void Pnbm_deg(); +void Pnbm_hp_rest(); +void Pnbm_hxky(), Pnbm_xky_rest(); +void Pnbm_hv(), Pnbm_rest(); + void Pquote_to_funargs(),Pfunargs_to_quote(),Pget_function_name(); void Pquote_match(),Pget_quote_id(),Pquote_match_rewrite(); void Pquote_to_nary(),Pquote_to_bin(); @@ -139,9 +147,24 @@ struct ftab str_tab[] = { {"quote_normalize",Pquote_normalize,-2}, {"quote_match",Pquote_match,2}, {"quote_match_rewrite",Pquote_match_rewrite,-4}, + {"nquote_comp",Pnquote_comp,2}, - {"nquote_match",Pnquote_match,2}, + {"nquote_match",Pnquote_match,-3}, + {"quote_to_nbp",Pquote_to_nbp,1}, + {"shuffle_mul",Pshuffle_mul,2}, + {"harmonic_mul",Pharmonic_mul,2}, + {"nbp_hm", Pnbp_hm,1}, + {"nbp_ht", Pnbp_ht,1}, + {"nbp_hc", Pnbp_hc,1}, + {"nbp_rest", Pnbp_rest,1}, + {"nbm_deg", Pnbm_deg,1}, + {"nbm_hxky", Pnbm_hxky,1}, + {"nbm_xky_rest", Pnbm_xky_rest,1}, + {"nbm_hp_rest", Pnbm_hp_rest,1}, + {"nbm_hv", Pnbm_hv,1}, + {"nbm_rest", Pnbm_rest,1}, + {"quote_to_nary",Pquote_to_nary,1}, {"quote_to_bin",Pquote_to_bin,2}, @@ -663,10 +686,12 @@ void Pnquote_match(NODE arg,Q *rp) QUOTE fq,pq; FNODE f,p; int ret; + Q mode; 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); + mode = argc(arg)==3 ? (Q)ARG2(arg) : 0; + fq = (QUOTE)ARG0(arg); Pquote_normalize(mknode(2,fq,mode),&fq); f = (FNODE)BDY(fq); + pq = (QUOTE)ARG1(arg); Pquote_normalize(mknode(2,pq,mode),&pq); p = (FNODE)BDY(pq); ret = nfnode_match(f,p,&r); if ( ret ) { fnode_do_assign(r); @@ -675,6 +700,7 @@ void Pnquote_match(NODE arg,Q *rp) *rp = 0; } + FNODE rewrite_fnode(FNODE,NODE); extern Obj VOIDobj; @@ -747,8 +773,8 @@ void fnode_do_assign(NODE arg) pair = (NODE)BDY(t); pv = (int)BDY(pair); f = (FNODE)(BDY(NEXT(pair))); - if ( f->id == I_FUNC ) { - /* XXX : used for wrapping A_func */ + if ( f->id == I_FUNC_HEAD ) { + /* XXX : I_FUNC_HEAD is a dummy id to pass FUNC */ MKQUOTEARG(qa,A_func,FA0(f)); value = (QUOTE)qa; } else @@ -2034,21 +2060,248 @@ void Pquote_normalize(NODE arg,QUOTE *rp) ac = argc(arg); if ( !ac ) error("quote_normalize : invalid argument"); q = (QUOTE)ARG0(arg); - expand = ac==2 && ARG1(arg); - if ( !q || OID(q) != O_QUOTE ) { + if ( ac == 2 ) + expand = QTOS((Q)ARG1(arg)); + if ( !q || OID(q) != O_QUOTE ) *rp = q; - return; - } 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; } } +NBP fnode_to_nbp(FNODE f); + +void Pquote_to_nbp(NODE arg,NBP *rp) +{ + QUOTE q; + FNODE f; + + q = (QUOTE)ARG0(arg); f = (FNODE)BDY(q); + f = fnode_normalize(f,0); + *rp = fnode_to_nbp(f); +} + +void Pshuffle_mul(NODE arg,NBP *rp) +{ + NBP p1,p2; + + p1 = (NBP)ARG0(arg); + p2 = (NBP)ARG1(arg); + shuffle_mulnbp(CO,p1,p2,rp); +} + +void Pharmonic_mul(NODE arg,NBP *rp) +{ + NBP p1,p2; + + p1 = (NBP)ARG0(arg); + p2 = (NBP)ARG1(arg); + harmonic_mulnbp(CO,p1,p2,rp); +} + +void Pnbp_hm(NODE arg, NBP *rp) +{ + NBP p; + NODE n; + NBM m; + + p = (NBP)ARG0(arg); + if ( !p ) *rp = 0; + else { + m = (NBM)BDY(BDY(p)); + MKNODE(n,m,0); + MKNBP(*rp,n); + } +} + +void Pnbp_ht(NODE arg, NBP *rp) +{ + NBP p; + NODE n; + NBM m,m1; + + p = (NBP)ARG0(arg); + if ( !p ) *rp = 0; + else { + m = (NBM)BDY(BDY(p)); + NEWNBM(m1); + m1->d = m->d; m1->c = ONE; m1->b = m->b; + MKNODE(n,m1,0); + MKNBP(*rp,n); + } +} + +void Pnbp_hc(NODE arg, Q *rp) +{ + NBP p; + NBM m; + + p = (NBP)ARG0(arg); + if ( !p ) *rp = 0; + else { + m = (NBM)BDY(BDY(p)); + *rp = m->c; + } +} + +void Pnbp_rest(NODE arg, NBP *rp) +{ + NBP p; + NODE n; + + p = (NBP)ARG0(arg); + if ( !p ) *rp = 0; + else { + n = BDY(p); + if ( !NEXT(n) ) *rp = 0; + else + MKNBP(*rp,NEXT(n)); + } +} + +void Pnbm_deg(NODE arg, Q *rp) +{ + NBP p; + NBM m; + + p = (NBP)ARG0(arg); + if ( !p ) + STOQ(-1,*rp); + else { + m = (NBM)BDY(BDY(p)); + STOQ(m->d,*rp); + } +} + +void Pnbm_hp_rest(NODE arg, LIST *rp) +{ + NBP p,h,r; + NBM m,m1; + NODE n; + int *b,*b1; + int d,d1,v,i,j,k; + + p = (NBP)ARG0(arg); + if ( !p ) + MKLIST(*rp,0); + else { + m = (NBM)BDY(BDY(p)); + b = m->b; d = m->d; + if ( !d ) + MKLIST(*rp,0); + else { + v = NBM_GET(b,0); + for ( i = 1; i < d; i++ ) + if ( NBM_GET(b,i) != v ) break; + NEWNBM(m1); NEWNBMBDY(m1,i); + b1 = m1->b; m1->d = i; m1->c = ONE; + if ( v ) for ( j = 0; j < i; j++ ) NBM_SET(b1,j); + else for ( j = 0; j < i; j++ ) NBM_CLR(b1,j); + MKNODE(n,m1,0); MKNBP(h,n); + + d1 = d-i; + NEWNBM(m1); NEWNBMBDY(m1,d1); + b1 = m1->b; m1->d = d1; m1->c = ONE; + for ( j = 0, k = i; j < d1; j++, k++ ) + if ( NBM_GET(b,k) ) NBM_SET(b1,j); + else NBM_CLR(b1,j); + MKNODE(n,m1,0); MKNBP(r,n); + n = mknode(2,h,r); + MKLIST(*rp,n); + } + } +} + +void Pnbm_hxky(NODE arg, LIST *rp) +{ + NBP p; + + p = (NBP)ARG0(arg); + if ( !p ) + *rp = 0; + else + separate_xky_nbm((NBM)BDY(BDY(p)),0,rp,0); +} + +void Pnbm_xky_rest(NODE arg,NBP *rp) +{ + NBP p; + + p = (NBP)ARG0(arg); + if ( !p ) + *rp = 0; + else + separate_xky_nbm((NBM)BDY(BDY(p)),0,0,rp); +} + +void Pnbm_hv(NODE arg, NBP *rp) +{ + NBP p; + + p = (NBP)ARG0(arg); + if ( !p ) + *rp = 0; + else + separate_nbm((NBM)BDY(BDY(p)),0,rp,0); +} + +void Pnbm_rest(NODE arg, NBP *rp) +{ + NBP p; + + p = (NBP)ARG0(arg); + if ( !p ) + *rp = 0; + else + separate_nbm((NBM)BDY(BDY(p)),0,0,rp); +} + +NBP fnode_to_nbp(FNODE f) +{ + Q r; + int n,i; + NBM m; + V v; + NBP u,u1,u2; + NODE t,b; + + if ( f->id == I_FORMULA ) { + r = eval(f); + NEWNBM(m); + if ( OID(r) == O_N ) { + m->d = 0; m->c = (Q)r; m->b = 0; + } else { + v = VR((P)r); + m->d = 1; m->c = ONE; NEWNBMBDY(m,1); + if ( !strcmp(NAME(v),"x") ) NBM_SET(m->b,0); + else NBM_CLR(m->b,0); + } + MKNODE(b,m,0); MKNBP(u,b); + return u; + } else if ( IS_NARYADD(f) ) { + t = (NODE)FA1(f); u = fnode_to_nbp((FNODE)BDY(t)); + for ( t = NEXT(t); t; t = NEXT(t) ) { + u1 = fnode_to_nbp((FNODE)BDY(t)); + addnbp(CO,u,u1,&u2); u = u2; + } + return u; + } else if ( IS_NARYMUL(f) ) { + t = (NODE)FA1(f); u = fnode_to_nbp((FNODE)BDY(t)); + for ( t = NEXT(t); t; t = NEXT(t) ) { + u1 = fnode_to_nbp((FNODE)BDY(t)); + mulnbp(CO,u,u1,&u2); u = u2; + } + return u; + } else if ( IS_BINARYPWR(f) ) { + u = fnode_to_nbp((FNODE)FA1(f)); + r = eval((FNODE)FA2(f)); + pwrnbp(CO,u,r,&u1); + return u1; + } +} + void Pnquote_comp(NODE arg,Q *rp) { QUOTE q1,q2; @@ -2057,8 +2310,8 @@ void Pnquote_comp(NODE arg,Q *rp) 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); + f1 = fnode_normalize(f1,0); + f2 = fnode_normalize(f2,0); r = nfnode_comp(f1,f2); STOQ(r,*rp); } @@ -2211,7 +2464,7 @@ FNODE nfnode_add(FNODE a1,FNODE a2,int expand); FNODE nfnode_mul(FNODE a1,FNODE a2,int expand); FNODE nfnode_pwr(FNODE a1,FNODE a2,int expand); FNODE nfnode_mul_coef(Num c,FNODE f,int expand); -FNODE fnode_expand_pwr(FNODE f,int n); +FNODE fnode_expand_pwr(FNODE f,int n,int expand); FNODE to_narymul(FNODE f); FNODE to_naryadd(FNODE f); FNODE fnode_node_to_naryadd(NODE n); @@ -2226,7 +2479,7 @@ FNODE fnode_normalize(FNODE f,int expand) NODE n; Q q; - if ( f->normalized && (f->expanded || !expand) ) return f; + if ( f->normalized && (f->expanded == expand) ) return f; STOQ(-1,q); mone = mkfnode(1,I_FORMULA,q); switch ( f->id ) { @@ -2424,7 +2677,7 @@ FNODE nfnode_mul(FNODE f1,FNODE f2,int expand) m = (FNODE *)ALLOCA(l*sizeof(FNODE)); for ( r = n1, i = 0; i < l1; r = NEXT(r), i++ ) m[i] = BDY(r); for ( r = n2; r; r = NEXT(r) ) { - if ( i == 0 ) + if ( i == 0 || (expand == 2) ) m[i++] = BDY(r); else { fnode_base_exp(m[i-1],&b1,&e1); fnode_base_exp(BDY(r),&b2,&e2); @@ -2480,7 +2733,7 @@ FNODE nfnode_pwr(FNODE f1,FNODE f2,int expand) ee = QTOS((Q)nf2); cc = mkfnode(1,I_FORMULA,c); if ( fnode_is_nonnegative_integer(f2) ) - b = fnode_expand_pwr(b1,ee); + b = fnode_expand_pwr(b1,ee,expand); else { STOQ(-1,q); mone = mkfnode(1,I_FORMULA,q); @@ -2490,7 +2743,7 @@ FNODE nfnode_pwr(FNODE f1,FNODE f2,int expand) MKNODE(t1,inv,t0); t0 = t1; } b1 = fnode_node_to_narymul(t0); - b = fnode_expand_pwr(b1,-ee); + b = fnode_expand_pwr(b1,-ee,expand); } if ( fnode_is_one(cc) ) return b; @@ -2500,25 +2753,37 @@ FNODE nfnode_pwr(FNODE f1,FNODE f2,int expand) && fnode_is_nonnegative_integer(f2) ) { q = (Q)eval(f2); if ( PL(NM(q)) > 1 ) error("nfnode_pwr : exponent too large"); - return fnode_expand_pwr(f1,QTOS(q)); + return fnode_expand_pwr(f1,QTOS(q),expand); } else return mkfnode(3,I_BOP,pwrfs,f1,f2); } -FNODE fnode_expand_pwr(FNODE f,int n) +FNODE fnode_expand_pwr(FNODE f,int n,int expand) { - int n1; - FNODE f1,f2; + int n1,i; + FNODE f1,f2,fn; + Q q; if ( !n ) return mkfnode(1,I_FORMULA,ONE); else if ( IS_ZERO(f) ) return mkfnode(1,I_FORMULA,0); else if ( n == 1 ) return f; else { - n1 = n/2; - f1 = fnode_expand_pwr(f,n1); - f2 = nfnode_mul(f1,f1,1); - if ( n%2 ) f2 = nfnode_mul(f2,f,1); - return f2; + switch ( expand ) { + case 1: + n1 = n/2; + f1 = fnode_expand_pwr(f,n1,expand); + f2 = nfnode_mul(f1,f1,expand); + if ( n%2 ) f2 = nfnode_mul(f2,f,1); + return f2; + case 2: + for ( i = 1, f1 = f; i < n; i++ ) + f1 = nfnode_mul(f1,f,expand); + return f1; + case 0: default: + STOQ(n,q); + fn = mkfnode(1,I_FORMULA,q); + return mkfnode(3,I_BOP,pwrfs,f,fn); + } } } @@ -2794,14 +3059,22 @@ int nfnode_match(FNODE f,FNODE pat,NODE *rp) NODE m,m1,m2,base,exp,fa,pa,n; LIST l; QUOTE qp,qf; - FNODE fbase,fexp,a; + FNODE fbase,fexp,a,fh; FUNC ff,pf; int r; + if ( !pat ) + if ( !f ) { + *rp = 0; + return 1; + } else + return 0; + else if ( !f ) + return 0; switch ( pat->id ) { case I_PVAR: /* [[pat,f]] */ - *rp = mknode(1,mknode(2,(int)FA0(pat),f),0); + *rp = mknode(1,mknode(2,(int)FA0(pat),f)); return 1; case I_FORMULA: @@ -2836,8 +3109,9 @@ int nfnode_match(FNODE f,FNODE pat,NODE *rp) if ( strcmp(ff->fullname,pf->fullname) ) return 0; m = 0; } else { - /* XXX only FA0(f) is used */ - m = mknode(1,mknode(2,FA0((FNODE)FA0(pat)),f),0); + /* XXX : I_FUNC_HEAD is a dummy id to pass FUNC */ + fh = mkfnode(1,I_FUNC_HEAD,FA0(f)); + m = mknode(1,mknode(2,FA0((FNODE)FA0(pat)),fh),0); } /* FA1(f) and FA1(pat) are I_LIST */ fa = (NODE)FA0((FNODE)FA1(f)); @@ -2900,7 +3174,7 @@ FNODE fnode_left_narymul(FNODE p,int i) 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); + if ( i == 0 ) return 0; else if ( i == 1 ) return (FNODE)BDY(a); else { for ( r0 = 0, k = 0, t = a; k < i; k++, t = NEXT(t) ) { @@ -2921,7 +3195,7 @@ FNODE fnode_right_narymul(FNODE p,int i) 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); + if ( i == l-1 ) return 0; else { for ( k = 0, t = a; k <= i; k++, t = NEXT(t) ); return fnode_node_to_narymul(t); @@ -3018,6 +3292,7 @@ int nfnode_match_narymul(FNODE f,FNODE p,NODE *rp) pright = fnode_right_narymul(p,pi); /* XXX : incomplete */ for ( s = fa, fi = 0; s; s = NEXT(s), fi++ ) { + if ( fi < pi ) continue; if ( nfnode_match(BDY(s),pivot,&m) ) { fleft = fnode_left_narymul(f,fi); pleft1 = rewrite_fnode(pleft,m);