Mercurial > hg > jgplsrc
diff am.c @ 0:e0bbaa717f41 draft default tip
lol J
author | Jordi GutiƩrrez Hermoso <jordigh@octave.org> |
---|---|
date | Mon, 25 Nov 2013 11:56:30 -0500 (2013-11-25) |
parents | |
children |
line wrap: on
line diff
new file mode 100644 --- /dev/null +++ b/am.c @@ -0,0 +1,217 @@ +/* Copyright 1990-2011, Jsoftware Inc. All rights reserved. */ +/* License in license.txt. */ +/* */ +/* Adverbs: Amend */ + +#include "j.h" + + +/* +static A jtmerge1(J jt,A w,A ind){PROLOG;A z;C*v,*x;I c,k,r,*s,t,*u; + RZ(w&&ind); + RZ(ind=pind(IC(w),ind)); + r=MAX(0,AR(w)-1); s=1+AS(w); t=AT(w); c=aii(w); + ASSERT(!(t&SPARSE),EVNONCE); + ASSERT(r==AR(ind),EVRANK); + ASSERT(!ICMP(s,AS(ind),r),EVLENGTH); + GA(z,t,c,r,s); x=CAV(z); v=CAV(w); u=AV(ind); k=bp(t); + DO(c, MC(x+k*i,v+k*(i+c*u[i]),k);); + EPILOG(z); +} +*/ + +#define MCASE(t,k) ((t)+16*(k)) +#define MINDEX {j=*u++; if(0>j)j+=m; ASSERT(0<=j&&j<m,EVINDEX);} + +static A jtmerge1(J jt,A w,A ind){A z;B*b;C*wc,*zc;D*wd,*zd;I c,it,j,k,m,r,*s,t,*u,*wi,*zi; + RZ(w&&ind); + r=MAX(0,AR(w)-1); s=1+AS(w); t=AT(w); k=bp(t); m=IC(w); c=aii(w); + ASSERT(!(t&SPARSE),EVNONCE); + ASSERT(r==AR(ind),EVRANK); + ASSERT(!ICMP(s,AS(ind),r),EVLENGTH); + GA(z,t,c,r,s); + if(!(AT(ind)&B01+INT))RZ(ind=cvt(INT,ind)); + it=AT(ind); u=AV(ind); b=(B*)u; + ASSERT(!c||1<m||!(it&B01),EVINDEX); + ASSERT(!c||1!=m||!memchr(b,C1,c),EVINDEX); + zi=AV(z); zc=(C*)zi; zd=(D*)zc; + wi=AV(w); wc=(C*)wi; wd=(D*)wc; + switch(MCASE(it,k)){ + case MCASE(B01,sizeof(C)): DO(c, *zc++=wc[*b++?i+c:i];); break; + case MCASE(B01,sizeof(I)): DO(c, *zi++=wi[*b++?i+c:i];); break; +#if !SY_64 + case MCASE(B01,sizeof(D)): DO(c, *zd++=wd[*b++?i+c:i];); break; +#endif + case MCASE(INT,sizeof(C)): DO(c, MINDEX; *zc++=wc[i+c*j];); break; + case MCASE(INT,sizeof(I)): DO(c, MINDEX; *zi++=wi[i+c*j];); break; +#if !SY_64 + case MCASE(INT,sizeof(D)): DO(c, MINDEX; *zd++=wd[i+c*j];); break; +#endif + default: if(it&B01)DO(c, MC(zc,wc+k*(*b++?i+c:i),k); zc+=k;) + else DO(c, MINDEX; MC(zc,wc+k*(i+c*j ),k); zc+=k;); break; + } + R RELOCATE(w,z); +} + +#define CASE2Z(T) {T*xv=(T*)AV(x),*yv=(T*)AV(y),*zv=(T*)AV(z); DO(n, zv[i]=bv[i]?yv[i]:xv[i];); R z;} +#define CASE2X(T) {T*xv=(T*)AV(x),*yv=(T*)AV(y); DO(n, if( bv[i])xv[i]=yv[i];); R x;} +#define CASE2Y(T) {T*xv=(T*)AV(x),*yv=(T*)AV(y); DO(n, if(!bv[i])yv[i]=xv[i];); R y;} +#define CASENZ(T) {T*zv=(T*)AV(z); DO(n, j=iv[i]; if(0>j){j+=m; ASSERT(0<=j,EVINDEX);}else ASSERT(j<m,EVINDEX); \ + zv[i]=*(i+(T*)aa[j]);); R z;} + +F1(jtcasev){A b,*u,*v,w1,x,y,z;B*bv,p,q;I*aa,c,*iv,j,m,n,r,*s,t; + RZ(w); + RZ(w1=ca(w)); u=AAV(w1); + p=1; m=AN(w)-3; v=AAV(w); c=i0(v[m+1]); + DO(m+1, x=symbrd(v[i]); if(!x){p=0; RESETERR; break;} u[i]=x; p=p&&NOUN&AT(x);); + if(p){ + b=u[m]; n=AN(b); r=AR(b); s=AS(b); t=AT(*u); + p=t&B01+LIT+INT+FL+CMPX&&AT(b)&NUMERIC; + if(p)DO(m, y=u[i]; if(!(t==AT(y)&&r==AR(y)&&!ICMP(s,AS(y),r))){p=0; break;}); + } + if(!p)R parse(v[m+2]); + if(q=2==m&&B01&AT(b)){bv=BAV(b); x=u[0]; y=u[1];} + else{ + if(!(INT&AT(b)))RZ(b=cvt(INT,b)); + iv=AV(b); + GA(x,INT,m,1,0); aa=AV(x); DO(m, aa[i]=(I)AV(u[i]);); + } + if(p=!q||0>c||1<AC(u[c]))GA(z,t,n,r,s) else z=u[c]; + switch((!q?12:p?0:c==0?4:8)+(t&B01+LIT?0:t&INT?1:t&FL?2:3)){ + case 0: CASE2Z(C); case 1: CASE2Z(I); case 2: CASE2Z(D); case 3: CASE2Z(Z); + case 4: CASE2X(C); case 5: CASE2X(I); case 6: CASE2X(D); case 7: CASE2X(Z); + case 8: CASE2Y(C); case 9: CASE2Y(I); case 10: CASE2Y(D); case 11: CASE2Y(Z); + case 12: CASENZ(C); case 13: CASENZ(I); case 14: CASENZ(D); case 15: CASENZ(Z); + default: ASSERTSYS(0,"casev"); +}} /* z=:b}x0,x1,x2,...,x(m-2),:x(m-1) */ + + +A jtmerge2(J jt,A a,A w,A ind,B ip){A z;I an,ar,*as,at,in,ir,*iv,k,t,wn,wt; + RZ(a&&w&&ind); + an=AN(a); at=AT(a); ar=AR(a); as=AS(a); + wn=AN(w); wt=AT(w); + in=AN(ind); ir=AR(ind); iv=AV(ind); + ASSERT(!an||!wn||HOMO(at,wt),EVDOMAIN); + ASSERT(ar<=ir,EVRANK); + ASSERT(!ICMP(as,AS(ind)+ir-ar,ar),EVLENGTH); + if(!wn)R ca(w); + RE(t=an&&wn?maxtype(at,wt):wt); + if(an&&t!=at)RZ(a=cvt(t,a)); + if(ip&&t==wt&&(!(t&BOX)||AFNJA&AFLAG(w))){ASSERT(!(AFRO&AFLAG(w)),EVRO); z=w;} + else{RZ(z=cvt(t,w)); if(ARELATIVE(w))RZ(z=relocate((I)w-(I)z,z));} + if(ip&&t&BOX&&AFNJA&AFLAG(w)){A*av,t,x,y;A1*zv;I ad,*tv; + ad=(I)a*ARELATIVE(a); av=AAV(a); zv=A1AV(z); + GA(t,INT,in,1,0); tv=AV(t); memset(tv,C0,in*SZI); + DO(in, y=smmcar(z,AVR(i%an)); if(!y)break; tv[i]=(I)y;); + if(!y){DO(in, if(!tv[i])break; smmfrr((A)tv[i]);); R 0;} + DO(in, x=(A)AABS(zv[iv[i]],z); zv[iv[i]]=AREL(tv[i],z); smmfrr(x);); + }else{ + if(ARELATIVE(a))RZ(a=rca(a)); + if(ARELATIVE(z)){A*av=AAV(a),*zv=AAV(z); DO(in, zv[iv[i]]=(A)AREL(av[i%an],z););} + else {C*av=CAV(a),*zv=CAV(z); k=bp(t); DO(in, MC(zv+k*iv[i],av+k*(i%an),k); );} + } + R z; +} + +A jtjstd(J jt,A w,A ind){A j=0,k,*v,x;B b;I d,i,id,n,r,*s,*u,wr,*ws; + wr=AR(w); ws=AS(w); b=AN(ind)&&BOX&AT(ind); + if(!wr)R from(ind,zero); + if(b&&AR(ind)){ + RE(aindex(ind,w,0L,&j)); + if(!j){ + RZ(x=from(ind,increm(iota(shape(w))))); u=AV(x); + DO(AN(x), ASSERT(*u,EVDOMAIN); --*u; ++u;); + R x; + } + k=AAV0(ind); n=AN(k); + GA(x,INT,wr,1,0); u=wr+AV(x); s=wr+ws; d=1; DO(wr, *--u=d; d*=*--s;); + R n==wr?pdt(j,x):irs2(pdt(j,vec(INT,n,AV(x))),iota(vec(INT,wr-n,ws+n)),0L,0L,RMAX,jtplus); + } + if(!b){n=1; RZ(j=pind(*ws,ind));} + else{ + ind=AAV0(ind); n=AN(ind); r=AR(ind); + ASSERT(!n&&1==r||AT(ind)&BOX+NUMERIC,EVINDEX); + if(n&&!(BOX&AT(ind)))RZ(ind=every(ind,0L,jtright1)); + v=AAV(ind); id=(I)ind*ARELATIVE(ind); + ASSERT(1>=r,EVINDEX); + ASSERT(n<=wr,EVINDEX); + d=n; DO(n, --d; if(!equ(ace,AADR(id,v[d])))break;); if(n)++d; n=d; + j=zero; + for(i=0;i<n;++i){ + x=AADR(id,v[i]); d=ws[i]; + if(AN(x)&&BOX&AT(x)){ + ASSERT(!AR(x),EVINDEX); + x=AAV0(x); k=IX(d); + if(AN(x))k=less(k,pind(d,1<AR(x)?ravel(x):x)); + }else k=pind(d,x); + RZ(j=irs2(tymes(j,sc(d)),k,0L,0L,RMAX,jtplus)); + }} + R n==wr?j:irs2(tymes(j,sc(prod(wr-n,ws+n))),iota(vec(INT,wr-n,ws+n)),0L,0L,RMAX,jtplus); +} /* convert ind in a ind}w into integer positions */ + +/* Reference count for w for amend in place */ +/* 1 jdo tpop */ +/* 2 amendn2 EPILOG/gc */ +/* 1 jdo tpop */ + +static A jtamendn2(J jt,A a,A w,A ind,B ip){PROLOG;A e,z;B b,sa,sw;I at,ir,it,t,t1,wt;P*p; + RZ(a&&w&&ind); + at=AT(a); sa=1&&at&SPARSE; if(sa)at=DTYPE(at); + wt=AT(w); sw=1&&wt&SPARSE; if(sw)wt=DTYPE(wt); + it=AT(ind); ir=AR(ind); + ASSERT(it&NUMERIC+BOX||!AN(ind),EVDOMAIN); + ASSERT(it&DENSE,EVNONCE); + if(sw){ + ASSERT(!(wt&BOX),EVNONCE); ASSERT(HOMO(at,wt),EVDOMAIN); + RE(t=maxtype(at,wt)); t1=STYPE(t); RZ(a=t==at?a:cvt(sa?t1:t,a)); + if(ip=ip&&t==wt&&t1!=BOX){ASSERT(!(AFRO&AFLAG(w)),EVRO); z=w;}else RZ(z=cvt(t1,w)); + p=PAV(z); e=SPA(p,e); b=!AR(a)&&equ(a,e); + p=PAV(a); if(sa&&!equ(e,SPA(p,e))){RZ(a=denseit(a)); sa=0;} + if(it&NUMERIC||!ir)z=(b?jtam1e:sa?jtam1sp:jtam1a)(jt,a,z,it&NUMERIC?box(ind):ope(ind),ip); + else{RE(aindex(ind,z,0L,&ind)); ASSERT(ind,EVNONCE); z=(b?jtamne:sa?jtamnsp:jtamna)(jt,a,z,ind,ip);} + }else z=merge2(sa?denseit(a):a,w,jstd(w,ind),ip); + EPILOG(z); +} + +static DF2(amccn2){R amendn2(a,w,VAV(self)->f,0);} +static DF2(amipn2){R amendn2(a,w,VAV(self)->f,(B)(!(AT(w)&RAT+XNUM)&&(1==AC(w)||AFNJA&AFLAG(w))));} + +static DF2(amccv2){DECLF; + RZ(a&&w); + ASSERT(DENSE&AT(w),EVNONCE); + R merge2(a,w,pind(AN(w),CALL2(f2,a,w,fs)),0); +} + +static DF2(amipv2){DECLF; + RZ(a&&w); + ASSERT(DENSE&AT(w),EVNONCE); + R merge2(a,w,pind(AN(w),CALL2(f2,a,w,fs)),(B)(!(AT(w)&RAT+XNUM)&&(1==AC(w)||AFNJA&AFLAG(w)))); +} + +static DF1(mergn1){ R merge1(w,VAV(self)->f);} +static DF1(mergv1){DECLF; R merge1(w,CALL1(f1,w,fs));} + +static B ger(A w){A*wv,x;I wd; + if(!(BOX&AT(w)))R 0; + wv=AAV(w); wd=(I)w*ARELATIVE(w); + DO(AN(w), x=WVR(i); if(BOX&AT(x)&&1==AR(x)&&2==AN(x))x=AAV0(x); if(!(LIT&AT(x)&&1>=AR(x)&&AN(x)))R 0;); + R 1; +} /* 0 if w is definitely not a gerund; 1 if possibly a gerund */ + +static A jtamend(J jt,A w,B ip){ + RZ(w); + if(VERB&AT(w)) R ADERIV(CRBRACE,mergv1,ip?amipv2:amccv2,RMAX,RMAX,RMAX); + else if(ger(w))R gadv(w,CRBRACE); + else R ADERIV(CRBRACE,mergn1,ip?amipn2:amccn2,RMAX,RMAX,RMAX); +} + +F1(jtrbrace){R amend(w,0);} +F1(jtamip ){R amend(w,1);} + + +static DF2(jtamen2){ASSERT(0,EVNONCE);} + +F1(jtemend){ + ASSERT(NOUN&AT(w),EVDOMAIN); + R ADERIV(CEMEND,0L,jtamen2,RMAX,RMAX,RMAX); +}