k.c

/* Copyright 1990-2011, Jsoftware Inc.  All rights reserved. */
/* License in license.txt.                                   */
/*                                                                         */
/* Conversions Amongst Internal Types                                      */

#include "j.h"

#define KF1(f)          B f(J jt,A w,void*yv)
#define CVCASE(a,b)     ((a)+1024*(b))


#define TOBIT(T,AS)   {T*v=(T*)wv,x; \
  for(i=0;i<m;++i){                                                       \
   DO(q, k=0; DO(BB, if(x=*v++){if(AS)k|=bit[i]; else R 0;}); *zv++=k;);  \
   if(r){k=0; DO(r,  if(x=*v++){if(AS)k|=bit[i]; else R 0;}); *zv++=k;}   \
   DO(r1, *zv++=0;);                                                      \
  }} 

static KF1(jtcvt2bit){I c,i,m,q,r,r1,wr,*ws,*wv;UC k,*zv=(UC*)yv;
 wv=AV(w); wr=AR(w); ws=AS(w); 
 c=wr?ws[wr-1]:1; m=c?AN(w)/c:0; q=c/BB; r=c%BB; r1=c%BW?(BW-c%BW)/BB:0;
 switch(AT(w)){
  default:  R 0;
  case B01: TOBIT(B, 1         ); break;
  case INT: TOBIT(I, 1==x      ); break;
  case FL:  TOBIT(D, FEQ(1.0,x)); break;
 }
 R 1;
}

static KF1(jtC1fromC2){UC*x;US c,*v;
 v=(US*)AV(w); x=(C*)yv;
 DO(AN(w), c=*v++; RZ(256>c); *x++=(UC)c;);
 R 1;
}

static KF1(jtC2fromC1){UC*v;US*x;
 v=UAV(w); x=(US*)yv;
 DO(AN(w), *x++=*v++;);
 R 1;
}

static KF1(jtBfromI){B*x;I n,p,*v;
 n=AN(w); v=AV(w); x=(B*)yv;
 DO(n, p=*v++; if(0==p||1==p)*x++=(B)p; else R 0;);
 R 1;
}

static KF1(jtBfromD){B*x;D p,*v;I n;
 n=AN(w); v=DAV(w); x=(B*)yv;
 DO(n, p=*v++; if(p<-2||2<p)R 0; 
  if(!p)*x++=0; else if(FEQ(1.0,p))*x++=1; else R 0;);
 R 1;
}

static KF1(jtIfromD){D p,q,r,*v;I i,k=0,n,*x;
 n=AN(w); v=DAV(w); x=(I*)yv;
 q=IMIN*(1+jt->fuzz); r=IMAX*(1+jt->fuzz);
 DO(n, p=v[i]; if(p<q||r<p)R 0;);
 for(i=0;i<n;++i){
  p=v[i]; q=jfloor(p);
#if SY_64
  if         (FEQ(p,q)){k=(I)q; *x++=SGN(k)==SGN(q)?k:0>q?IMIN:IMAX;}
  else if(++q,FEQ(p,q)){k=(I)q; *x++=SGN(k)==SGN(q)?k:0>q?IMIN:IMAX;}
  else R 0;
#else
  if(FEQ(p,q))*x++=(I)q; else if(FEQ(p,1+q))*x++=(I)(1+q); else R 0;
#endif
 }
 R 1;
}

static KF1(jtDfromZ){D d,*x;I n;Z*v;
 n=AN(w); v=ZAV(w); x=(D*)yv;
 if(jt->fuzz)DO(n, d=ABS(v->im); if(d!=inf&&d<=jt->fuzz*ABS(v->re)){*x++=v->re; v++;} else R 0;)
 else        DO(n, d=    v->im ; if(!d                            ){*x++=v->re; v++;} else R 0;);
 R 1;
}

static KF1(jtXfromB){B*v;I n,u[1];X*x;
 n=AN(w); v=BAV(w); x=(X*)yv;
 DO(n, *u=v[i]; x[i]=vec(INT,1L,u););           
 R !jt->jerr;
}

static KF1(jtXfromI){B b;I c,d,i,j,n,r,u[XIDIG],*v;X*x;
 n=AN(w); v=AV(w); x=(X*)yv;
 for(i=0;i<n;++i){
  c=v[i]; b=c==IMIN; d=b?-(1+c):ABS(c); j=0;
  DO(XIDIG, u[i]=r=d%XBASE; d=d/XBASE; if(r)j=i;);
  ++j; *u+=b;
  if(0>c)DO(XIDIG, u[i]=-u[i];);
  x[i]=vec(INT,j,u);
 }
 R !jt->jerr;
}

