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