use Array: all; use SimplePrint: all; use SimpleFibre: all; use Math: all; use String:{tochar}; inline bool dandBBB(bool x, bool y) { return(x &y); } /* % This is the APEX stdlib.sis include file. % Standard equates and constants for APL compiler % Also standard coercion functions */ #define toB(x) tob((x)) #define toI(x) toi((x)) #define toD(x) tod((x)) #define toC(x) (x) #define toc(x) (x) /* The toC above is wrong, but one thing at a time... */ void APEXERROR(char[.] msg) { /* Error function. This needs work, as it should kill * the running task, too. */ /*print(msg); */ return(); } /* Structural function utility functions */ /* Ravel utility */ #define APEXRavel(y) (reshape([prod(shape(y))],y)) inline int VectorRotateAmount(int x, int y) { /* Normalize x rotate for array of shape y on selected axis */ /* normalize rotation count */ if (x>0) z = _mod_(x,y); else z = y - _mod_(_abs_(x),y); return(z); } #define APEXRESHAPE(TYPE) \ inline TYPE[*] APEXReshape(int[.] x, TYPE[*] y) \ { /* APEX vector x reshape, with item reuse */ \ ry = APEXRavel(y); \ zxrho = prod(x); /* THIS NEEDS XRHO FOR CODE SAFETY!! */ \ yxrho = shape(ry)[0]; \ if( zxrho <= yxrho) { /* No element resuse case */ \ z = take([zxrho],ry); \ } else { \ ncopies = zxrho/yxrho; /* # complete copies of y. */ \ /* FIXME: y empty case !*/ \ z = with(. <= [i] <= .) \ genarray( [ncopies], y,y); \ /* Now append the leftover bits */ \ z = APEXRavel(z) ++ take([zxrho-(ncopies*yxrho)],ry); \ } \ return(reshape(x,z)); \ } APEXRESHAPE(bool) APEXRESHAPE(int) APEXRESHAPE(double) APEXRESHAPE(char) inline bool SameShape(int[*] x, int[*] y) { /* Predicate for two shape vectors having same shape */ if (_dim_(x) != _dim_(y)) z = false; else z = with ([0] <= i < [_dim_(y)]) fold(dandBBB, true, (_shape_(x))[i] == (_shape_(y))[i]); return(z); } #define APEXMIOTA(N) with (. <= [iv] <= .) genarray([N], iv) #define APEXPI 3.1415926535897932d #define APEXE 2.718281828d /* APEXPINFINITYI largest integer */ #define APEXPINFINITYD 1.7976931348623156D308 /* APEXMINFINITYI smallest integer */ #define APEXMINFINITYD -1.7976931348623156D308 inline bool[+] tob (bool[+] x) { z = with (. <= iv <= .) genarray(_shape_(x),tob(x[iv]),false); return(z); } inline bool[+] tob (int[+] x) { z = with (. <= iv <= .) genarray(_shape_(x),tob(x[iv]),false); return(z); } inline bool[+] tob (double[+] x) { z = with (. <= iv <= .) genarray(_shape_(x),tob(x[iv]),false); return(z); } inline bool tob(bool x) { return(x); } inline bool tob(int x) { if (1 == _toi_S_(x)) z = true; else z = false; return(z); } inline bool tob(double x) { if (1 == _toi_S_(x)) z = true; else z = false; return(z); } /* % Floating-point utilities % This taken from page 93 of the 1993-01-06 version % of Committee Draft 1 of the Extended ISO APL Standard % NO {quad}ct support yet! */ inline int Dsignum(double y) { /* signum double */ if (0.0 == y) z = 0; else if (0.0 > y) z = -1; else z = 1; return(z); } inline int Isignum(int y) { /* signum int */ if (0 == y) z = 0; else if (0 > y) z = -1; else z = 1; return(z); } #define Dmod(p,q) fmod(tod(p),tod(q)) #define Imod(p,q) _mod_(p,q) /* % 1996-12-07 Pearl Harbor Day. Try to fix bug in DBank infdivm % benchmark. (4 5 rho 6) + rank 1 (4 1 rho 7) introduces singleton % vectors into scalar fn calls. % Hence, we need support for singletons within scalar fns. % There is an similar, but independent, bug in rank support for % the extension case. */ /* vector-scalar simple search loops * This is origin-0 x1 iota y0 * cfn is comparator function type suffix to use, e.g, b,i,d,c, */ #define FindFirst(x,y,cfn,QUADct) \ sx = _shape_(x)[0]; \ z = sx; /* if not found */ \ for(i=0; iy[i]; i=shp; } return(z); } inline bool comparatorfnb(bool x, bool y,double QUADct) { /* Boolean comparator */ z = (x == y); return(z); } inline bool comparatorfni(int x, int y, double QUADct) { /* integer comparator */ z = (x == y); return(z); } inline bool comparatorfnd(double x, double y, double QUADct) { /* double comparator with fuzz */ L = _abs_(x-y); /* Tolerant equality */ R = QUADct*max(_abs_(x),_abs_(y)); z = (L <= R); return(z); } inline bool comparatorfnc(char x, char y,double QUADct) { /* char comparator */ z = (x == y); return(z); } inline bool comparatorfndnf(double x,double y, double QUADct) { /* double comparator, no fuzz */ z = (x == y); return(z); } /* Lehmer's random number generator */ #define lehmer(qrl) mod(qrl*16807,2147483647) /* Transposes */ #define APEXTRANSPOSE(TYPE,OTFILL) \ inline TYPE[*] APEXTranspose(TYPE[*] y) \ { \ z = with(iv) \ ( . <= iv <= .) : y[reverse( iv)]; \ genarray( reverse( shape(y)), OTFILL); \ return(z); \ } APEXTRANSPOSE(bool,false) APEXTRANSPOSE(int,0) APEXTRANSPOSE(double,0.0) APEXTRANSPOSE(char,' ') /* End of transposes */ /* modulus functions */ inline int Dmodulo(int x, int y, double QUADct) { if (0 == x) z = 0; else z = Imod(y,x); return(z); } inline double Dmodulo(double x, double y, double QUADct) { /* See page 93 of the 1993-01-06 version of Committee Draft 1 of the Extended ISO APL Standard THIS NEEDS WORK TO SUPPORT QUADct!!!! */ if (0.0d == x) z = 0.0d; else z = Dmod(y,x); return(z); } /* End of boilerplate */ /* % Dyadic Scalar Function kernel macro definitions % These are included in all generated code % Function names are defined as: % {valence, jsymbol, compute type, result type} % Having result type available will let us support things like % int*int where we know result will be integer, rather than being % required to support double_real result. 1996-05-05 */ /* x plus y */ #define dplusBBI(XV,YV) (toi(XV)+toi(YV)) #define dplusBII(XV,YV) (toi(XV)+YV) #define dplusIBI(XV,YV) (XV+toi(YV)) #define dplusIII(XV,YV) (XV+YV) #define dplusDDD(XV,YV) (XV+YV) #define dplusBDD(XV,YV) (tod(XV)+YV) #define dplusDBD(XV,YV) (XV+tod(YV)) #define dplusIDD(XY,YV) (tod(XV)+YV) #define dplusDID(XV,YV) (XV+tod(YV)) /* x minus y */ #define dbarBBI(XV,YV) (toi(XV)-toi(YV)) #define dbarIBI(XV,YV) (XV-toi(YV)) #define dbarBII(XV,YV) (XV-YV) #define dbarIII(XV,YV) (XV-YV) #define dbarIDD(XV,YV) (tod(XV)-YV) #define dbarDID(XV,YV) (XV-tod(YV)) #define dbarDDD(XV,YV) (XV-YV) #define dbarBDD(XV,YV) (tod(XV)-YV) #define dbarDBD(XV,YV) (XV-tod(YV)) /* x times y */ #define dmpyBBB(XV,YV) (XV&YV) #define dmpyIII(XV,YV) (XV*YV) #define dmpyDDD(XV,YV) (XV*YV) #define dmpyBII(XV,YV) (toi(XV)*YV) #define dmpyIBI(XV,YV) (XV*toi(YV)) #define dmpyBDD(XV,YV) (tod(XV)*YV) #define dmpyDBD(XV,YV) (XV*tod(YV)) #define dmpyDID(XV,YV) (XV*tod(YV)) #define dmpyIDD(XV,YV) (tod(XV)*YV) /* x divided by y */ inline double APEX_DIVIDEDD (double X, double Y) { if (X == Y) z = 1.0d; else z = X/Y; return(z); } #define ddivBDD(XV,YV) (APEX_DIVIDEDD(XV,YV)) #define ddivIDD(XV,YV) (APEX_DIVIDEDD(XV,YV)) #define ddivDDD(XV,YV) (APEX_DIVIDEDD(XV,YV)) #define ddivBID(XV,YV) (APEX_DIVIDEDD(XV,YV)) #define ddivIID(XV,YV) (APEX_DIVIDEDD(XV,YV)) #define ddivDID(XV,YV) (APEX_DIVIDEDD(XV,YV)) #define ddivBBD(XV,YV) (APEX_DIVIDEDD(XV,YV)) #define ddivIBD(XV,YV) (APEX_DIVIDEDD(XV,YV)) #define ddivDBD(XV,YV) (APEX_DIVIDEDD(XV,YV)) /* x min y */ inline int APEX_MINII (int x, int y) { if (x <= y) z = x; else z = y; return (z); } inline char APEX_MINCC (char x, char y) { if (x <= y) z = x; else z = y; return (z); } inline double APEX_MINDD (double x, double y) { if (x <= y) z = x; else z = y; return (z); } #define dminBBB(XV,YV) (XV&YV) #define dminIII(XV,YV) (APEX_MINII(XV,YV)) #define dminDDD(XV,YV) (APEX_MINDD(XV,YV)) #define dminCCC(XV,YV) (APEX_MINCC(XV,YV)) #define dminBII(XV,YV) (APEX_MINII(toi(XV),YV)) #define dminIBI(XV,YV) (APEX_MINII(XV,toi(YV))) #define dminBDD(XV,YV) (APEX_MINDD(tod(XV),YV)) #define dminDBD(XV,YV) (APEX_MINDD(XV,tod(YV))) #define dminIDD(XV,YV) (APEX_MINDD(tod(XV),YV)) #define dminDID(XV,YV) (APEX_MINDD(XV,tod(YV))) /* NB. max and min extended to characters */ inline int APEX_MAXII (int x, int y) { if (x >= y) z = x; else z = y; return (z); } inline char APEX_MAXCC (char x, char y) { if (x >= y) z = x; else z = y; return (z); } inline double APEX_MAXDD (double x, double y) { if (x >= y) z = x; else z = y; return (z); } /* x max y */ #define dmaxBBB(XV,YV) (XV|YV) #define dmaxIII(XV,YV) (APEX_MAXII(XV,YV)) #define dmaxDDD(XV,YV) (APEX_MAXDD(XV,YV)) #define dmaxCCC(XV,YV) (APEX_MAXCC(XV,YV)) #define dmaxBII(XV,YV) (APEX_MAXII(toi(XV),YV)) #define dmaxIBI(XV,YV) (APEX_MAXII(XV,toi(YV))) #define dmaxBDD(XV,YV) (APEX_MAXDD(tod(XV),YV)) #define dmaxDBD(XV,YV) (APEX_MAXDD(XV,tod(YV))) #define dmaxIDD(XV,YV) (APEX_MAXDD(tod(XV),YV)) #define dmaxDID(XV,YV) (APEX_MAXDD(XV,tod(YV))) /* x mod y */ #define dmodBBB(XV,YV,QUADct) ((~XV)&YV) #define dmodIII(XV,YV,QUADct) (Dmodulo(XV,YV,QUADct)) #define dmodDDD(XV,YV,QUADct) (Dmodulo(XV,YV,QUADct)) /* x star y */ #define dstarBBB(XV,YV) (XV|~YV) #define dstarIDD(XV,YV) (exp(XV,YV)) #define dstarDDD(XV,YV) (exp(XV,YV)) /* The dstari fragment will not work in integer type because EmitDyadicScalarFns % (and everyone else!) uses lhtype,rhtype to compute fragment % type. This fails for general star because we do not know that % the result type is going to be double_real, as we can not % ascertain that the right argument is positive. % Do it the slow way for now... 1995-11-18 % Actually, now that we have predicates, we can do better! 1996-04-30 */ #define dlogBDD(XV,YV) (log(YV)/log(XV)) #define dlogIDD(XV,YV) (log(YV)/log(XV)) #define dlogDDD(XV,YV) (log(YV)/log(XV)) /* NB. Extension of ISO APL to allow comparison of characters */ /* relationals */ #define dltBBB(XV,YV) ((~XV)&YV) #define dltIBB(XV,YV) (XVYV) #define dgtDDB(XV,YV,QUADct) (XV>YV) #define dgtCCB(XV,YV) (XV>YV) #define dgeBBB(XV,YV) (XV|~YV) #define dgeIIB(XV,YV) (XV>=YV) #define dgeDDB(XV,YV,QUADct) (XV>=YV) #define dgeCCB(XV,YV) (XV>=YV) /* Boolean functions */ #define dorBBB(XV,YV) (XV|YV) /* As of 2004-09-16, we don't support lcm/gcd. Needs work in code generator and dfa to support side effects in scan, etc. rbe */ /* Euclids algorithm for lcm */ #define dandII(XV,YV) (for initial ax := abs(XV); ay := abs(YV); \ u = min(ax,ay); v := max (ax,ay); \ while (v ~= 0) repeat \ v := mod(old u,old v); \ u := old v; \ returns value of (ax*ay)/u \ end for) /* Euclids algorithm for lcm */ #define dandDD(XV,YV) (for initial ax := abs(XV); ay := abs(YV); \ u = min(ax,ay); v := max (ax,ay); \ while (v ~= 0) repeat \ v := mod(old u,old v); \ u := old v; \ returns value of (ax*ay)/u \ end for) /* Euclids algorithm for gcd */ #define dorII(XV,YV) (for initial \ ax := abs(XV); ay := abs(YV); \ u = min(ax,ay); v := max (ax,ay); \ while (v ~= 0) repeat \ v := mod(old u,old v); \ u := old v; \ returns value of u \ end for) /* Euclids algorithm for gcd */ #define dorDDD(XV,YV) (for initial \ ax := abs(XV); ay := abs(YV); \ u = min(ax,ay); v := max (ax,ay); \ while (v ~= 0) repeat \ v := mod(old u,old v); \ u := old v; \ returns value of u \ end for) #define dnandBBB(XV,YV) (~XV&YV) #define dnorBBB(XV,YV) (~XV|YV) #define dcircDDD(XV,YV) (if (XV = 1.0d) then sin(YV) \ elseif (XV = 2.0d) then cos(YV) \ elseif (XV = 3.0d) then tan(YV) \ elseif (XV = 4.0d) then exp((1.0d+YV*YV),0.5d) \ else error[double_real] end if) /* domain error check above */ /* 1 circle */ #define dcirc1DDD(XV,YV) (sin(YV)) /* 2 circle */ #define dcirc2DDD(XV,YV) (cos(YV)) /* 3 circle */ #define dcirc3DDD(XV,YV) (tan(YV)) /* 3 circle */ #define dcirc4DDD(XV,YV) (exp((1.0d+YV*YV),0.5d)) inline bool eqIIBsl(int x, int y) { /* SxS dyadic scalar fn, shapes match */ z = deqIIB(toI(x),toI(y)); return(z); } inline int plusBBIsl(bool x, bool y) { /* SxS dyadic scalar fn, shapes match */ z = dplusIII(toI(x),toI(y)); return(z); } inline char[+] tranXCC(char[+] y) { z = { [i,j] -> y[j,i] }; return(z); } inline int[.] rhoIII(int x, int y) { /* Scalar reshape scalar to vector) */ zxrho = prod(toi(x)); /* Result element count */ z = genarray([zxrho], y); /* allocate result */ return(z); } inline char[*] rhoICC(int[.] x, char[*] y) { z = APEXReshape(toi(x),y); return(z); } int quadXII(int[*] y, int QUADpp, int QUADpw) { /* {quad}{<-} anything */ r=display(y); /* KLUDGE!!! print doesn't support booleans! */ /* MORE kludges - sac tends to evaporate side effects, so we'll help things along abit until that is repaired. */ return(r); } inline bool[*] anddoteqCCB(char[*] x, char[*] y) { /* QUICKSTOP0 case of inner product z = x f.g y */ yt = APEXTranspose(toc(y)); xct = toc(x); shp = drop([-1],shape(x)) ++ drop([1], shape(y)); z = with(iv) (. <= iv <= .) { vx = xct[take([dim(x)-1], iv)]; vy = yt[ reverse(take([1-dim(y)], iv))]; } : dotproduct(vx,vy); genarray(shp, false); return(z); } inline bool dotproduct(char[.] x, char[.] y) { /* Quickstopping dot product vector vector */ z = true; lim = shape(x)[0]; for(i=0; i