/* Calculations (this supplements Numbers-C.pm)
 *
 * This file is part of CLC-INTERCAL
 *
 * Copyright (C) 2023 Claudio Calvelli, all rights reserved
 *
 * CLC-INTERCAL is copyrighted software. However, permission to use, modify,
 * and distribute it is granted provided that the conditions set out in the
 * licence agreement are met. See files README and COPYING in the distribution.
 *
 * PERVERSION CLC-INTERCAL/Base links/Numbers-C.xs 1.-94.-2.5
 */

#ifdef __cplusplus
extern "C" {
#endif

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#ifdef __cplusplus
}
#endif

/* Language::INTERCAL::RegTypes defines these, but they MUST have
 * valye 1 and 2 respectively, so no need to import from there */
#define REG_spot    1
#define REG_twospot 2

STATIC U16 twospotbits[8] = {0, 0, 32, 20, 16, 12, 12, 10};
STATIC U16 spotbits[8] = {0, 0, 16, 10, 8, 6, 6, 5};

STATIC void faint_digits(U16 base, U32 n) {
    dSP;
    ENTER;
    SAVETMPS;
    EXTEND(SP, 2);
    PUSHs(sv_2mortal(newSVuv(base)));
    PUSHs(sv_2mortal(newSVuv(n)));
    PUTBACK;
    call_pv("_faint_digits", G_VOID);
    FREETMPS;
    LEAVE;
}

STATIC void faint_invalid(U16 spots) {
    dSP;
    ENTER;
    SAVETMPS;
    EXTEND(SP, 1);
    PUSHs(sv_2mortal(newSVuv(spots)));
    PUTBACK;
    call_pv("_invalid", G_VOID);
    FREETMPS;
    LEAVE;
}

/* optimised version of "BUT 0" aka unary AND */
STATIC U32 n_and(U32 num, U16 spots, U16 base) {
    if (! (spots == REG_spot || spots == REG_twospot)) faint_invalid(spots);
    if (base == 2) {
	U32 res = num >> 1;
	if (num & 1) res |= spots > 1 ? 0x80000000UL : 0x8000UL;
	return res & num;
    } else if (base == 4) {
	/* this is copied from n_or (see below) except that we have an
	 * additional mask to make sure a zero gets always preferred */
	U32 mask1, mask2, res;
	if (spots < 2) {
	    U32 n1, n2, r1, r2, m, lm, um;
	    res = (num >> 2) | ((num & 0x03) << 14);
	    n1 = num & 0xccccUL;
	    n2 = num & 0x3333UL;
	    r1 = res & 0xccccUL;
	    r2 = res & 0x3333UL;
	    m = (((n1 << 1) | n1 | (n1 >> 1)) & ((r1 << 1) | r1 | (r1 >> 1)) & 0xccccUL)
	      | (((n2 << 1) | n2 | (n2 >> 1)) & ((r2 << 1) | r2 | (r2 >> 1)) & 0x3333UL);
	    lm = ((res & 0x3333UL) + 0x44444UL - (num & 0x3333UL)) & 0x44444UL;
	    lm = (lm >> 1) | (lm >> 2);
	    um = ((res & 0xccccUL) + 0x11111UL - (num & 0xccccUL)) & 0x11111UL;
	    um = (um >> 1) | (um >> 2);
	    mask1 = (lm | um) & m;
	    mask2 = (~mask1) & m;
	} else {
	    U32 n1, n2, r1, r2, m, rhi, nhi, lm, lmhi, lmlo, rlo, nlo, um, umhi, umlo;
	    res = (num >> 2) | ((num & 0x03) << 30);
	    n1 = num & 0xccccccccUL;
	    n2 = num & 0x33333333UL;
	    r1 = res & 0xccccccccUL;
	    r2 = res & 0x33333333UL;
	    m = ((((n1 & 0x7fffffffUL) << 1) | n1 | (n1 >> 1)) &
		 (((r1 & 0x7fffffffUL) << 1) | r1 | (r1 >> 1)) & 0xccccccccUL)
	      | (((n2 << 1) | n2 | (n2 >> 1)) &
		 ((r2 << 1) | r2 | (r2 >> 1)) & 0x33333333UL);
	    rhi = res >> 16;
	    nhi = num >> 16;
	    lmhi = ((rhi & 0x3333UL) + 0x44444UL - (nhi & 0x3333UL)) & 0x44444UL;
	    lmhi = (lmhi >> 1) | (lmhi >> 2);
	    umhi = ((rhi & 0xccccUL) + 0x11111UL - (nhi & 0xccccUL)) & 0x11111UL;
	    umhi = (umhi >> 1) | (umhi >> 2);
	    rlo = res & 0xffffUL;
	    nlo = num & 0xffffUL;
	    lmlo = ((rlo & 0x3333UL) + 0x44444UL - (nlo & 0x3333UL)) & 0x44444UL;
	    lmlo = (lmlo >> 1) | (lmlo >> 2);
	    umlo = ((rlo & 0xccccUL) + 0x11111UL - (nlo & 0xccccUL)) & 0x11111UL;
	    umlo = (umlo >> 1) | (umlo >> 2);
	    mask1 = (((lmhi | umhi) << 16) | ((lmlo | umlo) & 0xffffUL)) & m;
	    mask2 = (~mask1) & m;
	}
	return (res & mask1) | (num & mask2);
    } else {
	U32 carry = num % base, mul = 1, high = carry, res = 0;
	U16 bits = spots > 1 ? twospotbits[base] : spotbits[base], b;
	num /= base;
	for (b = 1; b < bits; b++) {
	    U32 bit = num % base;
	    num /= base;
	    if (bit && carry)
		res += mul * (carry < bit ? bit : carry);
	    carry = bit;
	    mul *= base;
	}
	if (high && carry)
	    res += mul * (carry < high ? high : carry);
	return res;
    }
}