static X jtxd1(J jt,D p){PROLOG;A t;D d,e=tfloor(p),q,r;I m,*u;
 switch(jt->xmode){
  case XMFLR:   p=e;                            break;
  case XMCEIL:  p=ceil(p);                      break;
  case XMEXACT: ASSERT(teq(p,e),EVDOMAIN); p=e; break;
  case XMEXMT:  if(!teq(p,e))R vec(INT,0L,&m);
 }
 if(p== inf)R vci(XPINF);
 if(p==-inf)R vci(XNINF);
 GA(t,INT,30,1,0); u=AV(t); m=0; d=ABS(p); 
 while(0<d){
  q=jfloor(d/XBASE); r=d-q*XBASE; u[m++]=(I)r; d=q;
  if(m==AN(t)){RZ(t=ext(0,t)); u=AV(t);}
 }
 if(!m){u[0]=0; ++m;}else if(0>p)DO(m, u[i]=-u[i];);
 EPILOG(xstd(vec(INT,m,u)));
}

static KF1(jtXfromD){D*v=DAV(w);X*x=(X*)yv; DO(AN(w), x[i]=xd1(v[i]);); R !jt->jerr;}

static KF1(jtBfromX){A q;B*x;I e;X*v;
 v=XAV(w); x=(B*)yv;
 DO(AN(w), q=v[i]; e=*AV(q); RZ(1==AN(q)&&(0==e||1==e)); x[i]=(B)e;);
 R 1;
}

static KF1(jtIfromX){I a,i,m,n,*u,*x;X c,p,q,*v;
 v=XAV(w); x=(I*)yv; n=AN(w);
 RZ(p=xc(IMAX)); RZ(q=xminus(negate(p),xc(1L)));
 for(i=0;i<n;++i){
  c=v[i]; RZ(1!=xcompare(q,c)&&1!=xcompare(c,p));
  m=AN(c); u=AV(c)+m-1; a=0; DO(m, a=*u--+a*XBASE;); x[i]=a;
 }
 R 1;
}

static KF1(jtDfromX){D d,*x=(D*)yv,dm,dp;I c,i,n,*v,wn;X p,*wv;
 dp=1.7976931348623157e308; dm=-dp;
 wn=AN(w); wv=XAV(w);
 for(i=0;i<wn;++i){
  p=wv[i]; n=AN(p); v=AV(p)+n-1; c=*v;
  if     (c==XPINF)d=inf; 
  else if(c==XNINF)d=infm; 
  else{
   d=0.0; DO(n, d=*v--+d*XBASE;);
   ASSERT(jt->xco||dm<=d&&d<=dp,EVDOMAIN);
  }
  x[i]=d;
 } 
 R 1;
}

static KF1(jtQfromX){X*v=XAV(w),*x=(X*)yv; DO(AN(w), *x++=*v++; *x++=iv1;); R 1;}

static KF1(jtQfromD){B neg,recip;D c,d,t,*wv;I e,i,n,*v;Q q,*x;S*tv;
 RZ(w);
 n=AN(w); wv=DAV(w); x=(Q*)yv; tv=3*liln+(S*)&t;
 for(i=0;i<n;++i){
  t=wv[i]; 
  ASSERT(!_isnan(t),EVNAN);
  if(neg=0>t)t=-t; q.d=iv1;
  if     (t==inf)q.n=vci(XPINF);
  else if(t==0.0)q.n=xzero;
  else if(1.1102230246251565e-16<t&&t<9.007199254740992e15){
   d=jfloor(0.5+1/dgcd(1.0,t)); c=jfloor(0.5+d*t); 
   q.n=xd1(c); q.d=xd1(d); q=qstd(q);
  }else{
   if(recip=1>t)t=1.0/t;
   e=(I)(0xfff0&*tv); e>>=4; e-=1023;
   if(recip){q.d=xtymes(xd1(t/pow(2.0,e-53.0)),xpow(xc(2L),xc(e-53))); q.n=ca(iv1);}
   else     {q.n=xtymes(xd1(t/pow(2.0,e-53.0)),xpow(xc(2L),xc(e-53))); q.d=ca(iv1);}
  }
  if(neg){v=AV(q.n); DO(AN(q.n), *v=-*v; ++v;);}
  *x++=q;
 }
 R !jt->jerr;
}

