diff --git a/makefile b/makefile index cfe75915..b8649cf9 100644 --- a/makefile +++ b/makefile @@ -247,7 +247,7 @@ ${bd}/%.o: src/jit/%.c @echo $< | cut -c 5- @$(CC_INC) $@.d -o $@ -c $< -builtins: ${addprefix ${bd}/, arithm.o arithd.o cmp.o sfns.o squeeze.o select.o slash.o group.o sort.o search.o selfsearch.o scan.o md1.o md2.o fns.o sysfn.o internal.o inverse.o} +builtins: ${addprefix ${bd}/, arithm.o arithd.o cmp.o sfns.o squeeze.o select.o slash.o group.o sort.o search.o selfsearch.o fold.o scan.o md1.o md2.o fns.o sysfn.o internal.o inverse.o} ${bd}/%.o: src/builtins/%.c @echo $< | cut -c 5- @$(CC_INC) $@.d -o $@ -c $< diff --git a/src/builtins/fold.c b/src/builtins/fold.c new file mode 100644 index 00000000..25a203f9 --- /dev/null +++ b/src/builtins/fold.c @@ -0,0 +1,142 @@ +#include "../core.h" +#include "../builtins.h" + +static bool fold_ne(u64* x, u64 am) { + u64 r = 0; + for (u64 i = 0; i < (am>>6); i++) r^= x[i]; + if (am&63) r^= x[am>>6]<<(64-am & 63); + return POPC(r) & 1; +} + +static i64 bit_diff(u64* x, u64 am) { + i64 r = 0; + u64 a = 0xAAAAAAAAAAAAAAAA; + for (u64 i = 0; i < (am>>6); i++) r+= POPC(x[i]^a); + if (am&63) r+= POPC((x[am>>6]^a)<<(64-am & 63)); + return r - (i64)(am/2); +} + +B fold_c1(Md1D* d, B x) { B f = d->f; + if (isAtm(x) || RNK(x)!=1) thrF("´: Argument must be a list (%H ≡ ≢𝕩)", x); + usz ia = IA(x); + if (ia==0) { + decG(x); + if (isFun(f)) { + B r = TI(f,identity)(f); + if (!q_N(r)) return inc(r); + } + thrM("´: No identity found"); + } + u8 xe = TI(x,elType); + if (isFun(f) && v(f)->flags && xe<=el_f64) { + u8 rtid = v(f)->flags-1; + if (xe==el_bit) { + u64* xp = bitarr_ptr(x); + if (rtid==n_add) { B r = m_f64(bit_sum (xp, ia)); decG(x); return r; } + if (rtid==n_sub) { B r = m_f64(bit_diff(xp, ia)); decG(x); return r; } + if (rtid==n_and | rtid==n_mul | rtid==n_floor) { B r = m_i32(!bit_has(xp, ia, 0)); decG(x); return r; } + if (rtid==n_or | rtid==n_ceil ) { B r = m_i32( bit_has(xp, ia, 1)); decG(x); return r; } + if (rtid==n_ne) { bool r=fold_ne(xp, ia) ; decG(x); return m_i32(r); } + if (rtid==n_eq) { bool r=fold_ne(xp, ia) ^ (1&~ia); decG(x); return m_i32(r); } + goto base; + } + if (rtid==n_add) { // + + if (xe==el_i8 ) { i8* xp = i8any_ptr (x); i64 c=0; for (usz i=0; ic) c=xp[i]; decG(x); return m_i32(c); } + if (xe==el_i16) { i16* xp = i16any_ptr(x); i16 c=I16_MIN; for (usz i=0; ic) c=xp[i]; decG(x); return m_i32(c); } + if (xe==el_i32) { i32* xp = i32any_ptr(x); i32 c=I32_MIN; for (usz i=0; ic) c=xp[i]; decG(x); return m_i32(c); } + } + if (rtid==n_or) { // ∨ + if (xe==el_i8 ) { i8* xp = i8any_ptr (x); bool r=0; for (usz i=0; i0; i--) c = fc2(f, m_i32(xp[i-1]), c); + } else { + c = Get(x, ia-1); + for (usz i = ia-1; i>0; i--) c = fc2(f, Get(x, i-1), c); + } + decG(x); + return c; +} + +B fold_c2(Md1D* d, B w, B x) { B f = d->f; + if (isAtm(x) || RNK(x)!=1) thrF("´: 𝕩 must be a list (%H ≡ ≢𝕩)", x); + usz ia = IA(x); + u8 xe = TI(x,elType); + if (q_i32(w) && isFun(f) && v(f)->flags && elInt(xe)) { + i32 wi = o2iG(w); + u8 rtid = v(f)->flags-1; + if (xe==el_bit) { + u64* xp = bitarr_ptr(x); + if (rtid==n_add) { B r = m_f64(wi + bit_sum (xp, ia)); decG(x); return r; } + if (rtid==n_sub) { B r = m_f64((ia&1?-wi:wi) + bit_diff(xp, ia)); decG(x); return r; } + if (wi!=(wi&1)) goto base; + if (rtid==n_and | rtid==n_mul | rtid==n_floor) { B r = m_i32(wi && !bit_has(xp, ia, 0)); decG(x); return r; } + if (rtid==n_or | rtid==n_ceil ) { B r = m_i32(wi || bit_has(xp, ia, 1)); decG(x); return r; } + if (rtid==n_ne) { bool r=wi^fold_ne(xp, ia) ; decG(x); return m_i32(r); } + if (rtid==n_eq) { bool r=wi^fold_ne(xp, ia) ^ (1&ia); decG(x); return m_i32(r); } + goto base; + } + if (rtid==n_add) { // + + if (xe==el_i8 ) { i8* xp = i8any_ptr (x); i64 c=wi; for (usz i=0; ic) c=xp[i]; decG(x); return m_i32(c); } + if (xe==el_i16) { i16* xp = i16any_ptr(x); i32 c=wi; for (usz i=0; ic) c=xp[i]; decG(x); return m_i32(c); } + if (xe==el_i32) { i32* xp = i32any_ptr(x); i32 c=wi; for (usz i=0; ic) c=xp[i]; decG(x); return m_i32(c); } + } + if (rtid==n_or && (wi&1)==wi) { // ∨ + if (xe==el_i8 ) { i8* xp = i8any_ptr (x); bool q=wi; for (usz i=0; i0; i--) c = fc2(f, Get(x, i-1), c); + decG(x); + return c; +} diff --git a/src/builtins/md1.c b/src/builtins/md1.c index 01cb30de..e5f9e5ed 100644 --- a/src/builtins/md1.c +++ b/src/builtins/md1.c @@ -107,143 +107,6 @@ B each_c2(Md1D* d, B w, B x) { B f = d->f; return homFil2(f, eachd(f, w, x), wf, xf); } -static bool fold_ne(u64* x, u64 am) { - u64 r = 0; - for (u64 i = 0; i < (am>>6); i++) r^= x[i]; - if (am&63) r^= x[am>>6]<<(64-am & 63); - return POPC(r) & 1; -} -static i64 bit_diff(u64* x, u64 am) { - i64 r = 0; - u64 a = 0xAAAAAAAAAAAAAAAA; - for (u64 i = 0; i < (am>>6); i++) r+= POPC(x[i]^a); - if (am&63) r+= POPC((x[am>>6]^a)<<(64-am & 63)); - return r - (i64)(am/2); -} -B fold_c1(Md1D* d, B x) { B f = d->f; - if (isAtm(x) || RNK(x)!=1) thrF("´: Argument must be a list (%H ≡ ≢𝕩)", x); - usz ia = IA(x); - if (ia==0) { - decG(x); - if (isFun(f)) { - B r = TI(f,identity)(f); - if (!q_N(r)) return inc(r); - } - thrM("´: No identity found"); - } - u8 xe = TI(x,elType); - if (isFun(f) && v(f)->flags && xe<=el_f64) { - u8 rtid = v(f)->flags-1; - if (xe==el_bit) { - u64* xp = bitarr_ptr(x); - if (rtid==n_add) { B r = m_f64(bit_sum (xp, ia)); decG(x); return r; } - if (rtid==n_sub) { B r = m_f64(bit_diff(xp, ia)); decG(x); return r; } - if (rtid==n_and | rtid==n_mul | rtid==n_floor) { B r = m_i32(!bit_has(xp, ia, 0)); decG(x); return r; } - if (rtid==n_or | rtid==n_ceil ) { B r = m_i32( bit_has(xp, ia, 1)); decG(x); return r; } - if (rtid==n_ne) { bool r=fold_ne(xp, ia) ; decG(x); return m_i32(r); } - if (rtid==n_eq) { bool r=fold_ne(xp, ia) ^ (1&~ia); decG(x); return m_i32(r); } - goto base; - } - if (rtid==n_add) { // + - if (xe==el_i8 ) { i8* xp = i8any_ptr (x); i64 c=0; for (usz i=0; ic) c=xp[i]; decG(x); return m_i32(c); } - if (xe==el_i16) { i16* xp = i16any_ptr(x); i16 c=I16_MIN; for (usz i=0; ic) c=xp[i]; decG(x); return m_i32(c); } - if (xe==el_i32) { i32* xp = i32any_ptr(x); i32 c=I32_MIN; for (usz i=0; ic) c=xp[i]; decG(x); return m_i32(c); } - } - if (rtid==n_or) { // ∨ - if (xe==el_i8 ) { i8* xp = i8any_ptr (x); bool r=0; for (usz i=0; i0; i--) c = fc2(f, m_i32(xp[i-1]), c); - } else { - c = Get(x, ia-1); - for (usz i = ia-1; i>0; i--) c = fc2(f, Get(x, i-1), c); - } - decG(x); - return c; -} -B fold_c2(Md1D* d, B w, B x) { B f = d->f; - if (isAtm(x) || RNK(x)!=1) thrF("´: 𝕩 must be a list (%H ≡ ≢𝕩)", x); - usz ia = IA(x); - u8 xe = TI(x,elType); - if (q_i32(w) && isFun(f) && v(f)->flags && elInt(xe)) { - i32 wi = o2iG(w); - u8 rtid = v(f)->flags-1; - if (xe==el_bit) { - u64* xp = bitarr_ptr(x); - if (rtid==n_add) { B r = m_f64(wi + bit_sum (xp, ia)); decG(x); return r; } - if (rtid==n_sub) { B r = m_f64((ia&1?-wi:wi) + bit_diff(xp, ia)); decG(x); return r; } - if (wi!=(wi&1)) goto base; - if (rtid==n_and | rtid==n_mul | rtid==n_floor) { B r = m_i32(wi && !bit_has(xp, ia, 0)); decG(x); return r; } - if (rtid==n_or | rtid==n_ceil ) { B r = m_i32(wi || bit_has(xp, ia, 1)); decG(x); return r; } - if (rtid==n_ne) { bool r=wi^fold_ne(xp, ia) ; decG(x); return m_i32(r); } - if (rtid==n_eq) { bool r=wi^fold_ne(xp, ia) ^ (1&ia); decG(x); return m_i32(r); } - goto base; - } - if (rtid==n_add) { // + - if (xe==el_i8 ) { i8* xp = i8any_ptr (x); i64 c=wi; for (usz i=0; ic) c=xp[i]; decG(x); return m_i32(c); } - if (xe==el_i16) { i16* xp = i16any_ptr(x); i32 c=wi; for (usz i=0; ic) c=xp[i]; decG(x); return m_i32(c); } - if (xe==el_i32) { i32* xp = i32any_ptr(x); i32 c=wi; for (usz i=0; ic) c=xp[i]; decG(x); return m_i32(c); } - } - if (rtid==n_or && (wi&1)==wi) { // ∨ - if (xe==el_i8 ) { i8* xp = i8any_ptr (x); bool q=wi; for (usz i=0; i0; i--) c = fc2(f, Get(x, i-1), c); - decG(x); - return c; -} - B const_c1(Md1D* d, B x) { dec(x); return inc(d->f); } B const_c2(Md1D* d, B w, B x) { dec(w); dec(x); return inc(d->f); } @@ -392,6 +255,7 @@ B cell_c2(Md1D* d, B w, B x) { B f = d->f; return bqn_merge(r); } +extern B fold_c1(Md1D* d, B x); extern B rt_insert; B insert_c1(Md1D* d, B x) { B f = d->f; if (isAtm(x) || RNK(x)==0) thrM("˝: 𝕩 must have rank at least 1"); diff --git a/src/opt/single.c b/src/opt/single.c index 91f44ee4..7eb3dd86 100644 --- a/src/opt/single.c +++ b/src/opt/single.c @@ -24,6 +24,7 @@ #include "../builtins/sort.c" #include "../builtins/search.c" #include "../builtins/selfsearch.c" +#include "../builtins/fold.c" #include "../builtins/scan.c" #include "../builtins/arithm.c" #include "../builtins/arithd.c"