diff ca.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
parents
children
line wrap: on
line diff
new file mode 100644
--- /dev/null
+++ b/ca.c
@@ -0,0 +1,247 @@
+/* Copyright 1990-2011, Jsoftware Inc.  All rights reserved. */
+/* License in license.txt.                                   */
+/*                                                                         */
+/* Conjunctions: Atop and Ampersand                                        */
+
+#include "j.h"
+
+
+static DF1(jtonf1){PROLOG;DECLFG;A z;I flag=sv->flag,m=jt->xmode;
+ PREF1(jtonf1);
+ if(primitive(gs))if(flag&VFLR)jt->xmode=XMFLR; else if(flag&VCEIL)jt->xmode=XMCEIL;
+ if(RAT&AT(w))RZ(w=pcvt(XNUM,w));
+ z=CALL1(f1,CALL1(g1,w,gs),fs);
+ jt->xmode=m;
+ EPILOG(z);
+}
+
+static DF2(jtuponf2){PROLOG;DECLFG;A z;I flag=sv->flag,m=jt->xmode;
+ RZ(a&&w);
+ if(primitive(gs))if(flag&VFLR)jt->xmode=XMFLR; else if(flag&VCEIL)jt->xmode=XMCEIL;
+ if(RAT&AT(a))RZ(a=pcvt(XNUM,a));
+ if(RAT&AT(w))RZ(w=pcvt(XNUM,w));
+ z=INT&AT(a)&&INT&AT(w)&&CDIV==ID(gs)?intdiv(a,w):CALL1(f1,CALL2(g2,a,w,gs),fs);
+ jt->xmode=m;
+ EPILOG(z);
+}
+
+static X jtxmodpow(J jt,A a,A w,A h){A ox,z;
+ if(!(XNUM&AT(a)))RZ(a=cvt(XNUM,a));
+ if(!(XNUM&AT(w)))RZ(w=cvt(XNUM,w));
+ if(!(XNUM&AT(h)))RZ(h=cvt(XNUM,h));
+ ox=jt->xmod; jt->xmod=h;
+ GA(z,XNUM,1,0,0); *XAV(z)=xpow(*XAV(a),*XAV(w));
+ jt->xmod=ox;
+ RNE(z);
+}
+
+#define DMOD 46340         /* <. %: _1+2^31 */
+
+#if SY_64
+#define XMOD 3037000499    /* <. %: _1+2^63 */
+#else
+#define XMOD 94906265      /* <. %: _1+2^53 */
+static I dmodpow(D x,I n,D m){D z=1; while(n){if(1&n)z=fmod(z*x,m); x=fmod(x*x,m); n>>=1;} R(I)z;}
+#endif
+
+static I imodpow(I x,I n,I m){I z=1; while(n){if(1&n)z=(z*x)%m;     x=(x*x)%m;     n>>=1;} R   z;}
+
+static DF2(jtmodpow2){A h;B b,c;I at,m,n,wt,x,z;
+ PREF2(jtmodpow2);
+ h=VAV(self)->h; 
+ if(RAT&AT(a))RZ(a=pcvt(XNUM,a)) else if(!(AT(a)&INT+XNUM))RZ(a=pcvt(INT,a)); 
+ if(RAT&AT(w))RZ(w=pcvt(XNUM,w)) else if(!(AT(w)&INT+XNUM))RZ(w=pcvt(INT,w));
+ at=AT(a); wt=AT(w);
+ if((AT(h)&XNUM||at&XNUM||wt&XNUM)&&at&XNUM+INT&&wt&INT+XNUM){A z;
+  z=xmodpow(a,w,h); if(!jt->jerr)R z; RESETERR; R residue(h,expn2(a,w)); 
+ }
+ n=*AV(w);
+ if(!(INT&at&&INT&wt&&0<=n))R residue(h,expn2(a,w));
+ m=*AV(h); x=*AV(a);
+ if(!m)R expn2(a,w);
+ if(XMOD<m||XMOD<-m||m==IMIN||x==IMIN)R cvt(INT,xmodpow(a,w,h));
+ if(b=0>m)m=-m;
+ if(c=0>x)x=-x; x=x%m; if(c)x=m-x;
+#if SY_64
+ z=imodpow(x,n,m);
+#else
+ z=m>DMOD?dmodpow((D)x,n,(D)m):imodpow(x,n,m);
+#endif
+ R sc(b?z-m:z);
+}    /* a m&|@^ w ; m guaranteed to be INT or XNUM */
+
+static DF1(jtmodpow1){A g=VAV(self)->g; R rank2ex(VAV(g)->f,w,self,0L,0L,jtmodpow2);}
+     /* m&|@(n&^) w ; m guaranteed to be INT or XNUM */
+
+static CS1(on1,  CALL1(f1,CALL1(g1,w,gs),fs))
+static CS2(jtupon2,CALL1(f1,CALL2(g2,a,w,gs),fs))
+
+static DF2(on2){PROLOG;DECLFG;A ga,gw,z; 
+ PREF2(on2); 
+ gw=CALL1(g1,w,gs);
+ ga=CALL1(g1,a,gs);
+ z=CALL2(f2,ga,gw,fs); 
+ EPILOG(z);
+}
+
+static DF2(atcomp){AF f;
+ RZ(a&&w); 
+ f=atcompf(a,w,self); 
+ R f?f(jt,a,w,self):upon2(a,w,self);
+}
+
+static DF2(atcomp0){A z;AF f;D oldct=jt->ct;
+ RZ(a&&w);
+ f=atcompf(a,w,self);
+ jt->ct=0; z=f?f(jt,a,w,self):upon2(a,w,self); jt->ct=oldct; 
+ R z;
+}
+
+F2(jtatop){A f,g,h=0,x;AF f1=on1,f2=jtupon2;B b=0,j;C c,d,e;I flag=0,m=-1;V*av,*wv;
+ ASSERTVV(a,w);
+ av=VAV(a); c=av->id;
+ wv=VAV(w); d=wv->id;
+ switch(c){
+  case CNOT:    if(d==CMATCH){f2=jtnotmatch; flag+=VIRS2;} break;
+  case CGRADE:  if(d==CGRADE){f1=jtranking; flag+=VIRS1;} break;
+  case CSLASH:  if(d==CCOMMA)f1=jtredravel; break;
+  case CCEIL:   f1=jtonf1; f2=jtuponf2; flag=VCEIL; break;
+  case CFLOOR:  f1=jtonf1; f2=jtuponf2; flag=VFLR;  break;
+  case CICAP:   if(d==CNE)f1=jtnubind; else if(FIT0(CNE,wv))f1=jtnubind0; break;
+  case CQUERY:  if(d==CDOLLAR||d==CPOUND)f2=jtrollk;  break;
+  case CQRYDOT: if(d==CDOLLAR||d==CPOUND)f2=jtrollkx; break;
+  case CRAZE:   if(d==CCUT&&boxatop(w)){f1=jtrazecut1; f2=jtrazecut2;} break;
+  case CSLDOT:  if(d==CSLASH&&CSLASH==ID(av->f))f2=jtpolymult; break;
+  case CQQ:     if(d==CTHORN&&CEXEC==ID(av->f)&&equ(zero,av->g))f1=jtdigits10; break;
+  case CEXP:    if(d==CCIRCLE)f1=jtexppi; break;
+  case CAMP:
+   x=av->f; if(RAT&AT(x))RZ(x=pcvt(XNUM,x));
+   if((d==CEXP||d==CAMP&&CEXP==ID(wv->g))&&AT(x)&INT+XNUM&&!AR(x)&&CSTILE==ID(av->g)){
+    h=x; flag=VMOD; 
+    if(d==CEXP)f2=jtmodpow2; else f1=jtmodpow1;
+ }}
+ if(d==CEBAR||d==CEPS||(b=FIT0(CEPS,wv))){
+  f=av->f; g=av->g; e=ID(f); if(b)d=ID(wv->f);
+  if(c==CICAP)m=7;
+  else if(c==CSLASH)m=e==CPLUS?4:e==CPLUSDOT?5:e==CSTARDOT?6:-1;
+  else if(c==CAMP&&(g==zero||g==one)){j=*BAV(g); m=e==CIOTA?j:e==CICO?2+j:-1;}
+  switch(0<=m?d:-1){
+   case CEBAR: f2=b?atcomp0:atcomp; flag=6+8*m; break;
+   case CEPS:  f2=b?atcomp0:atcomp; flag=7+8*m; break;
+ }}
+ R fdef(CAT,VERB, f1,f2, a,w,h, flag, (I)wv->mr,(I)wv->lr,(I)wv->rr);
+}
+
+F2(jtatco){A f,g;AF f1=on1,f2=jtupon2;B b=0;C c,d,e;I flag=0,j,m=-1;V*av,*wv;
+ ASSERTVV(a,w);
+ av=VAV(a); c=av->id; f=av->f; g=av->g; e=ID(f); 
+ wv=VAV(w); d=wv->id;
+ switch(c){
+  case CNOT:    if(d==CMATCH){f2=jtnotmatch; flag+=VIRS2;} break;
+  case CGRADE:  if(d==CGRADE){f1=jtranking; flag+=VIRS1;} break;
+  case CCEIL:   f1=jtonf1; f2=jtuponf2; flag=VCEIL; break;
+  case CFLOOR:  f1=jtonf1; f2=jtuponf2; flag=VFLR;  break;
+  case CQUERY:  if(d==CDOLLAR||d==CPOUND)f2=jtrollk;  break;
+  case CQRYDOT: if(d==CDOLLAR||d==CPOUND)f2=jtrollkx; break;
+  case CICAP:   m=7; if(d==CNE)f1=jtnubind; else if(FIT0(CNE,wv))f1=jtnubind0; break;
+  case CAMP:    if(g==zero||g==one){j=*BAV(g); m=e==CIOTA?j:e==CICO?2+j:-1;} break;
+  case CSLASH:  
+   if(vaid(f)&&vaid(w))f2=jtfslashatg;
+   if(d==CCOMMA)f1=jtredravel; else m=e==CPLUS?4:e==CPLUSDOT?5:e==CSTARDOT?6:-1;
+   break;
+  case CSEMICO: 
+   if(d==CLBRACE)f2=jtrazefrom; 
+   else if(d==CCUT){
+    j=i0(wv->g);
+    if(CBOX==ID(wv->f)&&!j)f2=jtrazecut0;    
+    else if(boxatop(w)&&j&&-2<=j&&j<=2){f1=jtrazecut1; f2=jtrazecut2;}
+ }}
+ if(0<=m){
+  b=d==CFIT&&equ(zero,wv->g);
+  switch(b?ID(wv->f):d){
+   case CEQ:   f2=b?atcomp0:atcomp; flag=0+8*m; break;
+   case CNE:   f2=b?atcomp0:atcomp; flag=1+8*m; break;
+   case CLT:   f2=b?atcomp0:atcomp; flag=2+8*m; break;
+   case CLE:   f2=b?atcomp0:atcomp; flag=3+8*m; break;
+   case CGE:   f2=b?atcomp0:atcomp; flag=4+8*m; break;
+   case CGT:   f2=b?atcomp0:atcomp; flag=5+8*m; break;
+   case CEBAR: f2=b?atcomp0:atcomp; flag=6+8*m; break;
+   case CEPS:  f2=b?atcomp0:atcomp; flag=7+8*m; break;
+ }}
+ R fdef(CATCO,VERB, f1,f2, a,w,0L, flag, RMAX,RMAX,RMAX);
+}
+
+F2(jtampco){AF f1=on1;C c,d;I flag=0;V*wv;
+ ASSERTVV(a,w);
+ c=ID(a); wv=VAV(w); d=wv->id;
+ if     (c==CSLASH&&d==CCOMMA)         f1=jtredravel;
+ else if(c==CRAZE&&d==CCUT&&boxatop(w))f1=jtrazecut1;
+ else if(c==CGRADE&&d==CGRADE)         {f1=jtranking; flag+=VIRS1;}
+ R fdef(CAMPCO,VERB, f1,on2, a,w,0L, flag, RMAX,RMAX,RMAX);
+}
+
+static DF1(withl){DECLFG; R jt->rank?irs2(fs,w,gs,AR(fs),jt->rank[1],g2):CALL2(g2,fs,w,gs);}
+static DF1(withr){DECLFG; R jt->rank?irs2(w,gs,fs,jt->rank[1],AR(gs),f2):CALL2(f2,w,gs,fs);}
+
+static DF1(ixfixedleft  ){V*v=VAV(self); R indexofprehashed(v->f,w,v->h);}
+static DF1(ixfixedright ){V*v=VAV(self); R indexofprehashed(v->g,w,v->h);}
+
+static DF1(ixfixedleft0 ){A z;D old=jt->ct;V*v=VAV(self); 
+ jt->ct=0.0; z=indexofprehashed(v->f,w,v->h); jt->ct=old; 
+ R z;
+}
+
+static DF1(ixfixedright0){A z;D old=jt->ct;V*v=VAV(self); 
+ jt->ct=0.0; z=indexofprehashed(v->g,w,v->h); jt->ct=old; 
+ R z;
+}
+
+static DF2(with2){R df1(w,powop(self,a));}
+
+F2(jtamp){A h=0;AF f1=on1,f2=on2;B b;C c,d=0;D old=jt->ct;I flag=0,mode=-1,p,r;V*u,*v;
+ RZ(a&&w);
+ switch(CONJCASE(a,w)){
+  default: ASSERTSYS(0,"amp");
+  case NN: ASSERT(0,EVDOMAIN);
+  case NV:
+   f1=withl; v=VAV(w); c=v->id;
+   if(AN(a)&&AR(a)){
+    if(b=c==CFIT&&equ(zero,v->g))c=ID(v->f); 
+    mode=c==CIOTA?IIDOT:c==CICO?IICO:-1;
+   }
+   if(0<=mode){
+    if(b){jt->ct=0.0; h=indexofsub(mode,a,mark); jt->ct=old; f1=ixfixedleft0;}
+    else {            h=indexofsub(mode,a,mark);             f1=ixfixedleft ;}
+   }else switch(c){
+    case CWORDS: RZ(a=fsmvfya(a)); f1=jtfsmfx; break;
+    case CIBEAM: if(v->f&&v->g&&128==i0(v->f)&&3==i0(v->g)){RZ(h=crccompile(a)); f1=jtcrcfixedleft;}
+   }
+   R fdef(CAMP,VERB, f1,with2, a,w,h, flag, RMAX,RMAX,RMAX);
+  case VN: 
+   f1=withr;
+   if(AN(w)&&AR(w)){
+    v=VAV(a); c=v->id; p=v->flag%256; if(b=c==CFIT&&equ(zero,v->g))c=ID(v->f);
+    if(7==p%8)mode=II0EPS+p/8;  /* (e.i.0:)  etc. */
+    else      mode=c==CEPS?IEPS:c==CLESS?ILESS:-1;
+   }
+   if(0<=mode){
+    if(b){jt->ct=0.0; h=indexofsub(mode,w,mark); jt->ct=old; f1=ixfixedright0;}
+    else {            h=indexofsub(mode,w,mark);             f1=ixfixedright ;}
+   }
+   R fdef(CAMP,VERB, f1,with2, a,w,h, flag, RMAX,RMAX,RMAX);
+  case VV:
+   v=VAV(w); c=v->id; r=v->mr;
+   if(c==CFORK||c==CAMP){
+    if(c==CFORK)d=ID(v->h);
+    if(CIOTA==ID(v->g)&&(!d||d==CLEFT||d==CRIGHT)&&equ(alp,v->f)){
+     u=VAV(a); d=u->id;
+     if(d==CLT||d==CLE||d==CEQ||d==CNE||d==CGE||d==CGT)f2=jtcharfn2;
+   }}else switch(ID(a)){
+    case CGRADE: if(c==CGRADE){f1=jtranking; flag+=VIRS1;} break;
+    case CSLASH: if(c==CCOMMA)f1=jtredravel; break;
+    case CCEIL:  f1=jtonf1; flag=VCEIL; break;
+    case CFLOOR: f1=jtonf1; flag=VFLR;  break;
+    case CRAZE:  if(c==CCUT&&boxatop(w))f1=jtrazecut1;
+   }
+   R fdef(CAMP,VERB, f1,f2, a,w,0L, flag, r,r,r);
+}}