static KF1(jtDfromQ){D d,f,n,*x,xb=(D)XBASE;I cn,i,k,m,nn,pn,qn,r,*v,wn;Q*wv;X c,p,q,x2=0;
 wn=AN(w); wv=QAV(w); x=(D*)yv; nn=308/XBASEN;
 for(i=0;i<wn;++i){
  p=wv[i].n; pn=AN(p); k=1==pn?*AV(p):0;
  q=wv[i].d; qn=AN(q);
  if     (k==XPINF)x[i]=inf;
  else if(k==XNINF)x[i]=infm;
  else if(pn<=nn&&qn<=nn){
   n=0.0; f=1.0; v=AV(p); DO(pn, n+=f*v[i]; f*=xb;);
   d=0.0; f=1.0; v=AV(q); DO(qn, d+=f*v[i]; f*=xb;);
   x[i]=n/d;
  }else{
   k=5+qn; if(!x2)RZ(x2=xc(2L));
   RZ(c=xdiv(take(sc(-(k+pn)),p),q,XMFLR));
   cn=AN(c); m=MIN(cn,5); r=cn-(m+k); v=AV(c)+cn-m; 
   n=0.0; f=1.0; DO(m, n+=f*v[i]; f*=xb;);
   d=1.0; DO(ABS(r), d*=xb;);
   x[i]=0>r?n/d:n*d;
 }}
 R 1;
}

static KF1(jtXfromQ){Q*v;X*x;
 v=QAV(w); x=(X*)yv;
 DO(AN(w), RZ(equ(iv1,v->d)); *x++=v->n; ++v;);           
 R !jt->jerr;
}

static B jtDXfI(J jt,I p,A w,DX*x){B b;I e,c,d,i,j,n,r,u[XIDIG],*v;
 n=AN(w); v=AV(w);
 for(i=0;i<n;++i){
  c=v[i]; b=c==IMIN; d=b?-(1+c):ABS(c); j=0;
  DO(XIDIG, u[i]=r=d%XBASE; d/=XBASE; if(r)j=i;);
  ++j; *u+=b;
  e=XBASEN*(j-1); d=u[j-1]; while(d){++e; d/=10;} 
  if(0>c)DO(j, u[i]=-u[i];);
  x[i].e=e; x[i].p=p; x[i].x=vec(INT,j,u);;
 }
 R !jt->jerr;
}

/*
static B jtDXfI(J jt,I p,A w,DX*x){A y;I b,c,d,dd,e,i,m,n,q,r,*wv,*yv;
 n=AN(w); wv=AV(w); m=(p+XBASEN-1)/XBASEN;
 for(i=0;i<n;++i){
  c=wv[i]; d=dd=c==IMIN?-(1+c):ABS(c); 
  if(d){e=0; while(d){++e; r=d%10; d=d/10;}}else e=1;
  GA(y,INT,m,1,0); yv=AV(y);
  r=p%XBASEN; q=!!r+((e-r)+XBASEN-1)/XBASEN; 
  if(d=(e-r)%XBASEN){b=1; DO(XBASEN, b*=10; --d; if(!d)break;);}else b=XBASE;
  DO(m-q, *yv++=0;);
  d=dd/b; r=dd%b; r+=c==IMIN; r*=XBASE/b; 
  if(0>c){*yv++=-r; DO(q-1, r=d%XBASE; d=d/XBASE; *yv++=-r;);}
  else   {*yv++= r; DO(q-1, r=d%XBASE; d=d/XBASE; *yv++= r;);}
  x[i].e=e-1; x[i].p=p; x[i].x=y;
 }
 R !jt->jerr;
}    /* most significant digit last, decimal point before last digit */


