Support ($,)!.n allow _ in x of x $ y, and !.v for it

HenryHRich · HenryHRich · commit c43438daf686 · 2024-07-26T19:08:49.000-04:00
diff --git a/jsrc/cv.c b/jsrc/cv.c
@@ -62,16 +62,19 @@ static DF1(jtfitpp1){DECLFG;A z;
 static DF1(jtfitf1){V*sv=FAV(self); A z; R df1(z,  w,fit(fix(sv->fgh[0],zeroionei(0)),sv->fgh[1]));}  // ?? noun~!.n
 static DF2(jtfitf2){V*sv=FAV(self); A z; R df2(z,a,w,fit(fix(sv->fgh[0],zeroionei(0)),sv->fgh[1]));}
 
-// Fit conjunction u!.n
+// Fit conjunction u!.v
 // Preserve IRS1/IRS2 from u in result verb (exception: CEXP)
 // Preserve VISATOMIC1 from u (applies only to numeric atomic ops)
 // Preserve comparison-combination flags for tolerance fit, in case this is a fit-allowing primitive that uses them
 F2(jtfit){F2PREFIP;A f;C c;I k,l,m,r;V*sv;
- ASSERTVN(a,w);  // a must be a verb, w a noun
- sv=FAV(a); m=sv->mr; l=lrv(sv); r=rrv(sv);
+//  ASSERTVN(a,w);  // a must be a verb, w a noun
+ ASSERT(AT(a)&VERB,EVDOMAIN)  // a must be a verb
  A z; fdefallo(z)
- I cno=0;
- switch(sv->id){I wval;
+ sv=FAV(a); m=sv->mr; l=lrv(sv); r=rrv(sv);
+ if(likely(!(AT(w)&VERB))){  // is v a noun?
+  // Noun v.
+  I cno=0;
+  switch(sv->id){I wval;
   case CIOTA: ++cno;  // i.!.1 supported only in viavx.c
   case CSLDOT: case CSLDOTDOT: ++cno;   case CLE: case CLT: case CGE: case CGT: case CNE: case CEQ: ++cno;
   case CMATCH: case CEPS:    case CICO:      case CNUB:     case CSTAR:  
@@ -92,20 +95,26 @@ F2(jtfit){F2PREFIP;A f;C c;I k,l,m,r;V*sv;
   case CPOLY:
    ASSERT(AT(w)&NUMERIC,EVDOMAIN);
    fdeffill(z,0L,CFIT,VERB,jtvalenceerr,jtfitpoly2,a,w,0L,VFLAGNONE,m,l,r) RETF(z);  // p.!.f
+
+  case CHOOK:   // only ($,)
+   if(sv->valencefns[1]==jtreshape)goto fillreshape;
+   break;
   case CPOWOP:  // support for #^:_1!.n
    if(sv->fgh[1]!=num(-1))R jtfitct(jt,a,w,0,z);
    f=sv->fgh[0]; c=ID(f);
    if(c==CPOUND){ASSERT(!AR(w),EVRANK); fdeffill(z,0L,CFIT,VERB,jtvalenceerr,jtfitfill2,a,w,0L,VFLAGNONE,m,l,r) RETF(z);}  // #^:_1!.f
    ASSERT(c==CAMP,EVDOMAIN);
    f=FAV(f)->fgh[1]; ASSERT(CPOUND==ID(f),EVDOMAIN);
-   // fall through for x&#^:_1!.f
-  // fill atoms:
+    // fall through for x&#^:_1!.f
+   // fill atoms:
   case CPOUND:  case CTAKE:  case CTAIL: case CCOMMA:  case CCOMDOT: case CLAMIN: case CRAZE:
    ASSERT(!AR(w),EVRANK);  /* fall thru */
   case CROT: case CDOLLAR:  // these allow an empty array 
+fillreshape:;
    ASSERT(1>=AR(w),EVRANK);
    ASSERT(!AR(w)||!AN(w),EVLENGTH);
-   fdeffill(z,0L,CFIT,VERB,jtfitfill1,jtfitfill2,a,w,0L,sv->flag&(VIRS1|VIRS2|VJTFLGOK1|VJTFLGOK2|VASGSAFE),m,l,r) RETF(z);  // ^!.f
+   fdeffill(z,0L,CFIT,VERB,jtfitfill1,jtfitfill2,a,w,0L,sv->flag&(VIRS1|VIRS2|VJTFLGOK1|VJTFLGOK2|VASGSAFE),m,l,r) RETF(z);  // various allowing empty fill
+
   case CTHORN:
    RE(w=sc(k=i0(w)));
    ASSERT(0<k,EVDOMAIN);
@@ -117,7 +126,14 @@ F2(jtfit){F2PREFIP;A f;C c;I k,l,m,r;V*sv;
   case CTILDE:   // noun~!.n - what in the world is that?
    ASSERT(NOUN&AT(sv->fgh[0]),EVDOMAIN);
    fdeffill(z,0L,CFIT,VERB,jtfitf1,jtfitf2,a,w,0L,VFLAGNONE,m,l,r) RETF(z);
-  default:
-   ASSERT(0,EVDOMAIN);
-}}
+  // other cases continue on to error
+  }
+ }else{
+  // v is a verb.  Supported now only in $[!.n]!.v or ($,)[!.n]!.v
+  AF rtn1=sv->valencefns[1]; if(rtn1==jtfitfill2)rtn1=FAV(sv->fgh[0])->valencefns[1];  // what routine will process?  (if fit, look back to underlying function)
+  if(rtn1==jtreshape||rtn1==jtreitem)
+   fdeffill(z,0L,CFIT,VERB,jtvalenceerr,jtreshapeblankfn,a,w,0L,sv->flag&(VIRS1|VIRS2|VJTFLGOK1|VJTFLGOK2|VASGSAFE),m,l,r) FAV(z)->localuse.lu1.fittype=rtn1==jtreitem; RETF(z);  // fittype tells whether ($,) or $
+ }
+ ASSERT(0,EVDOMAIN);
+} 
 
diff --git a/jsrc/je.h b/jsrc/je.h
@@ -652,6 +652,7 @@ extern DF2(jtpolymult);
 extern DF2(jtpowop);
 extern DF2(jtrazecut0);
 extern DF2(jtrazecut2);
+extern DF2(jtreshapeblankfn);
 extern DF2(jtrollk);
 extern F2(jtrollksub);
 extern DF2(jtrollkx);
diff --git a/jsrc/jtype.h b/jsrc/jtype.h
@@ -1084,7 +1084,7 @@ typedef struct {
     A cachedref;  //  for namerefs ('name'~), the cached value, or 0 if not cached
     AF fork2hfn;   // for dyad fork that is NOT a comparison combination or jtintersect, the function to call to process h (might be in h@][)
     I forcetask;  // for t., the flags extracted from n.  Bits 0-7=thread pool; bit 8=worker thread only
-    I fittype;  // for u!.t where t is a code, its value is stored here in the CFIT block
+    I fittype;  // for u!.t where t is a code, its value is stored here in the CFIT block; for $!.v, 0 if the ultimate routine is ($,), 1 if $
     I1 srank[4];   // for RANK conj, the signed ranks.  srank[3] is nonzero if the given rank was floating-point - means 'don't combine'
     UI mrecip;  // for u m. n  m&|@^ and m&|@(n&^), the reciprocal of m, with binary point above 2^BW
     S foreignmn[2];  // in m!:n, the arguments
diff --git a/jsrc/vf.c b/jsrc/vf.c
@@ -261,14 +261,28 @@ static A jtreshapesp(J jt,A a,A w,I wf,I wcr){A a1,e,t,x,y,z;B az,*b,wz;I an,*av
  R z;
 }    /* a ($,)"wcr w for sparse w and scalar or vector a */
 
+// x is floating-point left side of x $ y, w is right side.  Result is INT x, but if x contains _, replace _ with the number needed to use up y exactly.
+// Give rndfn a chance to adjust the number.  nlens is #axes before inner  cell: wcr for ($,) 1 for $   wcr is cell-rank of w, if "r given
+static A jtreshapeblank(J jt, A a, A w, A rndfn, I nlens, I wcr){
+ RZ(a=vib(a)); RZ(a=mkwris(a)) // convert to int, converting _ to IMAX; make it writable since we will change _
+ I upos=IMAX, xprod=1; DO(AN(a), I xval=IAV(a)[i]; I nupos=xval==IMAX?i:upos; xval=xval==IMAX?1:xval; ASSERT(nupos<=upos,EVDOMAIN) upos=nupos; DPMULD(xprod,xval,xprod,ASSERT(0,EVLIMIT));)  // multiple non-_, error if overflow of >1 _
+ if(upos==IMAX)R a;  // if x didn't contain _, just use it as is
+ ASSERT(xprod!=0,EVDOMAIN);  // if result is empty, we cannot calculate a value
+ I nw; PRODX(nw,nlens,AS(w)+AR(w)-wcr,1)   // calculate # cells in a wcr-cell of w: use all axes or just the first
+ A nblank; df1(nblank,divide(sc(nw),sc(xprod)),rndfn); RZ(nblank);  // rndfn */ (x-._) % */ $`#@.isitem y
+ ASSERT(AR(nblank)==0,EVRANK) if(!(AT(nblank)&INT))RZ(nblank=cvt(INT,nblank))  // nblank must be stomic
+ IAV(a)[upos]=IAV(nblank)[0]; R a;  // replace _ with calculated value and return new x
+}
+
 F2(jtreshape){A z;B filling;C*wv,*zv;I acr,ar,c,k,m,n,p,q,r,*s,t,* RESTRICT u,wcr,wf,wr,* RESTRICT ws,zn;
  F2PREFIP;
  ARGCHK2(a,w);
  ar=AR(a); acr=jt->ranks>>RANKTX; acr=ar<acr?ar:acr;
  wr=AR(w); wcr=(RANKT)jt->ranks; wcr=wr<wcr?wr:wcr; wf=wr-wcr; ws=AS(w); RESETRANK;
  if((I )(1<acr)|(I )(acr<ar)){z=rank2ex(a,w,DUMMYSELF,MIN(acr,1),wcr,acr,wcr,jtreshape); PRISTCLRF(w) RETF(z);}  // multiple cells - must lose pristinity
  // now a is an atom or a list.  w can have any rank
- RZ(a=vip(a)); r=AN(a); u=AV(a);   // r=length of a   u->values of a
+ if(unlikely(AT(a)&FL))RZ(a=jtreshapeblank(jt,a,w,ds(CRIGHT),wcr,wcr)) else RZ(a=vip(a));  // convert a to integer & audit; if FL, also check for _ and handle
+ r=AN(a); u=AV(a);   // r=length of a   u->values of a
  if(unlikely(ISSPARSE(AT(w)))){RETF(reshapesp(a,w,wf,wcr));}
  PRODX(m,r,u,1)  // m=*/a (#atoms in result)  c=#cells of w  n=#atoms/cell of w
  CPROD(,c,wf,ws); CPROD(,n,wcr,wf+ws);
@@ -311,13 +325,30 @@ F2(jtreitem){A y,z;I acr,an,ar,r,*v,wcr,wr;
  fauxblockINT(yfaux,4,1);
  if(1>=wcr)y=a;  // y is atom or list: $ is the same as ($,)
  else{   // rank y > 1: append the shape of an item of y to x
-  RZ(a=vi(a)); an=AN(a); acr=1;  // if a was an atom, now it is a list
+// obsolete   RZ(a=vi(a));
+  if(unlikely(AT(a)&FL))RZ(a=jtreshapeblank(jt,a,w,ds(CRIGHT),MIN(1,wcr),wcr)) else RZ(a=vip(a));  // convert a to integer & audit; if FL, also check for _ and handle
+  an=AN(a); acr=1;  // if a was an atom, now it is a list
   fauxINT(y,yfaux,an+r,1) v=AV(y);
   MCISH(v,AV(a),an); MCISH(v+an,AS(w)+wr-r,r);
  }
- R wr==wcr?jtreshape(jtinplace,y,w):IRS2(y,w,0L,acr,wcr,jtreshape,z);  // Since a has no frame, we dont have to check agreement
+ R wr==wcr?jtreshape(jtinplace,y,w):IRS2(y,w,0L,acr,wcr,jtreshape,z);  // Since a has no frame, we don't have to check agreement
 }    /* a $"r w */
 
+// x $[!.n]!.v y or x ($,)[!.n]!.v y which uses fn v if needed to resolve _ in x
+DF2(jtreshapeblankfn){I acr,ar,r,wcr,wr;
+ F2PREFIP;
+ ARGCHK2(a,w);
+ ar=AR(a); acr=jt->ranks>>RANKTX; acr=ar<acr?ar:acr;
+ wr=AR(w); wcr=(RANKT)jt->ranks; wcr=wr<wcr?wr:wcr;   RESETRANK;
+ if((I )(1<acr)|(I )(acr<ar)){A z=rank2ex(a,w,DUMMYSELF,MIN(acr,1),wcr,acr,wcr,jtreshapeblankfn); PRISTCLRF(w) RETF(z);}  // multiple cells - must lose pristinity
+ A fs=FAV(self)->fgh[0]; AF reshapefn=FAV(fs)->valencefns[1];  // next routine to call, $ ($,) or !.n
+ if(likely(AT(a)&FL)){  // if there might be _, check for it
+  I nlens=FAV(self)->localuse.lu1.fittype?1:wcr; nlens=wcr<nlens?wcr:nlens;  // # axes to use for counting result cells: the w-cell, or 1 item thereof
+  RZ(a=jtreshapeblank(jt,a,w,FAV(self)->fgh[1],nlens,wcr))  // replace the blank, applying function in g
+ }
+ RETF((*reshapefn)(jtinplace,a,w,fs))   // do the reshape, with _ replaced
+}
+
 #define EXPAND(T)  \
   {T*u=(T*)wv,*v=(T*)zv,x;                                                \
    mvc(sizeof(T),&x,k,jt->fillv);                                         \
diff --git a/test/g210.ijs b/test/g210.ijs
@@ -422,6 +422,49 @@ NB. x$!.f y -------------------------------------------------------------
 'domain error' -: 9 3 $!.(<4) etx s:@<"0 'eleemosynary'
 'domain error' -: 9 3 $!.(<4) etx i.2 3
 
+NB. x $ y where x contains _
+(1 $ 2) -: _ $ 2
+(1 $ 2) -: _ $ ,2
+(3 $ 2 3 4) -: _ $ 2 3 4
+(2 $ i. 2 3 4) -: _ $ i. 2 3 4
+(3 2 $ i. 6 3) -: _ 2 $ i. 6 3
+(2 3 $ i. 6 3) -: 2 _ $ i. 6 3
+(2 1 3 $ i. 6 3) -: 2 _ 3 $ i. 6 3
+(1 $"1 0 i. 6 3) -:  _ $"1 0 i. 6 3
+(3 $"1 1 i. 6 3) -:  _ $"1 1 i. 6 3
+(3 2 $"1 1 i. 3 6) -:  _ 2 $"1 1 i. 3 6
+(3 $"1 2 i. 6 3 5) -:  _ $"1 2 i. 6 3 5
+(4 2 $"1 2 i. 6 8 5) -:  4 _ $"1 2 i. 6 8 5
+
+(1 ($,) 2) -: _ ($,) 2
+(1 ($,) 2) -: _ ($,) ,2
+(3 ($,) 2 3 4) -: _ ($,) 2 3 4
+(24 ($,) i. 2 3 4) -: _ ($,) i. 2 3 4
+(9 2 ($,) i. 6 3) -: _ 2 ($,) i. 6 3
+(2 9 ($,) i. 6 3) -: 2 _ ($,) i. 6 3
+(2 3 3 ($,) i. 6 3) -: 2 _ 3 ($,) i. 6 3
+(1 ($,)"1 0 i. 6 3) -:  _ ($,)"1 0 i. 6 3
+(3 ($,)"1 1 i. 6 3) -:  _ ($,)"1 1 i. 6 3
+(3 2 ($,)"1 1 i. 3 6) -:  _ 2 ($,)"1 1 i. 3 6
+(15 ($,)"1 2 i. 6 3 5) -:  _ ($,)"1 2 i. 6 3 5
+(4 10 ($,)"1 2 i. 6 8 5) -:  4 _ ($,)"1 2 i. 6 8 5
+
+'domain error' -: _ 2 $ etx i. 13
+'limit error' -: _ ($,)"2 etx i. 0 1e15 1e15
+'domain error' -: _ 0 $ etx i. 10
+'domain error' -: _ _ 1 $ etx i. 10
+
+NB. x $!.v y
+(9 2 ($,) i. 6 3) -: _ 2 ($,)!.<. i. 6 3
+(7 2 ($,) i. 5 3) -: _ 2 ($,)!.<. i. 5 3
+(8 2 ($,) i. 5 3) -: _ 2 ($,)!.>. i. 5 3
+'domain error' -: _ 2 ($,)!.] etx i. 5 3
+(9 2 ($,)!.99 i. 6 3) -: _ 2 ($,)!.99!.<. i. 6 3
+(7 2 ($,)!.99 i. 5 3) -: _ 2 ($,)!.99!.<. i. 5 3
+(8 2 ($,)!.99 i. 5 3) -: _ 2 ($,)!.99!.>. i. 5 3
+
+
+
 4!:55 ;:'adot1 adot2 sdot0 b f res rk s t ya xa yb yc'
 randfini''
 
diff --git a/test/g231.ijs b/test/g231.ijs
@@ -404,7 +404,7 @@ _2 3 (|."1 2 -: rot"1 2) j./?2 2 3 7$1000
 NB. Inplace if fill
 a =: i. 1e6
 5000 > 7!:2 'a =: 5 |.!.0 a'
-a =. i. 100 100 100
+a =: i. 100 100 100
 5000 > 7!:2 'a =: 5 6 |.!.0 a'
 5000 > 7!:2 'a =: 5 6 7 |.!.0 a'
 