/* optimised version of "BUT 7" aka unary OR */
STATIC U32 n_or(U32 num, U16 spots, U16 base) {
    if (! (spots == REG_spot || spots == REG_twospot)) faint_invalid(spots);
    if (base == 2) {
	U32 res = num >> 1;
	if (num & 1) res |= spots > 1 ? 0x80000000UL : 0x8000UL;
	return res | num;
    } else if (base == 4) {
	/* for each pair of digits, d1 and d2, we find if d1 < d2 by
	 * checking the carry of (d1 - d2). Actually we do (4 + d1 - d2)
	 * so there is a carry if d1 >= d2 and no carry otherwise.
	 * We then convert this into a 2-bit mask: 00 == no carry, 11 == carry
	 * and use that to select which digit to use; it's a "digit-wise"
	 * max() which uses only arithmetic and bitwise operators.
	 * It would work on two-spod numbers using 32 bit unsigned integers
	 * however perl may notice the overflow and use floats instead, which
	 * produce an incorrect result; "use integer" may also fail depending
	 * on how the underlying integers behave.
	 * Since we cannot assume a 64-bit system, we do the calculation for
	 * one-spot only: for two-spot, we do it twice, each time with one
	 * half of the number. */
	U32 mask, res;
	if (spots < 2) {
	    U32 lm, um;
	    res = (num >> 2) | ((num & 0x03) << 14);
	    lm = ((res & 0x3333UL) + 0x44444UL - (num & 0x3333UL)) & 0x44444UL;
	    lm = (lm >> 1) | (lm >> 2);
	    um = ((res & 0xccccUL) + 0x11111UL - (num & 0xccccUL)) & 0x11111UL;
	    um = (um >> 1) | (um >> 2);
	    mask = (lm | um) & 0xffffUL;
	} else {
	    U32 rhi, nhi, lmhi, umhi, rlo, nlo, lmlo, umlo;
	    res = (num >> 2) | ((num & 0x03) << 30);
	    rhi = res >> 16;
	    nhi = num >> 16;
	    lmhi = ((rhi & 0x3333UL) + 0x44444UL - (nhi & 0x3333UL)) & 0x44444UL;
	    lmhi = (lmhi >> 1) | (lmhi >> 2);
	    umhi = ((rhi & 0xccccUL) + 0x11111UL - (nhi & 0xccccUL)) & 0x11111UL;
	    umhi = (umhi >> 1) | (umhi >> 2);
	    rlo = res & 0xffffUL;
	    nlo = num & 0xffffUL;
	    lmlo = ((rlo & 0x3333UL) + 0x44444UL - (nlo & 0x3333UL)) & 0x44444UL;
	    lmlo = (lmlo >> 1) | (lmlo >> 2);
	    umlo = ((rlo & 0xccccUL) + 0x11111UL - (nlo & 0xccccUL)) & 0x11111UL;
	    umlo = (umlo >> 1) | (umlo >> 2);
	    mask = ((lmhi | umhi) << 16) | ((lmlo | umlo) & 0xffffUL);
	}
	return (res & mask) | (num & ~mask);
    } else {
	U32 carry = num % base, mul = 1, high = carry, res = 0;
	U16 bits = spots > 1 ? twospotbits[base] : spotbits[base], b;
	num /= base;
	for (b = 1; b < bits; b++) {
	    U32 bit = num % base;
	    num /= base;
	    res += mul * (carry < bit ? bit : carry);
	    carry = bit;
	    mul *= base;
	}
	res += mul * (carry < high ? high : carry);
	return res;
    }
}