static B jtccvt(J jt,I t,A w,A*y){A d;I n,r,*s,wt,*wv,*yv;
 RZ(w);
 r=AR(w); s=AS(w);
 switch((t&SPARSE?2:0)+(AT(w)&SPARSE?1:0)){I t1;P*wp,*yp;
  case 1: RZ(w=denseit(w)); break;
  case 2: RZ(*y=sparseit(cvt(DTYPE(t),w),IX(r),cvt(t,zero))); R 1;
  case 3: 
   t1=DTYPE(t);
   GA(*y,t,1,r,s); yp=PAV(*y); wp=PAV(w);
   SPB(yp,a,ca(SPA(wp,a)));
   SPB(yp,i,ca(SPA(wp,i)));
   SPB(yp,e,cvt(t1,SPA(wp,e)));
   SPB(yp,x,cvt(t1,SPA(wp,x)));
   R 1;
 }
 n=AN(w); wt=AT(w); wv=AV(w);
 if(t==wt){RZ(*y=ca(w)); R 1;}
 // else if(n&&t&JCHAR){ASSERT(HOMO(t,wt),EVDOMAIN); RZ(*y=uco1(w)); R 1;}
 GA(*y,t,n,r,s); yv=AV(*y); 
 if(t&CMPX)fillv(t,n,(C*)yv); 
 if(!n)R 1;
 switch(CVCASE(t,wt)){
  case CVCASE(LIT, C2T ): R C1fromC2(w,yv);
  case CVCASE(C2T, LIT ): R C2fromC1(w,yv);
  case CVCASE(BIT ,B01 ): R cvt2bit(w,yv);
  case CVCASE(INT ,B01 ): {I*x=    yv;B*v=(B*)wv; DO(n,*x++   =*v++;);} R 1;
  case CVCASE(XNUM,B01 ): R XfromB(w,yv);
  case CVCASE(RAT ,B01 ): GA(d,XNUM,n,r,s); R XfromB(w,AV(d))&&QfromX(d,yv);
  case CVCASE(FL  ,B01 ): {D*x=(D*)yv;B*v=(B*)wv; DO(n,*x++   =*v++;);} R 1;
  case CVCASE(CMPX,B01 ): {Z*x=(Z*)yv;B*v=(B*)wv; DO(n,x++->re=*v++;);} R 1;
  case CVCASE(BIT ,INT ): R cvt2bit(w,yv);
  case CVCASE(B01 ,INT ): R BfromI(w,yv);
  case CVCASE(XNUM,INT ): R XfromI(w,yv);
  case CVCASE(RAT ,INT ): GA(d,XNUM,n,r,s); R XfromI(w,AV(d))&&QfromX(d,yv);
  case CVCASE(FL  ,INT ): {D*x=(D*)yv;I*v=    wv; DO(n,*x++   =(D)*v++;);} R 1;
  case CVCASE(CMPX,INT ): {Z*x=(Z*)yv;I*v=    wv; DO(n,x++->re=(D)*v++;);} R 1;
  case CVCASE(BIT ,FL  ): R cvt2bit(w,yv);
  case CVCASE(B01 ,FL  ): R BfromD(w,yv);
  case CVCASE(INT ,FL  ): R IfromD(w,yv);
  case CVCASE(XNUM,FL  ): R XfromD(w,yv);
  case CVCASE(RAT ,FL  ): R QfromD(w,yv);
  case CVCASE(CMPX,FL  ): {Z*x=(Z*)yv;D t,*v=(D*)wv; DO(n, t=*v++; x++->re=t||_isnan(t)?t:0.0;);} R 1;  /* -0 to 0*/
  case CVCASE(BIT ,CMPX): GA(d,FL,n,r,s); RZ(DfromZ(w,AV(d))); R cvt2bit(d,yv);
  case CVCASE(B01 ,CMPX): GA(d,FL,n,r,s); RZ(DfromZ(w,AV(d))); R BfromD(d,yv);
  case CVCASE(INT ,CMPX): GA(d,FL,n,r,s); RZ(DfromZ(w,AV(d))); R IfromD(d,yv);
  case CVCASE(XNUM,CMPX): GA(d,FL,n,r,s); RZ(DfromZ(w,AV(d))); R XfromD(d,yv);
  case CVCASE(RAT ,CMPX): GA(d,FL,n,r,s); RZ(DfromZ(w,AV(d))); R QfromD(d,yv);
  case CVCASE(FL  ,CMPX): R DfromZ(w,yv);
  case CVCASE(B01 ,XNUM): R BfromX(w,yv);
  case CVCASE(INT ,XNUM): R IfromX(w,yv);
  case CVCASE(RAT ,XNUM): R QfromX(w,yv);
  case CVCASE(FL  ,XNUM): R DfromX(w,yv);
  case CVCASE(CMPX,XNUM): GA(d,FL,  n,r,s); RZ(DfromX(w,AV(d))); R ccvt(t,d,y);
  case CVCASE(B01 ,RAT ): GA(d,XNUM,n,r,s); RZ(XfromQ(w,AV(d))); R BfromX(d,yv);
  case CVCASE(INT ,RAT ): GA(d,XNUM,n,r,s); RZ(XfromQ(w,AV(d))); R IfromX(d,yv);
  case CVCASE(XNUM,RAT ): R XfromQ(w,yv);
  case CVCASE(FL  ,RAT ): R DfromQ(w,yv);
  case CVCASE(CMPX,RAT ): GA(d,FL,  n,r,s); RZ(DfromQ(w,AV(d))); R ccvt(t,d,y);
  default:                ASSERT(0,EVDOMAIN);
}}

