uCBQN/src/builtins/sfns.c
2021-07-12 01:06:39 +03:00

914 lines
28 KiB
C
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

#include "../core.h"
#include "../utils/each.h"
#include "../utils/mut.h"
#include "../utils/builtins.h"
#include "../utils/talloc.h"
B shape_c1(B t, B x) {
if (isAtm(x)) thrM("⥊: deshaping non-array");
usz ia = a(x)->ia;
if (reusable(x)) {
decSh(v(x));
arr_shVec(a(x), ia);
return x;
}
Arr* r = TI(x,slice)(x, 0);
arr_shVec(r, ia);
return taga(r);
}
B shape_c2(B t, B w, B x) {
if (isAtm(x)) { dec(x); dec(w); thrM("⥊: Reshaping non-array"); }
if (isAtm(w)) return shape_c1(t, x);
BS2B wget = TI(w,get);
usz wia = a(w)->ia;
if (wia>UR_MAX) thrM("⥊: Result rank too large");
ur nr = (ur)wia;
usz nia = a(x)->ia;
B r; Arr* ra;
if (reusable(x)) { r = x; decSh(v(x)); ra = (Arr*)v(r); }
else { ra = TI(x,slice)(x, 0); r = taga(ra); }
usz* sh = arr_shAllocI(ra, nia, nr);
if (sh) for (u32 i = 0; i < nr; i++) sh[i] = o2s(wget(w,i));
dec(w);
return r;
}
extern B rt_pick;
B pick_c1(B t, B x) {
if (isAtm(x)) return x;
if (a(x)->ia==0) {
B r = getFillE(x);
dec(x);
return r;
}
B r = TI(x,get)(x, 0);
dec(x);
return r;
}
B pick_c2(B t, B w, B x) {
if (isNum(w) && isArr(x) && rnk(x)==1) {
usz p = WRAP(o2i64(w), a(x)->ia, thrF("⊑: indexing out-of-bounds (𝕨≡%R, %s≡≠𝕩)", w, iaW));
B r = TI(x,get)(x, p);
dec(x);
return r;
}
return c2(rt_pick, w, x);
}
extern B rt_select;
B select_c1(B t, B x) {
if (isAtm(x)) thrM("⊏: Argument cannot be an atom");
ur xr = rnk(x);
if (xr==0) thrM("⊏: Argument cannot be rank 0");
if (a(x)->sh[0]==0) thrF("⊏: Argument shape cannot start with 0 (%H ≡ ≢𝕩)", x);
Arr* r = TI(x,slice)(inc(x),0);
usz* sh = arr_shAllocR(r, xr-1);
usz ia = 1;
for (i32 i = 1; i < xr; i++) {
if (sh) sh[i-1] = a(x)->sh[i];
ia*= a(x)->sh[i];
}
r->ia = ia;
dec(x);
return taga(r);
}
B select_c2(B t, B w, B x) {
if (isAtm(x)) thrM("⊏: 𝕩 cannot be an atom");
ur xr = rnk(x);
if (isAtm(w)) {
if (xr==0) thrM("⊏: 𝕩 cannot be a unit");
usz csz = arr_csz(x);
usz cam = a(x)->sh[0];
usz wi = WRAP(o2i64(w), cam, thrF("⊏: Indexing out-of-bounds (𝕨≡%R, %s≡≠𝕩)", w, cam));
Arr* r = TI(x,slice)(inc(x), wi*csz);
usz* sh = arr_shAllocI(r, csz, xr-1);
if (sh) memcpy(sh, a(x)->sh+1, (xr-1)*sizeof(usz));
dec(x);
return taga(r);
}
B xf = getFillQ(x);
BS2B xget = TI(x,get);
usz wia = a(w)->ia;
if (xr==1) {
usz xia = a(x)->ia;
if (TI(w,elType)==el_i32) {
i32* wp = i32any_ptr(w);
if (TI(x,elType)==el_i32) {
i32* rp; B r = m_i32arrc(&rp, w);
i32* xp = i32any_ptr(x);
for (usz i = 0; i < wia; i++) {
usz c = WRAP(wp[i], xia, thrF("⊏: Indexing out-of-bounds (%i∊𝕨, %s≡≠𝕩)", wp[i], xia));
rp[i] = xp[c];
}
dec(w); dec(x);
return r;
} else if (TI(x,elType)==el_f64) {
f64* rp; B r = m_f64arrc(&rp, w);
f64* xp = f64any_ptr(x);
for (usz i = 0; i < wia; i++) {
usz c = WRAP(wp[i], xia, thrF("⊏: Indexing out-of-bounds (%i∊𝕨, %s≡≠𝕩)", wp[i], xia));
rp[i] = xp[c];
}
dec(w); dec(x);
return r;
} else if (TI(x,elType)==el_c32) {
u32* rp; B r = m_c32arrc(&rp, w);
u32* xp = c32any_ptr(x);
for (usz i = 0; i < wia; i++) {
usz c = WRAP(wp[i], xia, thrF("⊏: Indexing out-of-bounds (%i∊𝕨, %s≡≠𝕩)", wp[i], xia));
rp[i] = xp[c];
}
dec(w); dec(x);
return r;
} else if (v(x)->type==t_harr) {
usz i = 0;
B* xp = harr_ptr(x);
HArr_p r = m_harrs(wia, &i);
for (; i < wia; i++) {
usz c = WRAP(wp[i], xia, thrF("⊏: Indexing out-of-bounds (%i∊𝕨, %s≡≠𝕩)", wp[i], xia));
r.a[i] = inc(xp[c]);
}
dec(x);
return harr_fcd(r, w);
} else {
usz i = 0;
HArr_p r = m_harrs(wia, &i);
for (; i < wia; i++) {
usz c = WRAP(wp[i], xia, thrF("⊏: Indexing out-of-bounds (%i∊𝕨, %s≡≠𝕩)", wp[i], xia));
r.a[i] = xget(x, c);
}
dec(x);
return withFill(harr_fcd(r,w),xf);
}
} else {
usz i = 0;
HArr_p r = m_harrs(wia, &i);
BS2B wgetU = TI(w,getU);
for (; i < wia; i++) {
B cw = wgetU(w, i);
if (!isNum(cw)) { harr_abandon(r); goto base; }
usz c = WRAP(o2i64(cw), xia, thrF("⊏: Indexing out-of-bounds (%R∊𝕨, %s≡≠𝕩)", cw, xia));
r.a[i] = xget(x, c);
}
dec(x);
return withFill(harr_fcd(r,w),xf);
}
} else {
BS2B wgetU = TI(w,getU);
ur wr = rnk(w);
i32 rr = wr+xr-1;
if (xr==0) thrM("⊏: 𝕩 cannot be a unit");
if (rr>UR_MAX) thrF("⊏: Result rank too large (%i≡=𝕨, %i≡=𝕩)", wr, xr);
usz csz = arr_csz(x);
usz cam = a(x)->sh[0];
MAKE_MUT(r, wia*csz);
mut_to(r, fillElType(xf));
for (usz i = 0; i < wia; i++) {
B cw = wgetU(w, i);
if (!isNum(cw)) { mut_pfree(r, i*csz); goto base; }
f64 c = o2f(cw);
if (c<0) c+= cam;
if ((usz)c >= cam) { mut_pfree(r, i*csz); thrF("⊏: Indexing out-of-bounds (%R∊𝕨, %s≡≠𝕩)", cw, cam); }
mut_copy(r, i*csz, x, csz*(usz)c, csz);
}
Arr* ra = mut_fp(r);
usz* rsh = arr_shAllocR(ra, rr);
if (rsh) {
memcpy(rsh , a(w)->sh , wr *sizeof(usz));
memcpy(rsh+wr, a(x)->sh+1, (xr-1)*sizeof(usz));
}
dec(w); dec(x);
return withFill(taga(ra),xf);
}
base:
dec(xf);
return c2(rt_select, w, x);
}
static NOINLINE B slash_c1R(B x, u64 s) {
usz xia = a(x)->ia;
BS2B xgetU = TI(x,getU);
f64* rp; B r = m_f64arrv(&rp, s); usz ri = 0;
for (usz i = 0; i < xia; i++) {
usz c = o2s(xgetU(x, i));
for (usz j = 0; j < c; j++) rp[ri++] = i;
}
dec(x);
return r;
}
extern B rt_slash;
B slash_c1(B t, B x) {
if (RARE(isAtm(x)) || RARE(rnk(x)!=1)) thrF("/: Argument must have rank 1 (%H ≡ ≢𝕩)", x);
i64 s = isum(x);
if(s<0) thrM("/: Argument must consist of natural numbers");
usz xia = a(x)->ia;
if (RARE(xia>=I32_MAX)) return slash_c1R(x, s);
i32* rp; B r = m_i32arrv(&rp, s); usz ri = 0;
if (TI(x,elType)==el_i32) {
i32* xp = i32any_ptr(x);
for (i32 i = 0; i < xia; i++) {
if (RARE(xp[i])<0) thrF("/: Argument must consist of natural numbers (contained %i)", xp[i]);
for (usz j = 0; j < xp[i]; j++) rp[ri++] = i;
}
} else {
BS2B xgetU = TI(x,getU);
for (i32 i = 0; i < xia; i++) {
usz c = o2s(xgetU(x, i));
for (usz j = 0; j < c; j++) rp[ri++] = i;
}
}
dec(x);
return r;
}
B slash_c2(B t, B w, B x) {
if (isArr(x) && rnk(x)==1 && isArr(w) && rnk(w)==1 && depth(w)==1) {
usz wia = a(w)->ia;
usz xia = a(x)->ia;
if (RARE(wia!=xia)) {
if (wia==0) { dec(w); return x; }
thrF("/: Lengths of components of 𝕨 must match 𝕩 (%s ≠ %s)", wia, xia);
}
B xf = getFillQ(x);
usz ri = 0;
if (TI(w,elType)==el_i32) {
i32* wp = i32any_ptr(w);
while (wia>0 && !wp[wia-1]) wia--;
i64 wsum = 0;
u32 or = 0;
for (usz i = 0; i < wia; i++) {
wsum+= wp[i];
or|= (u32)wp[i];
}
if (or>>31) thrM("/: 𝕨 must consist of natural numbers");
if (TI(x,elType)==el_i32) {
i32* xp = i32any_ptr(x);
i32* rp; B r = m_i32arrv(&rp, wsum);
if (or<2) {
for (usz i = 0; i < wia; i++) {
*rp = xp[i];
rp+= wp[i];
}
} else {
for (usz i = 0; i < wia; i++) {
i32 cw = wp[i];
i32 cx = xp[i];
for (usz j = 0; j < cw; j++) *rp++ = cx;
}
}
dec(w); dec(x);
return r;
} else if (TI(x,elType)==el_f64) {
f64* xp = f64any_ptr(x);
f64* rp; B r = m_f64arrv(&rp, wsum);
for (usz i = 0; i < wia; i++) {
i32 cw = wp[i];
f64 cx = xp[i];
for (usz j = 0; j < cw; j++) *rp++ = cx;
}
dec(w); dec(x);
return r;
} else {
HArr_p r = m_harrs(wsum, &ri);
BS2B xgetU = TI(x,getU);
for (usz i = 0; i < wia; i++) {
i32 cw = wp[i];
if (cw==0) continue;
B cx = xgetU(x, i);
for (usz j = 0; j < cw; j++) r.a[ri++] = inc(cx);
}
dec(w); dec(x);
return withFill(harr_fv(r), xf);
}
} else {
i64 ria = isum(w);
if (ria>USZ_MAX) thrOOM();
HArr_p r = m_harrs(ria, &ri);
BS2B wgetU = TI(w,getU);
BS2B xgetU = TI(x,getU);
for (usz i = 0; i < wia; i++) {
usz c = o2s(wgetU(w, i));
if (c) {
B cx = xgetU(x, i);
for (usz j = 0; j < c; j++) r.a[ri++] = inc(cx);
}
}
dec(w); dec(x);
return withFill(harr_fv(r), xf);
}
}
if (isArr(x) && rnk(x)==1 && q_i32(w)) {
usz xia = a(x)->ia;
i32 wv = o2i(w);
if (wv<=0) {
if (wv<0) thrM("/: 𝕨 cannot be negative");
Arr* r = TI(x,slice)(x, 0);
arr_shVec(r,0);
return taga(r);
}
usz ri = 0;
if (TI(x,elType)==el_i32) {
i32* xp = i32any_ptr(x);
i32* rp; B r = m_i32arrv(&rp, xia*wv);
for (usz i = 0; i < xia; i++) {
for (usz j = 0; j < wv; j++) rp[ri++] = xp[i];
}
dec(x);
return r;
} else {
B xf = getFillQ(x);
HArr_p r = m_harrUv(xia*wv);
BS2B xgetU = TI(x,getU);
for (usz i = 0; i < xia; i++) {
B cx = xgetU(x, i);
for (usz j = 0; j < wv; j++) r.a[ri++] = inc(cx);
}
dec(x);
return withFill(r.b, xf);
}
}
return c2(rt_slash, w, x);
}
B slicev(B x, usz s, usz ia) {
usz xia = a(x)->ia; assert(s+ia <= xia);
Arr* r = TI(x,slice)(x, s);
arr_shVec(r, ia);
return taga(r);
}
extern B rt_take, rt_drop;
B take_c1(B t, B x) { return c1(rt_take, x); }
B drop_c1(B t, B x) { return c1(rt_drop, x); }
B take_c2(B t, B w, B x) {
if (isNum(w) && isArr(x) && rnk(x)==1) {
i64 v = o2i64(w);
usz ia = a(x)->ia;
u64 va = v<0? -v : v;
if (va>ia) {
MAKE_MUT(r, va);
B xf = getFillE(x);
mut_copy(r, v<0? va-ia : 0, x, 0, ia);
mut_fill(r, v<0? 0 : ia, xf, va-ia);
dec(x);
dec(xf);
return mut_fv(r);
}
if (v<0) return slicev(x, ia+v, -v);
else return slicev(x, 0, v);
}
return c2(rt_take, w, x);
}
B drop_c2(B t, B w, B x) {
if (isNum(w) && isArr(x) && rnk(x)==1) {
i64 v = o2i64(w);
usz ia = a(x)->ia;
if (v<0) return -v>ia? slicev(x, 0, 0) : slicev(x, 0, v+ia);
else return v>ia? slicev(x, 0, 0) : slicev(x, v, ia-v);
}
return c2(rt_drop, w, x);
}
extern B rt_join;
B join_c1(B t, B x) {
if (isAtm(x)) thrM("∾: Argument must be an array");
if (rnk(x)==1) {
usz xia = a(x)->ia;
if (xia==0) {
B xf = getFillE(x);
if (isAtm(xf)) {
decR(xf);
if (!PROPER_FILLS) {
B xfq = getFillR(x);
bool no = noFill(xfq);
decR(xfq);
if (no) return x;
}
dec(x);
thrM("∾: Empty vector 𝕩 cannot have an atom fill element");
}
dec(x);
ur ir = rnk(xf);
if (ir==0) thrM("∾: Empty vector 𝕩 cannot have a unit fill element");
B xff = getFillQ(xf);
HArr_p r = m_harrUp(0);
usz* sh = arr_shAllocR((Arr*)r.c, ir);
if (sh) {
sh[0] = 0;
memcpy(sh+1, a(xf)->sh+1, sizeof(usz)*(ir-1));
}
dec(xf);
return withFill(r.b, xff);
}
BS2B xgetU = TI(x,getU);
B x0 = xgetU(x,0);
B rf; if(SFNS_FILLS) rf = getFillQ(x0);
if (isAtm(x0)) thrM("∾: Rank of items must be equal or greater than rank of argument");
usz ir = rnk(x0);
usz* x0sh = a(x0)->sh;
if (ir==0) thrM("∾: Rank of items must be equal or greater than rank of argument");
usz csz = arr_csz(x0);
usz cam = x0sh[0];
for (usz i = 1; i < xia; i++) {
B c = xgetU(x, i);
if (!isArr(c) || rnk(c)!=ir) thrF("∾: All items in argument should have same rank (contained items with ranks %i and %i)", ir, isArr(c)? rnk(c) : 0);
usz* csh = a(c)->sh;
if (ir>1) for (usz j = 1; j < ir; j++) if (csh[j]!=x0sh[j]) thrF("∾: Item trailing shapes must be equal (contained arrays with shapes %H and %H)", x0, c);
cam+= a(c)->sh[0];
if (SFNS_FILLS && !noFill(rf)) rf = fill_or(rf, getFillQ(c));
}
MAKE_MUT(r, cam*csz);
usz ri = 0;
for (usz i = 0; i < xia; i++) {
B c = xgetU(x, i);
usz cia = a(c)->ia;
mut_copy(r, ri, c, 0, cia);
ri+= cia;
}
assert(ri==cam*csz);
Arr* ra = mut_fp(r);
usz* sh = arr_shAllocR(ra, ir);
if (sh) {
sh[0] = cam;
memcpy(sh+1, x0sh+1, sizeof(usz)*(ir-1));
}
dec(x);
return SFNS_FILLS? qWithFill(taga(ra), rf) : taga(ra);
}
return c1(rt_join, x);
}
B join_c2(B t, B w, B x) {
if (isAtm(w)) w = m_atomUnit(w);
ur wr = rnk(w);
if (isAtm(x)) {
if (wr==1 && inplace_add(w, x)) return w;
x = m_atomUnit(x);
}
usz wia = a(w)->ia; usz* wsh = a(w)->sh;
usz xia = a(x)->ia; usz* xsh = a(x)->sh; ur xr = rnk(x);
B f = fill_both(w, x);
ur c = wr>xr?wr:xr;
if (c==0) {
HArr_p r = m_harrUv(2);
r.a[0] = TI(w,get)(w,0); dec(w);
r.a[1] = TI(x,get)(x,0); dec(x);
return qWithFill(r.b, f);
}
if (c-wr > 1 || c-xr > 1) thrF("∾: Argument ranks must differ by 1 or less (%i≡=𝕨, %i≡=𝕩)", wr, xr);
if (c==1) {
B r = vec_join(w, x);
if (rnk(r)==0) srnk(r,1);
return qWithFill(r, f);
}
MAKE_MUT(r, wia+xia);
mut_to(r, el_or(TI(w,elType), TI(x,elType)));
mut_copy(r, 0, w, 0, wia);
mut_copy(r, wia, x, 0, xia);
Arr* ra = mut_fp(r);
usz* sh = arr_shAllocR(ra, c);
if (sh) {
for (i32 i = 1; i < c; i++) {
usz s = xsh[i+xr-c];
if (wsh[i+wr-c] != s) { mut_pfree(r, wia+xia); thrF("∾: Lengths not matchable (%H ≡ ≢𝕨, %H ≡ ≢𝕩)", w, x); }
sh[i] = s;
}
sh[0] = (wr==c? wsh[0] : 1) + (xr==c? xsh[0] : 1);
}
dec(w); dec(x);
return qWithFill(taga(ra), f);
}
B couple_c1(B t, B x) {
if (isArr(x)) {
usz rr = rnk(x);
usz ia = a(x)->ia;
Arr* r = TI(x,slice)(inc(x),0);
usz* sh = arr_shAllocI(r, ia, rr+1);
if (sh) { sh[0] = 1; memcpy(sh+1, a(x)->sh, rr*sizeof(usz)); }
dec(x);
return taga(r);
}
if (q_i32(x)) { i32* rp; B r = m_i32arrv(&rp, 1); rp[0] = o2iu(x); return r; }
if (isF64(x)) { f64* rp; B r = m_f64arrv(&rp, 1); rp[0] = o2fu(x); return r; }
if (isC32(x)) { u32* rp; B r = m_c32arrv(&rp, 1); rp[0] = o2cu(x); return r; }
HArr_p r = m_harrUv(1);
r.a[0] = x;
return r.b;
}
B couple_c2(B t, B w, B x) {
if (isAtm(w)&isAtm(x)) {
if (q_i32(x)&q_i32(w)) { i32* rp; B r = m_i32arrv(&rp, 2); rp[0]=o2iu(w); rp[1]=o2iu(x); return r; }
if (isF64(x)&isF64(w)) { f64* rp; B r = m_f64arrv(&rp, 2); rp[0]=o2fu(w); rp[1]=o2fu(x); return r; }
if (isC32(x)&isC32(w)) { u32* rp; B r = m_c32arrv(&rp, 2); rp[0]=o2cu(w); rp[1]=o2cu(x); return r; }
}
if (isAtm(w)) w = m_atomUnit(w);
if (isAtm(x)) x = m_atomUnit(x);
if (!eqShape(w, x)) thrF("≍: 𝕨 and 𝕩 must have equal shapes (%H ≡ ≢𝕨, %H ≡ ≢𝕩)", w, x);
usz ia = a(w)->ia;
ur wr = rnk(w);
MAKE_MUT(r, ia*2);
mut_copy(r, 0, w, 0, ia);
mut_copy(r, ia, x, 0, ia);
Arr* ra = mut_fp(r);
usz* sh = arr_shAllocR(ra, wr+1);
if (sh) { sh[0]=2; memcpy(sh+1, a(w)->sh, wr*sizeof(usz)); }
if (!SFNS_FILLS) { dec(w); dec(x); return taga(ra); }
B rf = fill_both(w, x);
dec(w); dec(x);
return qWithFill(taga(ra), rf);
}
static inline void shift_check(B w, B x) {
ur wr = rnk(w); usz* wsh = a(w)->sh;
ur xr = rnk(x); usz* xsh = a(x)->sh;
if (wr+1!=xr & wr!=xr) thrF("shift: =𝕨 must be =𝕩 or ¯1+=𝕩 (%i≡=𝕨, %i≡=𝕩)", wr, xr);
for (i32 i = 1; i < xr; i++) if (wsh[i+wr-xr] != xsh[i]) thrF("shift: Lengths not matchable (%H ≡ ≢𝕨, %H ≡ ≢𝕩)", w, x);
}
B shiftb_c1(B t, B x) {
if (isAtm(x) || rnk(x)==0) thrM("»: Argument cannot be a scalar");
usz ia = a(x)->ia;
if (ia==0) return x;
B xf = getFillE(x);
usz csz = arr_csz(x);
MAKE_MUT(r, ia); mut_to(r, TI(x,elType));
mut_copy(r, csz, x, 0, ia-csz);
mut_fill(r, 0, xf, csz);
return qWithFill(mut_fcd(r, x), xf);
}
B shiftb_c2(B t, B w, B x) {
if (isAtm(x) || rnk(x)==0) thrM("»: 𝕩 cannot be a scalar");
if (isAtm(w)) w = m_atomUnit(w);
shift_check(w, x);
B f = fill_both(w, x);
usz wia = a(w)->ia;
usz xia = a(x)->ia;
MAKE_MUT(r, xia); mut_to(r, el_or(TI(w,elType), TI(x,elType)));
int mid = wia<xia? wia : xia;
mut_copy(r, 0 , w, 0, mid);
mut_copy(r, mid, x, 0, xia-mid);
dec(w);
return qWithFill(mut_fcd(r, x), f);
}
B shifta_c1(B t, B x) {
if (isAtm(x) || rnk(x)==0) thrM("«: Argument cannot be a scalar");
usz ia = a(x)->ia;
if (ia==0) return x;
B xf = getFillE(x);
usz csz = arr_csz(x);
MAKE_MUT(r, ia); mut_to(r, TI(x,elType));
mut_copy(r, 0, x, csz, ia-csz);
mut_fill(r, ia-csz, xf, csz);
return qWithFill(mut_fcd(r, x), xf);
}
B shifta_c2(B t, B w, B x) {
if (isAtm(x) || rnk(x)==0) thrM("«: 𝕩 cannot be a scalar");
if (isAtm(w)) w = m_atomUnit(w);
shift_check(w, x);
B f = fill_both(w, x);
usz wia = a(w)->ia;
usz xia = a(x)->ia;
MAKE_MUT(r, xia); mut_to(r, el_or(TI(w,elType), TI(x,elType)));
if (wia < xia) {
usz m = xia-wia;
mut_copy(r, 0, x, wia, m);
mut_copy(r, m, w, 0, wia);
} else {
mut_copy(r, 0, w, wia-xia, xia);
}
dec(w);
return qWithFill(mut_fcd(r, x), f);
}
extern B rt_group;
B group_c1(B t, B x) {
return c1(rt_group, x);
}
B group_c2(B t, B w, B x) {
if (isArr(w)&isArr(x) && rnk(w)==1 && rnk(x)==1 && depth(w)==1) {
usz wia = a(w)->ia;
usz xia = a(x)->ia;
if (wia-xia > 1) thrF("⊔: ≠𝕨 must be either ≠𝕩 or one bigger (%s≡≠𝕨, %s≡≠𝕩)", wia, xia);
if (TI(w,elType)==el_i32) {
i32* wp = i32any_ptr(w);
i64 ria = wia==xia? 0 : wp[xia];
if (ria<-1) thrM("⊔: 𝕨 can't contain elements less than ¯1");
ria--;
for (usz i = 0; i < xia; i++) if (wp[i]>ria) ria = wp[i];
if (ria>USZ_MAX-1) thrOOM();
ria++;
TALLOC(i32, lenO, ria+1); i32* len = lenO+1;
TALLOC(i32, pos, ria);
for (usz i = 0; i < ria; i++) len[i] = pos[i] = 0;
for (usz i = 0; i < xia; i++) {
i32 n = wp[i];
if (n<-1) thrM("⊔: 𝕨 can't contain elements less than ¯1");
len[n]++; // overallocation makes this safe after n<-1 check
}
Arr* r = m_fillarrp(ria); fillarr_setFill(r, m_f64(0));
arr_shVec(r, ria);
B* rp = fillarr_ptr(r);
for (usz i = 0; i < ria; i++) rp[i] = m_f64(0); // don't break if allocation errors
B xf = getFillQ(x);
Arr* rf = m_fillarrp(0); fillarr_setFill(rf, m_f64(0));
arr_shVec(rf, 0);
fillarr_setFill(r, taga(rf));
if (TI(x,elType)==el_i32) {
for (usz i = 0; i < ria; i++) { i32* t; rp[i] = m_i32arrv(&t, len[i]); }
i32* xp = i32any_ptr(x);
for (usz i = 0; i < xia; i++) {
i32 n = wp[i];
if (n>=0) i32arr_ptr(rp[n])[pos[n]++] = xp[i];
}
} else if (TI(x,elType)==el_c32) {
for (usz i = 0; i < ria; i++) { u32* t; rp[i] = m_c32arrv(&t, len[i]); }
u32* xp = c32any_ptr(x);
for (usz i = 0; i < xia; i++) {
i32 n = wp[i];
if (n>=0) c32arr_ptr(rp[n])[pos[n]++] = xp[i];
}
} else {
for (usz i = 0; i < ria; i++) {
Arr* c = m_fillarrp(len[i]);
fillarr_setFill(c, inc(xf));
c->ia = 0;
rp[i] = taga(c);
}
BS2B xget = TI(x,get);
for (usz i = 0; i < xia; i++) {
i32 n = wp[i];
if (n>=0) fillarr_ptr(a(rp[n]))[pos[n]++] = xget(x, i);
}
for (usz i = 0; i < ria; i++) { arr_shVec(a(rp[i]), len[i]); }
}
fillarr_setFill(rf, xf);
dec(w); dec(x); TFREE(lenO); TFREE(pos);
return taga(r);
} else {
BS2B wgetU = TI(w,getU);
i64 ria = wia==xia? 0 : o2i64(wgetU(w, xia));
if (ria<-1) thrM("⊔: 𝕨 can't contain elements less than ¯1");
ria--;
for (usz i = 0; i < xia; i++) {
B cw = wgetU(w, i);
if (!q_i64(cw)) goto base;
i64 c = o2i64u(cw);
if (c>ria) ria = c;
if (c<-1) thrM("⊔: 𝕨 can't contain elements less than ¯1");
}
if (ria>USZ_MAX-1) thrOOM();
ria++;
TALLOC(i32, lenO, ria+1); i32* len = lenO+1;
TALLOC(i32, pos, ria);
for (usz i = 0; i < ria; i++) len[i] = pos[i] = 0;
for (usz i = 0; i < xia; i++) len[o2i64u(wgetU(w, i))]++;
Arr* r = m_fillarrp(ria); fillarr_setFill(r, m_f64(0));
arr_shVec(r, ria);
B* rp = fillarr_ptr(r);
for (usz i = 0; i < ria; i++) rp[i] = m_f64(0); // don't break if allocation errors
B xf = getFillQ(x);
for (usz i = 0; i < ria; i++) {
Arr* c = m_fillarrp(len[i]);
fillarr_setFill(c, inc(xf));
c->ia = 0;
rp[i] = taga(c);
}
Arr* rf = m_fillarrp(0);
arr_shVec(rf, 0);
fillarr_setFill(rf, xf);
fillarr_setFill(r, taga(rf));
BS2B xget = TI(x,get);
for (usz i = 0; i < xia; i++) {
i64 n = o2i64u(wgetU(w, i));
if (n>=0) fillarr_ptr(a(rp[n]))[pos[n]++] = xget(x, i);
}
for (usz i = 0; i < ria; i++) { arr_shVec(a(rp[i]), len[i]); }
dec(w); dec(x); TFREE(lenO); TFREE(pos);
return taga(r);
}
}
base:
return c2(rt_group, w, x);
}
extern B rt_reverse;
B reverse_c1(B t, B x) {
if (isAtm(x) || rnk(x)==0) thrM("⌽: Argument cannot be a unit");
B xf = getFillQ(x);
u8 xe = TI(x,elType);
usz xia = a(x)->ia;
if (rnk(x)==1) {
if (xe==el_i32) {
i32* xp = i32any_ptr(x);
i32* rp; B r = m_i32arrv(&rp, xia);
for (usz i = 0; i < xia; i++) rp[i] = xp[xia-i-1];
dec(x);
return r;
}
}
usz csz = arr_csz(x);
usz cam = a(x)->sh[0];
usz rp = 0;
usz ip = xia;
MAKE_MUT(r, xia); mut_to(r, xe);
for (usz i = 0; i < cam; i++) {
ip-= csz;
mut_copy(r, rp, x, ip, csz);
rp+= csz;
}
return withFill(mut_fcd(r, x), xf);
}
B reverse_c2(B t, B w, B x) {
if (isArr(w)) return c2(rt_reverse, w, x);
if (isAtm(x) || rnk(x)==0) thrM("⌽: 𝕩 must have rank at least 1 for atom 𝕨");
usz xia = a(x)->ia;
if (xia==0) return x;
B xf = getFillQ(x);
usz cam = a(x)->sh[0];
usz csz = arr_csz(x);
i64 am = o2i64(w);
if ((u64)am >= (u64)cam) { am%= (i64)cam; if(am<0) am+= cam; }
am*= csz;
MAKE_MUT(r, xia); mut_to(r, TI(x,elType));
mut_copy(r, 0, x, am, xia-am);
mut_copy(r, xia-am, x, 0, am);
return withFill(mut_fcd(r, x), xf);
}
B reverse_uc1(B t, B o, B x) {
return reverse_c1(t, c1(o, reverse_c1(t, x)));
}
B pick_uc1(B t, B o, B x) {
if (isAtm(x) || a(x)->ia==0) return def_fn_uc1(t, o, x);
B xf = getFillQ(x);
usz ia = a(x)->ia;
B arg = TI(x,get)(x, 0);
B rep = c1(o, arg);
MAKE_MUT(r, ia); mut_to(r, el_or(TI(x,elType), selfElType(rep)));
mut_set(r, 0, rep);
mut_copy(r, 1, x, 1, ia-1);
return qWithFill(mut_fcd(r, x), xf);
}
B pick_ucw(B t, B o, B w, B x) {
if (isArr(w) || isAtm(x) || rnk(x)!=1) return def_fn_ucw(t, o, w, x);
usz xia = a(x)->ia;
usz wi = WRAP(o2i64(w), xia, thrF("𝔽⌾(n⊸⊑)𝕩: reading out-of-bounds (n≡%R, %s≡≠𝕩)", w, xia));
B xf = getFillQ(x);
B arg = TI(x,get)(x, wi);
B rep = c1(o, arg);
if (reusable(x) && TI(x,canStore)(rep)) {
if (TI(x,elType)==el_i32) {
i32* xp = i32any_ptr(x);
xp[wi] = o2i(rep);
return x;
} else if (v(x)->type==t_harr) {
B* xp = harr_ptr(x);
dec(xp[wi]);
xp[wi] = rep;
return x;
} else if (TI(x,elType)==el_f64) {
f64* xp = f64any_ptr(x);
xp[wi] = o2f(rep);
return x;
} else if (v(x)->type==t_fillarr) {
B* xp = fillarr_ptr(a(x));
dec(xp[wi]);
xp[wi] = rep;
return x;
}
}
MAKE_MUT(r, xia); mut_to(r, el_or(TI(x,elType), selfElType(rep)));
mut_set(r, wi, rep);
mut_copy(r, 0, x, 0, wi);
mut_copy(r, wi+1, x, wi+1, xia-wi-1);
return qWithFill(mut_fcd(r, x), xf);
}
B slash_ucw(B t, B o, B w, B x) {
if (isAtm(w) || isAtm(x) || rnk(w)!=1 || rnk(x)!=1 || a(w)->ia!=a(x)->ia) return def_fn_ucw(t, o, w, x);
usz ia = a(x)->ia;
BS2B wgetU = TI(w,getU);
if (TI(w,elType)!=el_i32) for (usz i = 0; i < ia; i++) if (!q_i32(wgetU(w,i))) return def_fn_ucw(t, o, w, x);
B arg = slash_c2(t, inc(w), inc(x));
usz argIA = a(arg)->ia;
B rep = c1(o, arg);
if (isAtm(rep) || rnk(rep)!=1 || a(rep)->ia != argIA) thrF("𝔽⌾(a⊸/)𝕩: Result of 𝔽 must have the same shape as a/𝕩 (expected ⟨%s⟩, got %H)", argIA, rep);
MAKE_MUT(r, ia); mut_to(r, el_or(TI(x,elType), TI(rep,elType)));
BS2B xget = TI(x,get);
BS2B rgetU = TI(rep,getU);
BS2B rget = TI(rep,get);
usz repI = 0;
for (usz i = 0; i < ia; i++) {
i32 cw = o2iu(wgetU(w, i));
if (cw) {
B cr = rget(rep,repI);
if (CHECK_VALID) for (i32 j = 1; j < cw; j++) if (!equal(rgetU(rep,repI+j), cr)) { mut_pfree(r,i); thrM("𝔽⌾(a⊸/): Incompatible result elements"); }
mut_set(r, i, cr);
repI+= cw;
} else mut_set(r, i, xget(x,i));
}
dec(w); dec(rep);
return mut_fcd(r, x);
}
B select_ucw(B t, B o, B w, B x) {
if (isAtm(x) || rnk(x)!=1 || isAtm(w) || rnk(w)!=1) return def_fn_ucw(t, o, w, x);
usz xia = a(x)->ia;
usz wia = a(w)->ia;
BS2B wgetU = TI(w,getU);
if (TI(w,elType)!=el_i32) for (usz i = 0; i < wia; i++) if (!q_i64(wgetU(w,i))) return def_fn_ucw(t, o, w, x);
B arg = select_c2(t, inc(w), inc(x));
B rep = c1(o, arg);
if (isAtm(rep) || rnk(rep)!=1 || a(rep)->ia != wia) thrF("𝔽⌾(a⊸⊏)𝕩: Result of 𝔽 must have the same shape as a⊏𝕩 (expected ⟨%s⟩, got %H)", wia, rep);
#if CHECK_VALID
TALLOC(bool, set, xia);
for (i64 i = 0; i < xia; i++) set[i] = false;
#define EQ(F) if (set[cw] && (F)) thrM("𝔽⌾(a⊸⊏): Incompatible result elements"); set[cw] = true;
#define FREE_CHECK TFREE(set)
#else
#define EQ(F)
#define FREE_CHECK
#endif
if (TI(w,elType)==el_i32) {
i32* wp = i32any_ptr(w);
if (reusable(x) && TI(x,elType)==TI(rep,elType)) {
if (v(x)->type==t_i32arr) {
i32* xp = i32arr_ptr(x);
i32* rp = i32any_ptr(rep);
for (usz i = 0; i < wia; i++) {
i64 cw = wp[i]; if (cw<0) cw+= (i64)xia; // already checked
i32 cr = rp[i];
EQ(cr!=xp[cw]);
xp[cw] = cr;
}
dec(w); dec(rep); FREE_CHECK;
return x;
} else if (v(x)->type==t_harr) {
B* xp = harr_ptr(x);
BS2B rget = TI(rep,get);
for (usz i = 0; i < wia; i++) {
i64 cw = wp[i]; if (cw<0) cw+= (i64)xia;
B cr = rget(rep, i);
EQ(!equal(cr,xp[cw]));
dec(xp[cw]);
xp[cw] = cr;
}
dec(w); dec(rep); FREE_CHECK;
return x;
}
}
MAKE_MUT(r, xia); mut_to(r, el_or(TI(x,elType), TI(rep,elType)));
mut_copy(r, 0, x, 0, xia);
BS2B rget = TI(rep,get);
for (usz i = 0; i < wia; i++) {
i64 cw = wp[i]; if (cw<0) cw+= (i64)xia;
B cr = rget(rep, i);
EQ(!equal(mut_getU(r, cw), cr));
mut_rm(r, cw);
mut_setS(r, cw, cr);
}
dec(w); dec(rep); FREE_CHECK;
return mut_fcd(r, x);
}
MAKE_MUT(r, xia); mut_to(r, el_or(TI(x,elType), TI(rep,elType)));
mut_copy(r, 0, x, 0, xia);
BS2B rget = TI(rep,get);
for (usz i = 0; i < wia; i++) {
i64 cw = o2i64u(wgetU(w, i)); if (cw<0) cw+= (i64)xia;
B cr = rget(rep, i);
EQ(!equal(mut_getU(r, cw), cr));
mut_rm(r, cw);
mut_set(r, cw, cr);
}
dec(w); dec(rep); FREE_CHECK;
return mut_fcd(r, x);
#undef EQ
#undef FREE_CHECK
}
void sfns_init() {
c(BFn,bi_pick)->uc1 = pick_uc1;
c(BFn,bi_reverse)->uc1 = reverse_uc1;
c(BFn,bi_pick)->ucw = pick_ucw;
c(BFn,bi_slash)->ucw = slash_ucw;
c(BFn,bi_select)->ucw = select_ucw;
}