MODULE = Language::INTERCAL::Numbers	PACKAGE = Language::INTERCAL::Numbers

U32
n_interleave (n1, n2, base)
	U32 n1
	U32 n2
	U16 base
    PROTOTYPE: $$$
    CODE:
	if (base == 2) {
	    if (n1 > 0xffff) faint_digits(base, n1);
	    if (n2 > 0xffff) faint_digits(base, n2);
	    /*                                                                0000000000000000abcdefghjklmnpqr */
	    n1 =  ((n1 & 0x000000ffUL) << 1) | ((n1 & 0x0000ff00UL) << 9); /* 0000000abcdefgh00000000jklmnpqr0 */
	    n1 =   (n1 & 0x001e001eUL)       | ((n1 & 0x01e001e0UL) << 4); /* 000abcd0000efgh0000jklm0000npqr0 */
	    n1 =   (n1 & 0x06060606UL)       | ((n1 & 0x18181818UL) << 2); /* 0ab00cd00ef00gh00jk00lm00np00qr0 */
	    n1 =   (n1 & 0x22222222UL)       | ((n1 & 0x44444444UL) << 1); /* a0b0c0d0e0f0g0h0j0k0l0m0n0p0q0r0 */
	    /*                                                                0000000000000000abcdefghjklmnpqr */
	    n2 =   (n2 & 0x000000ffUL)       | ((n2 & 0x0000ff00UL) << 8); /* 00000000abcdefgh00000000jklmnpqr */
	    n2 =   (n2 & 0x000f000fUL)       | ((n2 & 0x00f000f0UL) << 4); /* 0000abcd0000efgh0000jklm0000npqr */
	    n2 =   (n2 & 0x03030303UL)       | ((n2 & 0x0c0c0c0cUL) << 2); /* 00ab00cd00ef00gh00jk00lm00np00qr */
	    n2 =   (n2 & 0x11111111UL)       | ((n2 & 0x22222222UL) << 1); /* 0a0b0c0d0e0f0g0h0j0k0l0m0n0p0q0r */
	    RETVAL = n1 | n2;
	} else if (base == 4) {
	    if (n1 > 0xffff) faint_digits(base, n1);
	    if (n2 > 0xffff) faint_digits(base, n2);
	    /*                                                                 00000000abcdefgh */
	    n1 =  ((n1 & 0x000000ffUL) << 2) | ((n1 & 0x0000ff00UL) << 10); /* 000abcd0000efgh0 */
	    n1 =   (n1 & 0x003c003cUL)       | ((n1 & 0x03c003c0UL) << 4);  /* 0ab00cd00ef00gh0 */
	    n1 =   (n1 & 0x0c0c0c0cUL)       | ((n1 & 0x30303030UL) << 2);  /* a0b0c0d0e0f0g0h0 */
	    /*                                                                 00000000abcdefgh */
	    n2 =   (n2 & 0x000000ffUL)       | ((n2 & 0x0000ff00UL) << 8);  /* 0000abcd0000efgh */
	    n2 =   (n2 & 0x000f000fUL)       | ((n2 & 0x00f000f0UL) << 4);  /* 00ab00cd00ef00gh */
	    n2 =   (n2 & 0x03030303UL)       | ((n2 & 0x0c0c0c0cUL) << 2);  /* 0a0b0c0d0e0f0g0h */
	    RETVAL = n1 | n2;
	} else {
	    U32 orig1 = n1, orig2 = n2, mul = 1;
	    U16 bits = spotbits[base], b;
	    RETVAL = 0;
	    for (b = 0; b < bits && (n1 || n2); b++) {
		U32 b1 = n1 % base, b2 = n2 % base;
		n1 /= base;
		n2 /= base;
		RETVAL += b2 * mul;
		mul *= base;
		RETVAL += b1 * mul;
		mul *= base;
	    }
	    if (n1) faint_digits(base, orig1);
	    if (n2) faint_digits(base, orig2);
	}
    OUTPUT:
	RETVAL

