uCBQN/src/md1.c
2021-05-03 15:22:46 +03:00

199 lines
6.2 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 "h.h"
bool isPureFn(B x) { // doesn't consume
if (!isFun(x) && !isMd(x)) return true;
if (v(x)->flags) return true;
B2B dcf = TI(x).decompose;
B xd = dcf(inc(x));
B* xdp = harr_ptr(xd);
i32 t = o2iu(xdp[0]);
if (t<2) { dec(xd); return t==0; }
usz xdia = a(xd)->ia;
for (i32 i = 1; i<xdia; i++) if(!isPureFn(xdp[i])) { dec(xd); return false; }
dec(xd); return true;
}
B homFil1(B f, B r, B xf) {
assert(EACH_FILLS);
if (isPureFn(f)) {
if (f.u==bi_eq.u || f.u==bi_ne.u || f.u==bi_feq.u) { dec(xf); return tag(toI32Arr(r), ARR_TAG); } // ≠ may return ≥2⋆31, but whatever, this thing is stupid anyway
if (f.u==bi_fne.u) { dec(xf); return withFill(r, m_harrUv(0).b); }
if (!noFill(xf)) {
if (CATCH) { dec(catchMessage); return r; }
B rf = asFill(c1(f, xf));
popCatch();
return withFill(r, rf);
}
}
dec(xf);
return r;
}
B homFil2(B f, B r, B wf, B xf) {
assert(EACH_FILLS);
if (isPureFn(f)) {
if (f.u==bi_feq.u || f.u==bi_fne.u) { dec(wf); dec(xf); return tag(toI32Arr(r), ARR_TAG); }
if (!noFill(wf) && !noFill(xf)) {
if (CATCH) { dec(catchMessage); return r; }
B rf = asFill(c2(f, wf, xf));
popCatch();
return withFill(r, rf);
}
}
dec(wf); dec(xf);
return r;
}
B tbl_c1(B d, B x) { B f = c(Md1D,d)->f;
if (!EACH_FILLS) return eachm(f, x);
B xf = getFillQ(x);
return homFil1(f, eachm(f, x), xf);
}
B tbl_c2(B d, B w, B x) { B f = c(Md1D,d)->f;
B wf, xf;
if (EACH_FILLS) wf = getFillQ(w);
if (EACH_FILLS) xf = getFillQ(x);
if (isAtm(w)) w = m_atomUnit(w);
if (isAtm(x)) x = m_atomUnit(x);
usz wia = a(w)->ia; ur wr = rnk(w);
usz xia = a(x)->ia; ur xr = rnk(x);
usz ria = wia*xia; ur rr = wr+xr;
if (rr<xr) thrM("⌜: Required result rank too large");
BS2B wgetU = TI(w).getU;
BS2B xget = TI(x).get;
BBB2B fc2 = c2fn(f);
usz ri = 0;
HArr_p r = m_harrs(ria, &ri);
for (usz wi = 0; wi < wia; wi++) {
B cw = wgetU(w,wi);
for (usz xi = 0; xi < xia; xi++,ri++) {
r.a[ri] = fc2(f, inc(cw), xget(x,xi));
}
}
usz* rsh = harr_fa(r, rr);
if (rsh) {
memcpy(rsh , a(w)->sh, wr*sizeof(usz));
memcpy(rsh+wr, a(x)->sh, xr*sizeof(usz));
}
dec(w); dec(x);
if (EACH_FILLS) return homFil2(f, r.b, wf, xf);
return r.b;
}
B each_c1(B d, B x) { B f = c(Md1D,d)->f;
if (!EACH_FILLS) return eachm(f, x);
B xf = getFillQ(x);
return homFil1(f, eachm(f, x), xf);
}
B each_c2(B d, B w, B x) { B f = c(Md1D,d)->f;
if (!EACH_FILLS) return eachd(f, w, x);
B wf = getFillQ(w);
B xf = getFillQ(x);
return homFil2(f, eachd(f, w, x), wf, xf);
}
B scan_c1(B d, B x) { B f = c(Md1D,d)->f;
if (isAtm(x) || rnk(x)==0) thrM("`: Argument cannot have rank 0");
B xf = getFillQ(x);
ur xr = rnk(x);
usz ia = a(x)->ia;
if (ia==0) return x;
bool reuse = v(x)->type==t_harr && reusable(x);
usz i = 0;
HArr_p r = reuse? harr_parts(x) : m_harrs(a(x)->ia, &i);
BS2B xget = reuse? TI(x).getU : TI(x).get;
BBB2B fc2 = c2fn(f);
if (xr==1) {
r.a[i] = xget(x,0); i++;
for (i = 1; i < ia; i++) r.a[i] = fc2(f, inc(r.a[i-1]), xget(x,i));
} else {
usz csz = arr_csz(x);
for (; i < csz; i++) r.a[i] = xget(x,i);
for (; i < ia; i++) r.a[i] = fc2(f, inc(r.a[i-csz]), xget(x,i));
}
return withFill(reuse? x : harr_fcd(r, x), xf);
}
B scan_c2(B d, B w, B x) { B f = c(Md1D,d)->f;
if (isAtm(x) || rnk(x)==0) thrM("`: 𝕩 cannot have rank 0");
ur xr = rnk(x); usz* xsh = a(x)->sh; usz ia = a(x)->ia;
B wf = getFillQ(w);
bool reuse = (v(x)->type==t_harr && reusable(x)) | !ia;
usz i = 0;
HArr_p r = reuse? harr_parts(x) : m_harrs(a(x)->ia, &i);
BS2B xget = reuse? TI(x).getU : TI(x).get;
BBB2B fc2 = c2fn(f);
if (isArr(w)) {
ur wr = rnk(w); usz* wsh = a(w)->sh; BS2B wget = TI(w).get;
if (wr+1 != xr) thrM("`: Shape of 𝕨 must match the cell of 𝕩");
if (memcmp(wsh, xsh+1, wr)) thrM("`: Shape of 𝕨 must match the cell of 𝕩");
if (ia==0) return x;
usz csz = arr_csz(x);
for (; i < csz; i++) r.a[i] = fc2(f, wget(w,i), xget(x,i));
for (; i < ia; i++) r.a[i] = fc2(f, inc(r.a[i-csz]), xget(x,i));
dec(w);
} else {
if (xr!=1) thrM("`: Shape of 𝕨 must match the cell of 𝕩");
if (ia==0) return x;
B pr = r.a[0] = fc2(f, w, xget(x,0)); i++;
for (; i < ia; i++) r.a[i] = pr = fc2(f, inc(pr), xget(x,i));
}
return withFill(reuse? x : harr_fcd(r, x), wf);
}
B fold_c1(B d, B x) { B f = c(Md1D,d)->f;
if (isAtm(x) || rnk(x)!=1) thrM("´: argument must be a list");
usz ia = a(x)->ia;
if (ia==0) {
dec(x);
if (isFun(f)) {
B r = TI(f).identity(f);
if (!isNothing(r)) return inc(r);
}
thrM("´: No identity found");
}
BS2B xget = TI(x).get;
B c = xget(x, ia-1);
BBB2B fc2 = c2fn(f);
for (usz i = ia-1; i>0; i--) c = fc2(f, xget(x, i-1), c);
dec(x);
return c;
}
B fold_c2(B d, B w, B x) { B f = c(Md1D,d)->f;
if (isAtm(x) || rnk(x)!=1) thrM("´: 𝕩 must be a list");
usz ia = a(x)->ia;
B c = w;
BS2B xget = TI(x).get;
BBB2B fc2 = c2fn(f);
for (usz i = ia; i>0; i--) c = fc2(f, xget(x, i-1), c);
dec(x);
return c;
}
B const_c1(B d , B x) { dec(x); return inc(c(Md1D,d)->f); }
B const_c2(B d, B w, B x) { dec(w); dec(x); return inc(c(Md1D,d)->f); }
B swap_c1(B d , B x) { return c2(c(Md1D,d)->f, inc(x), x); }
B swap_c2(B d, B w, B x) { return c2(c(Md1D,d)->f, x , w); }
#define ba(NAME) bi_##NAME = mm_alloc(sizeof(Md1), t_md1BI, ftag(MD1_TAG)); c(Md1,bi_##NAME)->c2 = NAME##_c2; c(Md1,bi_##NAME)->c1 = NAME##_c1 ; c(Md1,bi_##NAME)->extra=pm1_##NAME; gc_add(bi_##NAME);
#define bd(NAME) bi_##NAME = mm_alloc(sizeof(Md1), t_md1BI, ftag(MD1_TAG)); c(Md1,bi_##NAME)->c2 = NAME##_c2; c(Md1,bi_##NAME)->c1 = c1_invalid; c(Md1,bi_##NAME)->extra=pm1_##NAME; gc_add(bi_##NAME);
#define bm(NAME) bi_##NAME = mm_alloc(sizeof(Md1), t_md1BI, ftag(MD1_TAG)); c(Md1,bi_##NAME)->c2 = c2_invalid;c(Md1,bi_##NAME)->c1 = NAME##_c1 ; c(Md1,bi_##NAME)->extra=pm1_##NAME; gc_add(bi_##NAME);
void print_md1_def(B x) { printf("%s", format_pm1(c(Md1,x)->extra)); }
B bi_tbl, bi_each, bi_fold, bi_scan, bi_const, bi_swap;
static inline void md1_init() { ba(tbl) ba(each) ba(fold) ba(scan) ba(const) ba(swap)
ti[t_md1BI].print = print_md1_def;
}
#undef ba
#undef bd
#undef bm