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);
+}