U32
n_select(n1, n2, base)
	U32 n1
	U32 n2
	U16 base
    PROTOTYPE: $$$
    CODE:
	RETVAL = 0;
	if (base == 2) {
	    U32 bit = 1;
	    while (n2) {
		while (! (n2 & 1)) {
		    n1 >>= 1;
		    n2 >>= 1;
		}
		RETVAL |= n1 & bit;
		n2 >>= 1;
		bit <<= 1;
	    }
	} else {
	    U32 i, num[7], mul[7];
	    for (i = 0; i < 7; i++) {
		num[i] = 0;
		mul[i] = 1;
	    }
	    while (n2) {
		U32 b1 = n1 % base, b2 = n2 % base;
		n1 /= base;
		n2 /= base;
		if (b2) {
		    if (b1)
			num[b2] += mul[b2] * (b1 > b2 ? b1 : b2);
		    mul[b2] *= base;
		}
	    }
	    for (i = 1; i < base; i++)
		RETVAL = RETVAL * mul[i] + num[i];
	}
    OUTPUT:
	RETVAL

U32
n_swb (num, spots, base)
	U32 num
	U16 spots
	U16 base
    PROTOTYPE: $$$
    CODE:
	if (! (spots == REG_spot || spots == REG_twospot)) faint_invalid(spots);
	if (base == 2) {
	    RETVAL = num >> 1;
	    if (num & 1) RETVAL |= spots > 1 ? 0x80000000UL : 0x8000UL;
	    RETVAL ^= num;
	} else if (base == 4) {
	    if (spots > 1) {
		U32 hi = (num >> 18) | ((num & 0x3UL) << 14);
		U32 lo = (num >> 2) & 0xffffUL;
		U32 nh = num >> 16;
		hi = (((hi & 0x3333UL) + 0xccccUL - (nh & 0x3333UL)) & 0x3333UL)
		   | (((hi & 0xccccUL) + 0x3330UL - (nh & 0xccccUL)) & 0xccccUL);
		lo = (((lo & 0x3333UL) + 0xccccUL - (num & 0x3333UL)) & 0x3333UL)
		   | (((lo & 0xccccUL) + 0x3330UL - (num & 0xccccUL)) & 0xccccUL);
		RETVAL = (hi << 16) | lo;
	    } else {
		RETVAL = (num >> 2) | ((num & 0x3) << 14);
		RETVAL = (((RETVAL & 0x3333UL) + 0xccccUL - (num & 0x3333UL)) & 0x3333UL)
		       | (((RETVAL & 0xccccUL) + 0x3330UL - (num & 0xccccUL)) & 0xccccUL);
	    }
	} else {
	    U32 carry = num % base, mul = 1, high = carry;
	    U16 bits = spots > 1 ? twospotbits[base] : spotbits[base], b;
	    num /= base;
	    RETVAL = 0;
	    for (b = 1; b < bits; b++) {
		U32 bit = num % base, sw;
		num /= base;
		sw = bit;
		if (bit < carry) bit += base;
		bit -= carry;
		carry = sw;
		sw = bit - carry;
		RETVAL += bit * mul;
		mul *= base;
	    }
	    if (high < carry) high += base;
	    high -= carry;
	    RETVAL += high * mul;
	}
    OUTPUT:
	RETVAL

