diff cr.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/cr.c
@@ -0,0 +1,171 @@
+/* Copyright 1990-2011, Jsoftware Inc.  All rights reserved. */
+/* License in license.txt.                                   */
+/*                                                                         */
+/* Conjunctions: Rank Associates                                           */
+
+#include "j.h"
+
+#define DR(r)           (0>r?RMAX:r)
+
+
+I mr(A w){R VAV(w)->mr;}
+I lr(A w){R VAV(w)->lr;}
+I rr(A w){R VAV(w)->rr;}
+
+I efr(I ar,I r){R 0>r?MAX(0,r+ar):MIN(r,ar);}
+
+#define NEWYA   {GA(ya,at,acn,acr,as+af); uu=CAV(ya);}
+#define NEWYW   {GA(yw,wt,wcn,wcr,ws+wf); vv=CAV(yw);}
+#define MOVEYA  {MC(uu,u+=ak,ak); if(ab)RZ(ya=relocate((I)a-(I)ya,ya));}
+#define MOVEYW  {MC(vv,v+=wk,wk); if(wb)RZ(yw=relocate((I)w-(I)yw,yw));}
+
+A jtrank1ex(J jt,A w,A fs,I mr,AF f1){PROLOG;A y,y0,yw,z;B wb;C*v,*vv;
+    I k,mn,n=1,p,*s,wcn,wcr,wf,wk,wr,*ws,wt,yn,yr,*ys,yt;
+ RZ(w);
+ wt=AT(w);
+ if(wt&SPARSE)R sprank1(w,fs,mr,f1);
+ wr=AR(w); ws=AS(w); wcr=efr(wr,mr); wf=wr-wcr; wb=ARELATIVE(w);
+ if(!wf)R CALL1(f1,w,fs);
+ RE(wcn=prod(wcr,wf+ws)); wk=wcn*bp(wt); v=CAV(w)-wk; NEWYW;
+ p=wf; s=ws; RE(mn=prod(wf,ws));
+ if(AN(w))MOVEYW else RZ(yw=reshape(vec(INT,wcr,ws+wf),filler(w)));
+#define VALENCE   1
+#define TEMPLATE  0
+#include "cr_t.h"
+}
+
+A jtrank2ex(J jt,A a,A w,A fs,I lr,I rr,AF f2){PROLOG;A y,y0,ya,yw,z;B ab,b,wb;
+   C*u,*uu,*v,*vv;I acn,acr,af,ak,ar,*as,at,k,mn,n=1,p,q,*s,wcn,wcr,wf,wk,wr,*ws,wt,yn,yr,*ys,yt;
+ RZ(a&&w);
+ at=AT(a); wt=AT(w);
+ if(at&SPARSE||wt&SPARSE)R sprank2(a,w,fs,lr,rr,f2);
+ ar=AR(a); as=AS(a); acr=efr(ar,lr); af=ar-acr; ab=ARELATIVE(a);
+ wr=AR(w); ws=AS(w); wcr=efr(wr,rr); wf=wr-wcr; wb=ARELATIVE(w);
+ if(!af&&!wf)R CALL2(f2,a,w,fs);
+ RE(acn=prod(acr,as+af)); ak=acn*bp(at); u=CAV(a)-ak; NEWYA;
+ RE(wcn=prod(wcr,ws+wf)); wk=wcn*bp(wt); v=CAV(w)-wk; NEWYW;
+ b=af<=wf; p=b?wf:af; q=b?af:wf; s=b?ws:as; RE(mn=prod(p,s)); RE(n=prod(p-q,s+q));
+ ASSERT(!ICMP(as,ws,q),EVLENGTH);
+ if(AN(a))MOVEYA else RZ(ya=reshape(vec(INT,acr,as+af),filler(a)));
+ if(AN(w))MOVEYW else RZ(yw=reshape(vec(INT,wcr,ws+wf),filler(w)));
+#define VALENCE  2
+#define TEMPLATE 0
+#include "cr_t.h"
+}
+
+
+/* Integrated Rank Support                              */
+/* f knows how to compute f"r                           */
+/* jt->rank points to a 2-element vector of             */
+/* (left, right (monadic)) ranks                        */
+/* 0=jt->rank means f is not being called from rank     */
+/* jt->rank is guaranteed positive                      */
+/* jt->rank is guaranteed <: argument ranks             */
+/* frame agreement is verified before invoking f        */
+/* frames either match, or one is empty                 */
+/* (i.e. prefix agreement invokes general case)         */
+
+A jtirs1(J jt,A w,A fs,I m,AF f1){A z;I*old=jt->rank,rv[2],wr; 
+ RZ(w);
+ wr=AR(w); rv[1]=m=efr(wr,m);
+ if(m>=wr)R CALL1(f1,w,fs);
+ rv[0]=0;
+ jt->rank=rv; z=CALL1(f1,w,fs); jt->rank=old; 
+ R z;
+}
+
+A jtirs2(J jt,A a,A w,A fs,I l,I r,AF f2){A z;I af,ar,*old=jt->rank,rv[2],wf,wr; 
+ RZ(a&&w);
+ ar=AR(a); rv[0]=l=efr(ar,l); af=ar-l;
+ wr=AR(w); rv[1]=r=efr(wr,r); wf=wr-r;
+ if(!(af||wf))R CALL2(f2,a,w,fs);
+ ASSERT(!ICMP(AS(a),AS(w),MIN(af,wf)),EVLENGTH);
+ /* if(af&&wf&&af!=wf)R rank2ex(a,w,fs,l,r,f2); */
+ jt->rank=rv; z=CALL2(f2,a,w,fs); jt->rank=old; 
+ R z;
+}
+
+
+static DF1(cons1a){R VAV(self)->f;}
+
+static DF2(cons2a){R VAV(self)->f;}
+
+static DF1(cons1){V*sv=VAV(self);
+ RZ(w);
+ R rank1ex(w,self,efr(AR(w),*AV(sv->h)),cons1a);
+}
+
+static DF2(cons2){V*sv=VAV(self);I*v=AV(sv->h);
+ RZ(a&&w);
+ R rank2ex(a,w,self,efr(AR(a),v[1]),efr(AR(w),v[2]),cons2a);
+}
+
+static DF1(rank1i){DECLF;A h=sv->h;I*v=AV(h); R irs1(w,fs,*v,f1);}
+
+static DF2(rank2i){DECLF;A h=sv->h;I*v=AV(h); R irs2(a,w,fs,v[1],v[2],f2);}
+
+static DF1(rank1){DECLF;A h=sv->h;I m,*v=AV(h),wr;
+ RZ(w);
+ wr=AR(w); m=efr(wr,v[0]);
+ R m<wr?rank1ex(w,fs,m,f1):CALL1(f1,w,fs);
+}
+
+static DF2(rank2){DECLF;A h=sv->h;I ar,l,r,*v=AV(h),wr;
+ RZ(a&&w);
+ ar=AR(a); l=efr(ar,v[1]);
+ wr=AR(w); r=efr(wr,v[2]);
+ R l<ar||r<wr?rank2ex(a,w,fs,l,r,f2):CALL2(f2,a,w,fs);
+}
+
+static void qqset(A a,AF*f1,AF*f2,I*flag){A f,g;C c,d,e,p,q;I m=0;V*v;
+ static C at1[]={CFLOOR,CLE,CCEIL,CGE,CPLUS,CPLUSDOT,CPLUSCO, 
+   CSTAR,CSTARDOT,CSTARCO,CMINUS,CNOT,CHALVE,CDIV,CSQRT,CEXP,CLOG, 
+   CSTILE,CBANG,CLEFT,CRIGHT,CQUERY,CHGEOM,CJDOT,CCIRCLE, 
+   CPCO,CQCO,CRDOT,CTDOT,CXCO,0};  /* f monad <-> f"r monad */
+ static C ir1[]={CCOMMA,CLAMIN,CLEFT,CRIGHT,CCANT,CROT,CTAKE,CDROP,CGRADE,CDGRADE,
+   CBOX,CNE,CTAIL,CCTAIL,CSLASH,CBSLASH,CBSDOT,CCOMDOT,CPCO,CATDOT,0};
+ static C ir2[]={CCOMMA,CLAMIN,CLEFT,CRIGHT,CCANT,CROT,CTAKE,CDROP,CGRADE,CDGRADE,
+   CDOLLAR,CPOUND,CIOTA,CICO,CEPS,CLBRACE,CMATCH,
+   CEQ,CLT,CMIN,CLE,CGT,CMAX,CGE,CPLUS,CPLUSDOT,CPLUSCO,CSTAR,CSTARDOT,CSTARCO,
+   CMINUS,CDIV,CEXP,CNE,CSTILE,CBANG,CCIRCLE,0};
+ if(NOUN&AT(a)){*f1=cons1; *f2=cons2; *flag=0; R;}
+ v=VAV(a); c=v->id;
+ if(strchr(ir1,c))m+=VIRS1;
+ if(strchr(ir2,c))m+=VIRS2;
+ if(!(m&VIRS1)&&v->flag&VIRS1&&c!=CQQ)m+=VIRS1;
+ if(!(m&VIRS2)&&v->flag&VIRS2&&c!=CQQ)m+=VIRS2;
+ if(!m){
+  p=0; if(f=v->f)p=VERB&AT(f)&&strchr(ir2,d=ID(f));
+  q=0; if(g=v->g)q=VERB&AT(g)&&strchr(ir2,e=ID(g));
+  switch(c){
+   case CFIT:   if(p&&d!=CEXP)m+=VIRS2; if(d==CNE)m+=VIRS1; break;
+   case CTILDE: if(p)m+=VIRS1+VIRS2; break;
+   case CAMP:   if(p&&NOUN&AT(g)||q&&NOUN&AT(f))m+=VIRS1; break;
+   case CFORK:  if(v->f1==(AF)jtmean)m+=VIRS1;
+ }}
+ *f1=strchr(at1,c) ? v->f1 : m&VIRS1 ? rank1i : rank1;
+ *f2=                        m&VIRS2 ? rank2i : rank2; 
+ *flag=m;
+}
+
+F2(jtqq){A h,t;AF f1,f2;D*d;I flag,*hv,n,r[3],*v;
+ RZ(a&&w);
+ GA(h,INT,3,1,0); hv=AV(h);
+ if(VERB&AT(w)){
+  GA(t,FL,3,1,0); d=DAV(t);
+  n=r[0]=hv[0]=mr(w); d[0]=n<=-RMAX?-inf:RMAX<=n?inf:n;
+  n=r[1]=hv[1]=lr(w); d[1]=n<=-RMAX?-inf:RMAX<=n?inf:n;
+  n=r[2]=hv[2]=rr(w); d[2]=n<=-RMAX?-inf:RMAX<=n?inf:n;
+  w=t;
+ }else{
+  n=AN(w);
+  ASSERT(1>=AR(w),EVRANK);
+  ASSERT(0<n&&n<4,EVLENGTH);
+  RZ(t=vib(w)); v=AV(t);
+  hv[0]=v[2==n]; r[0]=DR(hv[0]);
+  hv[1]=v[3==n]; r[1]=DR(hv[1]);
+  hv[2]=v[n-1];  r[2]=DR(hv[2]);
+ }
+ qqset(a,&f1,&f2,&flag);
+ R fdef(CQQ,VERB, f1,f2, a,w,h, flag, r[0],r[1],r[2]);
+}