Mercurial > hg > jgplsrc
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]); +}