U32
n_awc (num, spots, base)
	U32 num
	U16 spots
	U16 base
    PROTOTYPE: $$$
    CODE:
	if (! (spots == REG_spot || spots == REG_twospot)) faint_invalid(spots);
	if (base == 2) {
	    RETVAL = num >> 1;
	    if (num & 1) RETVAL |= spots > 1 ? 0x80000000UL : 0x8000UL;
	    RETVAL ^= num;
	} else if (base == 4) {
	    if (spots > 1) {
		U32 hi = (num >> 18) | ((num & 0x3) << 14);
		U32 lo = (num >> 2) & 0xffff;
		U32 nh = num >> 16;
		hi = (((nh & 0x3333UL) + (hi & 0x3333UL)) & 0x3333UL)
		   | (((nh & 0xccccUL) + (hi & 0xccccUL)) & 0xccccUL);
		lo = (((num & 0x3333UL) + (lo & 0x3333UL)) & 0x3333UL)
		   | (((num & 0xccccUL) + (lo & 0xccccUL)) & 0xccccUL);
		RETVAL = (hi << 16) | lo;
	    } else {
		RETVAL = (num >> 2) | ((num & 0x3) << 14);
		RETVAL = (((num & 0x3333UL) + (RETVAL & 0x3333UL)) & 0x3333UL)
		       | (((num & 0xccccUL) + (RETVAL & 0xccccUL)) & 0xccccUL);
	    }
	} else {
	    U32 carry = num % base, mul = 1, high = carry;
	    U16 bits = spots > 1 ? twospotbits[base] : spotbits[base], b;
	    num /= base;
	    RETVAL = 0;
	    for (b = 1; b < bits; b++) {
		U32 bit = num % base, sw;
		num /= base;
		sw = bit;
		bit += carry;
		if (bit >= base) bit -= base;
		carry = sw;
		RETVAL += bit * mul;
		mul *= base;
	    }
	    high += carry;
	    if (high >= base) high -= base;
	    RETVAL += high * mul;
	}
    OUTPUT:
	RETVAL

U32
n_and (num, spots, base)
	U32 num
	U16 spots
	U16 base
    PROTOTYPE: $$$

U32
n_or (num, spots, base)
	U32 num
	U16 spots
	U16 base
    PROTOTYPE: $$$

U32
n_but (num, spots, base, prefer)
	U32 num;
	U16 spots;
	U16 base;
	U16 prefer;
    PROTOTYPE: $$$$
    CODE:
	if (! (spots == REG_spot || spots == REG_twospot)) faint_invalid(spots);
	if (prefer > 0 && prefer < base - 1) {
	    U32 carry = num % base, mul = 1, high = carry;
	    U16 bits = spots > 1 ? twospotbits[base] : spotbits[base], b;
	    num /= base;
	    RETVAL = 0;
	    for (b = 1; b < bits; b++) {
		U32 bit = num % base;
		num /= base;
		if (bit <= prefer) {
		    if (carry < bit || carry > prefer) {
			RETVAL += bit * mul;
		    } else {
			RETVAL += carry * mul;
		    }
		} else {
		    if (carry < bit && carry > prefer) {
			RETVAL += bit * mul;
		    } else {
			RETVAL += carry * mul;
		    }
		}
		carry = bit;
		mul *= base;
	    }
	    if (high <= prefer) {
		if (carry < high || carry > prefer) {
		    RETVAL += high * mul;
		} else {
		    RETVAL += carry * mul;
		}
	    } else {
		if (carry < high && carry > prefer) {
		    RETVAL += high * mul;
		} else {
		    RETVAL += carry * mul;
		}
	    }
	} else if (prefer == 7) {
	    RETVAL = n_or(num, spots, base);
	} else if (prefer == 0) {
	    RETVAL = n_and(num, spots, base);
	} else {
	    dSP;
	    ENTER;
	    SAVETMPS;
	    EXTEND(SP, 2);
	    PUSHs(sv_2mortal(newSVuv(prefer)));
	    PUSHs(sv_2mortal(newSVuv(base)));
	    PUTBACK;
	    call_pv("_faint_but", G_VOID);
	    FREETMPS;
	    LEAVE;
	}
    OUTPUT:
	RETVAL

