Mercurial > hg > jgplsrc
diff f2.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/f2.c @@ -0,0 +1,189 @@ +/* Copyright 1990-2011, Jsoftware Inc. All rights reserved. */ +/* License in license.txt. */ +/* */ +/* Format: ": Dyad */ + +#include "j.h" + + +static F2(jtth2box){A z;I n,p,q,*v,x,y; + p=jt->pos[0]; q=jt->pos[1]; + RZ(a=vi(a)); n=AN(a); v=AV(a); + ASSERT(1>=AR(a),EVRANK); + ASSERT(1==n||2==n,EVLENGTH); + x=v[0]; y=2>n?0:v[1]; + ASSERT(0<=x&&x<=2&&0<=y&&y<=2,EVDOMAIN); + jt->pos[0]=x; jt->pos[1]=y; + z=thorn1(w); + jt->pos[0]=p; jt->pos[1]=q; + R z; +} + +static I jtc2j(J jt,B e,I m,C*zv){C c,*s,*t;I k,p; + if(e&&(t=strchr(jt->th2buf,'e'))){ + ++t; t+='-'==*t; + k=0; while(c=*(k+t),c=='0'||c=='+')++k; + if(k){ + if(!c||' '==c){*t++='0'; --k;} + while(*t=*(k+t))++t; + p=m-(t-jt->th2buf); DO(p,*t++=' ';); if(0<=p)jt->th2buf[m]=0; + }} + t=jt->th2buf; k=strlen(t); + if(!e&&(s=memchr(t,'-',k))){ /* turn -0 to 0 */ + *s=' '; + DO(k-(1+s-t), c=s[1+i]; if(c!='0'&&c!='.'){*s=CSIGN; break;}); + if(!m&&' '==*s){++t; --k;} + } + if(m&&m<k)memset(zv,'*',m); + else{ + if(k<m){memset(zv+e*k,' ',m-k); if(!e)zv+=m-k;} + DO(k, c=t[i]; *zv++='-'==c?CSIGN:c;); + } + R k; +} /* c format to j format */ + +static B jtfmtex(J jt,I m,I d,I n,I*xv,B b,I c,I q,I ex){B bm=b||m;C*u,*v=jt->th2buf;I k; + if(jt->th2bufn<20+d){A s; jt->th2bufn=20+d; GA(s,LIT,jt->th2bufn,1,0); v=jt->th2buf=CAV(s);} + if(b)*v++='_'; else if(m)*v++=' '; *v++=' '; sprintf(v,FMTI,c); v+=q; + k=(XBASEN+d+1-q)/XBASEN; k=MIN(n-1,k); + DO(k, c=*--xv; sprintf(v,FMTI04,b?-c:c); v+=XBASEN;); + k=v-jt->th2buf-(2+bm); + if(k<d){memset(v,'0',d-k); v+=d-k;} + else if(k>d&&(u=v=jt->th2buf+d+2+bm,'5'<=*v)){ + while('9'==*--u); + if(' '!=*u)++*u; else{*++u='1'; ++ex;} + memset(u+1,'0',v-u-1); + } + jt->th2buf[bm]=jt->th2buf[bm+1]; jt->th2buf[bm+1]='.'; sprintf(v-!d,"e"FMTI"",ex); + R 1; +} /* format one extended integer in exponential form */ + +static B jtfmtx(J jt,B e,I m,I d,C*s,I t,X*wv){B b;C*v=jt->th2buf;I c,n,p,q,*xv;X x; + x=*wv; n=AN(x); xv=AV(x)+n-1; + c=*xv; b=0>c; if(b)c=-c; + if(c==XPINF){if(b)*v++='_'; *v++='_'; *v=0; R 1;} + q=c>999?4:c>99?3:c>9?2:1; p=q+XBASEN*(n-1); + if(e)R fmtex(m,d,n,xv,b,c,q,p-1); + else if(m&&m<b+p+d+!!d){memset(v,'*',m); v[m]=0;} + else{ + if(jt->th2bufn<4+p+d){A s; jt->th2bufn=4+p+d; GA(s,LIT,jt->th2bufn,1,0); v=jt->th2buf=CAV(s);} + if(' '==*s)*v++=' '; if(b)*v++='_'; + sprintf(v,FMTI,c); v+=q; + DO(n-1, c=*--xv; sprintf(v,FMTI04,b?-c:c); v+=XBASEN;); + if(d){*v++='.'; memset(v,'0',d); v[d]=0;} + } + R 1; +} /* format one extended integer */ + +static B jtfmtq(J jt,B e,I m,I d,C*s,I t,Q*wv){B b;C*v=jt->th2buf;I c,ex=0,k,n,p,q,*xv;Q y;X a,g,x; + y=*wv; x=y.n; c=XDIG(x); b=0>c; if(b)x=negate(x); + if(c==XPINF||c==XNINF){if(e)*v++=' '; if(e>b)*v++=' '; if(b)*v++='_'; *v++='_'; *v=0; R 1;} + RZ(a=xpow(xc(10L),xc(1+d))); + if(e&&c&&0>xcompare(x,y.d)){ + ex=XBASEN*(AN(y.n)-AN(y.d)); + g=xtymes(x,xpow(xc(10L),xc(1+d-ex))); + RZ(x=xdiv(g,y.d,XMFLR)); + while(1==xcompare(a,x)){--ex; g=xtymes(xc(10L),g); RZ(x=xdiv(g,y.d,XMFLR));} + if(b)x=negate(x); + }else x=xdiv(xtymes(y.n,a),y.d,XMFLR); + RZ(x=xdiv(xplus(x,xc(5L)),xc(10L),XMFLR)); + n=AN(x); xv=AV(x)+n-1; c=*xv; b=0>c; if(b)c=-c; + q=c>999?4:c>99?3:c>9?2:1; p=q+XBASEN*(n-1); if(c||!e)ex+=p-d-1; + if(e)R fmtex(m,d,n,xv,b,c,q,ex); + else if(m&&m<b+d+!!d+(0>ex?1:1+ex)){memset(v,'*',m); v[m]=0;} + else{ + if(jt->th2bufn<4+p+d){A s; jt->th2bufn=4+p+d; GA(s,LIT,jt->th2bufn,1,0); v=jt->th2buf=CAV(s);} + if(' '==*s)*v++=' '; if(b)*v++='_'; + if(0>ex){k=-ex-1; DO(1+MIN(d,k), *v++='0';);} + sprintf(v,FMTI,c); v+=q; + DO(n-1, c=*--xv; sprintf(v,FMTI04,b?-c:c); v+=XBASEN;); + if(d){v[1]=0; DO(d, *v=*(v-1); --v;); *v='.';} + } + R 1; +} /* format one rational number */ + +static void jtfmt1(J jt,B e,I m,I d,C*s,I t,C*wv){D y; + switch(t){ + case B01: sprintf(jt->th2buf,s,(D)*wv); break; + case INT: sprintf(jt->th2buf,s,(D)*(I*)wv); break; + case XNUM: fmtx(e,m,d,s,t,(X*)wv); break; + case RAT: fmtq(e,m,d,s,t,(Q*)wv); break; + default: + y=*(D*)wv; y=y?y:0.0; /* -0 to 0 */ + if (!memcmp(wv,&inf, SZD))strcpy(jt->th2buf,e?" _" :' '==*s?" _" :"_" ); + else if(!memcmp(wv,&infm,SZD))strcpy(jt->th2buf,e?" __" :' '==*s?" __":"__"); + else if(_isnan(*wv) )strcpy(jt->th2buf,e?" _.":' '==*s?" _.":"_."); + else sprintf(jt->th2buf,s,y); +}} /* format one number */ + +static void jtth2c(J jt,B e,I m,I d,C*s,I n,I t,I wk,C*wv,I zk,C*zv){ + DO(n, fmt1(e,m,d,s,t,wv); c2j(e,m,zv); zv+=zk; wv+=wk;); +} /* format a column */ + +static A jtth2a(J jt,B e,I m,I d,C*s,I n,I t,I wk,C*wv,B first){PROLOG;A y,z;B b=0;C*u,*yv,*zv;I i,m0=m,k,p,q; + q=m?m:t&B01?3:t&INT?12:17; p=n*q; + GA(z,LIT,p,2,0); *AS(z)=n; *(1+AS(z))=q; zv=CAV(z); + if(m){th2c(e,m,d,s,n,t,wk,wv,m,zv); R z;} + for(i=q=0;i<n;++i){ + fmt1(e,m0,d,s,t,wv); + while(p<q+(I)strlen(jt->th2buf)+1){RZ(z=over(z,z)); p+=p; zv=CAV(z);} + u=q+zv; q+=k=c2j(e,0L,u); b=b||CSIGN==*u; zv[q++]=0; m=MAX(m,k); wv+=wk; + } + m+=!first; + GA(y,LIT,n*m,2,0); *AS(y)=n; *(1+AS(y))=m; + yv=CAV(y); memset(yv,' ',AN(y)); u=zv; + if(e){yv+=!first; DO(n, q=strlen(u); MC(yv+(b&&CSIGN!=*u),u,q); yv+=m; u+=1+q;);} + else {yv+=m; DO(n, q=strlen(u); MC(yv-q, u,q); yv+=m; u+=1+q;);} + EPILOG(y); +} /* like th2c, but allocates and returns array */ + +static B jtth2ctrl(J jt,A a,A*ep,A*mp,A*dp,A*sp,I*zkp){A da,ea,ma,s;B b=1,*ev,r; + C*sv;D x,y;I an,*av,d,*dv,i,m,*mv,sk=15,zk=0;Z*au; + r=!(CMPX&AT(a)); jt->th2bufn=500; + if(r)RZ(a=cvt(INT,a)); + an=AN(a); au=ZAV(a); av=AV(a); + GA(ea,B01,an, 1,0); *ep=ea; ev=BAV(ea); + GA(ma,INT,an, 1,0); *mp=ma; mv= AV(ma); + GA(da,INT,an, 1,0); *dp=da; dv= AV(da); + GA(s, LIT,an*sk,2,0); *sp=s; sv=CAV(s); *AS(s)=an; *(1+AS(s))=sk; + for(i=0;i<an;++i){ + if(r){m=av[i]; x=(D)m; d=0;} + else{ + x=au[i].re; m=(I)tfloor(x); ASSERT(teq(x,(D)m),EVDOMAIN); + y=au[i].im; d=(I)tfloor(y); ASSERT(teq(y,(D)d),EVDOMAIN); if(0>y)x=-1; + } + if(0>m)m=-m; if(0>d)d=-d; ASSERT(0<=m&&0<=d,EVLIMIT); + if(0<=x)sprintf(sv, "%%"FMTI"."FMTI"f", m,d); + else sprintf(sv, m?"%%- "FMTI"."FMTI"e" :"%%-"FMTI"."FMTI"e", m?m-1:0,d+!!(SYS&SYS_PC)); + sv+=sk; ev[i]=0>x; mv[i]=m; dv[i]=d; zk+=m; b=b&&m; + if(jt->th2bufn<m)jt->th2bufn=m; if(jt->th2bufn<500+d)jt->th2bufn=500+d; + } + GA(s,LIT,jt->th2bufn,1,0); jt->th2buf=CAV(s); + *zkp=b?zk:0; R 1; +} /* parse format control (left argument of ":) */ + +F2(jtthorn2){PROLOG;A da,ea,h,ma,s,y,*yv,z;B e,*ev;C*sv,*wv,*zv;I an,c,d,*dv,k,m,*mv,n,r,sk,t,wk,*ws,zk; + F2RANK(1,RMAX,jtthorn2,0); + an=AN(a); t=AT(w); + if(t&BOX)R th2box(a,w); + ASSERT(t&NUMERIC&&!(t&SPARSE)&&!(AT(a)&SPARSE),EVDOMAIN); + r=AR(w); ws=AS(w); c=r?ws[r-1]:1; n=c?AN(w)/c:prod(r-1,ws); + ASSERT(!AR(a)||c==an,EVLENGTH); + k=bp(t); wk=c*k; wv=CAV(w)-k; + RZ(th2ctrl(a,&ea,&ma,&da,&s,&zk)); + ev=BAV(ea); mv=AV(ma); dv=AV(da); sk=1<an?*(1+AS(s)):0; sv=CAV(s)-sk; + if(zk||!AN(w)){ + if(1==an)zk*=c; + GA(z,LIT,n*zk,r?r:1,ws); *(AS(z)+AR(z)-1)=zk; zv=CAV(z); + DO(c, if(i<an){e=ev[i]; m=mv[i]; d=dv[i];} th2c(e,m,d,sv+=sk,n,t,wk,wv+=k,zk,zv); zv+=m;); + }else{ + GA(y,BOX,c,1,0); yv=AAV(y); + DO(c, if(i<an){e=ev[i]; m=mv[i]; d=dv[i];} RZ(yv[i]=th2a(e,m,d,sv+=sk,n,t,wk,wv+=k,(B)!i));); + RZ(z=razeh(y)); + if(2<r||1==n&&2!=r){ + if(!r)r=1; + RZ(h=vec(INT,r,ws)); *(AV(h)+r-1)=*(1+AS(z)); + RZ(z=reshape(h,z)); + }} + EPILOG(z); +}