A jtcvt(J jt,I t,A w){A y;B b;I*oq; 
 oq=jt->rank; jt->rank=0; b=ccvt(t,w,&y); jt->rank=oq; 
 ASSERT(b,EVDOMAIN);
 R y;
}


A jtbcvt(J jt,C mode,A w){A y,z=w;D ofuzz;I*oq;
 RZ(w);
 ofuzz=jt->fuzz; oq=jt->rank; 
 jt->fuzz=0;     jt->rank=0;
 if(RAT&AT(w))z=ccvt(XNUM,w,&y)?y:w;
 if(mode||!(AT(w)&XNUM+RAT))z=ccvt(B01,w,&y)?y:ccvt(INT,w,&y)?y:ccvt(FL,w,&y)?y:w; 
 jt->fuzz=ofuzz; jt->rank=oq;
 RNE(z);
}    /* convert to lowest type. 0=mode: don't convert XNUM/RAT to other types */

F1(jticvt){A z;D*v,x;I i,k=0,n,*u;
 RZ(w);
 n=AN(w); v=DAV(w);
 GA(z,INT,n,AR(w),AS(w)); u=AV(z);
 for(i=0;i<n;++i){
  x=*v++; if(x<IMIN||IMAX<x)R w;
#if SY_64
  k=(I)x; *u++=SGN(k)==SGN(x)?k:0>x?IMIN:IMAX;
#else
  *u++=(I)x;
#endif
 }
 R z;
}

A jtpcvt(J jt,I t,A w){A y;B b;I*oq=jt->rank; 
 jt->rank=0; b=ccvt(t,w,&y); jt->rank=oq; 
 R b?y:w;
}    /* convert w to type t, if possible, otherwise just return w */


F1(jtcvt0){I n,t,*u,*v,z0,z1;
 RZ(w);
 t=AT(w); n=AN(w); 
 if(n&&t&FL+CMPX){
  if(t&CMPX)n+=n; u=AV(w); v=(I*)minus0; z0=z1=*v;
#if SY_64
             DO(n, if(z0==*u            )*u=0;        ++u; ); 
#else
  z1=*(1+v); DO(n, if(z0==u[0]&&z1==u[1])u[0]=u[1]=0; u+=2;);
#endif
 }
 R w;
}    /* convert -0 to 0 in place */


A jtxcvt(J jt,I m,A w){A z;I old=jt->xmode; jt->xmode=m; z=cvt(XNUM,w); jt->xmode=old; R z;}

F1(jtxco1){RZ(w); ASSERT(AT(w)&DENSE,EVNONCE); R cvt(AT(w)&B01+INT+XNUM?XNUM:RAT,w);}

F2(jtxco2){A z;B b;I j,n,r,*s,t,*wv,*zu,*zv;
 RZ(a&&w);
 n=AN(w); r=AR(w); t=AT(w);
 ASSERT(t&DENSE,EVNONCE);
 RE(j=i0(a));
 switch(j){
  case -2: R aslash1(CDIV,w);
  case -1: b=jt->xco; jt->xco=1; z=bcvt(1,w); jt->xco=b; R z;
  case  1: R xco1(w);
  case  2: 
   if(!(t&RAT))RZ(w=cvt(RAT,w));
   GA(z,XNUM,2*n,1+r,AS(w)); *(r+AS(z))=2;
   MC(AV(z),AV(w),2*n*SZI);
   R z;
  case  3:
   ASSERT(t&XD+XZ,EVDOMAIN);
   b=1&&t&XD;
   GA(z,INT,b?n:2*n,b?r:1+r,0); s=AS(z); if(!b)*s++=2; ICPY(s,AS(w),r);
   zv=AV(z); zu=n+zv; wv=AV(w);
   if(t&XD){DX*v=(DX*)wv;   DO(n,         *zv++=v->p;);}
   else    {ZX*v=(ZX*)wv,y; DO(n, y=*v++; *zv++=y.re.p; *zu++=y.im.p;);}
   R z;
  default:
   ASSERT(20<=j,EVDOMAIN);
   GA(z,t&CMPX?XZ:XD,n,r,AS(w));
   if(t&INT){RZ(DXfI(j,w,(DX*)AV(z))); R z;}
   ASSERT(0,EVNONCE);
}}